Changeset 13677 in project for chicken/trunk/utils.scm


Ignore:
Timestamp:
03/11/09 03:23:24 (12 years ago)
Author:
Kon Lovett
Message:

Moved 'apropos' out. Added routines to encapsulate information the new apropos extension needs

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/utils.scm

    r12937 r13677  
    2828(declare
    2929  (unit utils)
    30   (uses regex data-structures extras files srfi-13)
     30  (uses extras srfi-13)
    3131  (usual-integrations)
    3232  (fixnum)
     
    4141      ##sys#windows-platform)
    4242    (bound-to-procedure
    43       string-search string-match regexp regexp-escape
    44       ##sys#symbol-has-toplevel-binding? ##sys#environment-symbols
    45       ##sys#hash-table-for-each ##sys#macro-environment
    46       ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
    47       for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
    48       decompose-pathname absolute-pathname? string-append ##sys#substring
    49       delete-file system)
     43      ##sys#check-port port? read-string for-each-line read-line with-input-from-file
     44      command-line-arguments
     45      string-append
     46      system)
    5047    (no-procedure-checks-for-usual-bindings)
    5148    (no-bound-checks))] )
     
    5451
    5552(register-feature! 'utils)
    56 
    57 
    58 ;;; Environment utilities
    59 
    60 (define ##sys#apropos-interned)
    61 (define ##sys#apropos-macros)
    62 (let ([string-search string-search]
    63       [regexp regexp]
    64       [regexp-escape regexp-escape])
    65   (let ([makpat
    66          (lambda (patt)
    67            (when (symbol? patt)
    68              (set! patt (symbol->string patt)))
    69            (when (string? patt)
    70              (set! patt (regexp (regexp-escape patt))))
    71            patt)])
    72 
    73     (set! ##sys#apropos-interned
    74       (lambda (patt env)
    75         (set! patt (makpat patt))
    76         (##sys#environment-symbols env
    77           (lambda (sym)
    78             (and (string-search patt (symbol->string sym))
    79                  (##sys#symbol-has-toplevel-binding? sym) ) ) ) ) )
    80 
    81     (set! ##sys#apropos-macros
    82       (lambda (patt env) ; env is currently ignored
    83         (set! patt (makpat patt))
    84         (let ([ms '()])
    85           (for-each
    86            (lambda (a)
    87              (let ((key (car a)))
    88                (when (string-search patt (symbol->string key))
    89                  (set! ms (cons key ms)) ) ) )
    90            (##sys#macro-environment))
    91           ms ) ) ) ) )
    92 
    93 (define (##sys#apropos patt env #!optional macf)
    94   (let ([ts (##sys#apropos-interned patt env)])
    95     (if macf
    96         (##sys#append ts (##sys#apropos-macros patt env))
    97         ts ) ) )
    98 
    99 (define apropos-list)
    100 (define apropos)
    101 (let ([%apropos-list
    102         (lambda (loc patt args) ; #!optional (env (interaction-environment)) #!key macros?
    103           (let ([env (interaction-environment)]
    104                 [macros? #f])
    105             ; Handle extended lambda list optional & rest w/ keywords
    106             (let loop ([args args])
    107               (when (pair? args)
    108                 (let ([arg (car args)])
    109                   (if (eq? #:macros? arg)
    110                       (begin
    111                         (set! macros? (cadr args))
    112                         (loop (cddr args)) )
    113                       (begin
    114                         (set! env arg)
    115                         (loop (cdr args)) ) ) ) ) )
    116             (##sys#check-structure env 'environment loc)
    117             (unless (or (string? patt) (symbol? patt) (regexp? patt))
    118               (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" patt))
    119             (##sys#apropos patt env macros?) ) )]
    120       [disp-proc
    121         (lambda (proc labl)
    122           (let ([info (procedure-information proc)])
    123             (cond [(pair? info) (display (cons labl (cdr info)))]
    124                   [info         (display labl)]
    125                   [else         (display labl) ] ) ) ) ]
    126       [symlen
    127         (lambda (sym)
    128           (let ([len (##sys#size (##sys#symbol->qualified-string sym))])
    129             (if (keyword? sym)
    130                 (fx- len 2) ; compensate for leading '###' when only a ':' is printed
    131                 len ) ) )])
    132 
    133   (set! apropos-list
    134     (lambda (patt . rest)
    135       (%apropos-list 'apropos-list patt rest)))
    136 
    137   (set! apropos
    138     (lambda (patt . rest)
    139       (let ([ss (%apropos-list 'apropos patt rest)]
    140             [maxlen 0])
    141         (for-each
    142           (lambda (sym)
    143             (set! maxlen (fxmax maxlen (symlen sym))))
    144           ss)
    145         (for-each
    146           (lambda (sym)
    147             (display sym)
    148             (do ([i (fx- maxlen (symlen sym)) (fx- i 1)])
    149                 [(fx<= i 0)]
    150               (display #\space))
    151             (display #\space) (display #\:) (display #\space)
    152             (if (macro? sym)
    153                 ;FIXME want to display macro lambda arguments
    154                 (display 'macro)
    155                 (let ([bnd (##core#inline "C_retrieve" sym)])
    156                   (cond [(procedure? bnd)
    157                           (disp-proc bnd 'procedure)]
    158                         [else
    159                           (display 'variable)]) ) )
    160             (newline) )
    161           ss)))) )
    16253
    16354
Note: See TracChangeset for help on using the changeset viewer.