Changeset 13688 in project


Ignore:
Timestamp:
03/12/09 06:35:53 (11 years ago)
Author:
Kon Lovett
Message:

Use of core immutable.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/apropos/trunk/apropos.scm

    r13680 r13688  
    2121  (no-procedure-checks)
    2222  (bound-to-procedure
    23     ##sys#current-environment ##sys#macro-environment
    24     ##sys#syntactic-environment? ##sys#syntactic-environment-symbols
     23    ##sys#current-environment ##sys#syntactic-environment? ##sys#syntactic-environment-symbols
    2524    ##sys#environment? ##sys#environment-symbols
    2625    ##sys#symbol->qualified-string
     
    3837
    3938(define-inline (%error-invalid-search loc obj)
    40   (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" obj) )
     39  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a string, symbol, or regexp") obj) )
    4140
    4241(define-inline (%error-invalid-environment loc obj)
    43   (##sys#signal-hook #:type-error loc "bad argument type - not an environment" obj) )
     42  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not an environment") obj) )
    4443
    4544(define-inline (%error-invalid-macro-environment loc obj)
    46   (##sys#signal-hook #:type-error loc "bad argument type - not a macro environment" obj) )
     45  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a macro environment") obj) )
     46
     47(define-inline (%error-invalid-any-environment loc obj)
     48  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not an environment or macro environment") obj) )
    4749
    4850;; Argument Checking
     
    5355
    5456(define-inline (%check-macro-environment loc obj)
    55   (unless (##sys#syntactic-environment? obj)
     57  (unless (or (not obj) (##sys#syntactic-environment? obj))
    5658    (%error-invalid-macro-environment loc obj) ) )
    5759
     
    6365
    6466(module apropos (;export
    65   ;
     67  ; Original
    6668  apropos
    6769  apropos-list
    6870  apropos-information-list
    69   ;
    70   environment-apropos
    71   environment-apropos-list
    72   environment-apropos-information-list)
     71  ; Crispy
     72  apropos/environment
     73  apropos-list/environment
     74  apropos-information-list/environment
     75  ; Extra Crispy
     76  apropos/environments
     77  apropos-list/environments
     78  apropos-information-list/environments)
    7379
    7480(import scheme chicken regex lolevel)
    7581
    7682;;; Suuport
     83
     84;;
     85
     86(define (check-any-environment/->syntactic-environment? loc obj)
     87  (cond ((##sys#environment? obj)           #f)
     88        ((##sys#syntactic-environment? obj) obj)
     89        (else
     90          (%error-invalid-any-environment loc obj) ) ) )
    7791
    7892;; Symbols
     
    8094(define (symbol-string-length sym)
    8195  (let ((len (string-length (##sys#symbol->qualified-string sym))))
    82     (if (keyword? sym)
    83         (- len 2) ; compensate for leading '###' when only a ':' is printed
     96    (if (keyword? sym) (- len 2) ;compensate for leading '##'
    8497        len ) ) )
    8598
    86 (define (largest-symbol-string-length syms)
     99(define (max-symbol-print-width syms)
    87100  (let ((maxlen 0))
    88101    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-string-length sym)))) syms)
     
    99112  (##sys#syntactic-environment-symbols macenv (cut symbol-match? <> regexp)) )
    100113
    101 ;;
     114(define (*apropos-list loc regexp env macenv)
     115  (append
     116   (search-environment env regexp global-bound?)
     117   (if macenv (search-macro-environment macenv regexp) '())) )
     118
     119(define (*apropos-list/environment loc regexp env macenv)
     120  (if macenv (search-macro-environment env regexp)
     121      (search-environment env regexp global-bound?) ) )
     122
     123;;
    102124
    103125(define (make-apropos-regexp patt)
     
    109131; #!key macros?
    110132;
    111 ; macenv is #t for (##sys#current-environment) or a syntactic-environment object
    112 
    113 (define (parse-rest-arguments args)
    114   (let ((env (interaction-environment))
    115         (macenv #f)
    116         (1st-optarg #t)) ;keyword argument not considered an optional argument here
    117     (let loop ((args args))
    118       (when (pair? args)
    119         (let ((arg (car args)))
    120           (cond ((eq? #:macros? arg)
    121                  (when (cadr args) (set! macenv (##sys#macro-environment)))
    122                  (loop (cddr args)) )
    123                 (arg
    124                  (cond (1st-optarg      ;specific environment
    125                         (set! env arg)
    126                         (set! 1st-optarg #f) )
    127                        ((boolean? args) ;default macro environment
    128                         (set! macenv (##sys#current-environment)) )
    129                        (else            ;specific macro environment
    130                         (set! macenv arg) ) )
    131                  (loop (cdr args)) )
    132                 (else ;accept #f for macenv flag
    133                  (loop (cdr args)) ) ) ) )
    134     (values env macenv) ) ) )
    135 
     133; macenv is #t for default macro environment (##sys#current-environment) or a
     134; syntactic-environment object.
     135;
     136; => (values macenv syms)
    136137(define (parse-arguments loc patt args)
     138  (define (parse-rest-arguments loc args)
     139    (let ((env (interaction-environment))
     140          (macenv #f)
     141          (1st-optarg #t)) ;keyword argument not considered an optional argument here
     142      (let loop ((args args))
     143        (when (pair? args)
     144          (let ((arg (car args)))
     145                  ;keyword argument?
     146            (cond ((eq? #:macros? arg)
     147                    (when (cadr args) (set! macenv #t))
     148                    (loop (cddr args)) )
     149                  ;optional argument?
     150                  (arg
     151                         ;specific environment?
     152                    (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
     153                          ;default macro environment?
     154                          ((boolean? args) (set! macenv (##sys#current-environment)))
     155                          ;specific macro environment?
     156                          (else (set! macenv arg)))
     157                    (loop (cdr args)) )
     158                  ;accept #f for macenv
     159                  (else
     160                    (loop (cdr args)) ) ) ) )
     161      (values env macenv) ) ) )
    137162  (%check-search-pattern loc patt)
    138   (let-values (((env macenv) (parse-rest-arguments args)))
     163  (receive (env macenv) (parse-rest-arguments loc args)
    139164    (%check-environment loc env)
    140165    (%check-macro-environment loc macenv)
    141     (values (make-apropos-regexp patt) env macenv) ) )
    142 
    143 (define (*apropos-list loc regexp env macenv)
    144   (append
    145    (search-environment env regexp global-bound?)
    146    (if macenv (search-macro-environment macenv regexp) '())) )
    147 
    148 (define (*environment-apropos-list loc regexp env)
    149   (cond ((##sys#environment? env)           (search-environment env regexp global-bound?))
    150         ((##sys#syntactic-environment? env) (search-macro-environment env regexp))
    151         (else
    152          (%error-invalid-environment 'environment-apropos-list env) ) ) )
     166    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv)) ) )
     167
     168; => (values macenv syms)
     169(define (parse-arguments/environment loc patt env)
     170  (%check-search-pattern loc patt)
     171  (let ((macenv (check-any-environment/->syntactic-environment? loc env)))
     172    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv)) ) )
     173
     174; => envsyms
     175(define (parse-arguments/environments loc patt envs)
     176  (%check-search-pattern loc patt)
     177  (let ((regexp (make-apropos-regexp patt)))
     178    (let loop ((envs envs) (envsyms '()))
     179      (if (null? envs) envsyms
     180          (let* ((env (car envs))
     181                 (macenv (check-any-environment/->syntactic-environment? loc env)) )
     182            (loop
     183              (cdr envs)
     184              (append
     185                envsyms
     186                `((,macenv . ,(*apropos-list/environment loc regexp env macenv))))) ) ) ) ) )
     187
    153188
    154189;; Display
     
    159194        `(procedure . ,(cdr info)) ) ) )
    160195
    161 (define (apropos-information sym env macenv)
    162   (cond ((macro? sym)   'macro )
    163         ((keyword? sym) 'keyword )
     196(define (apropos-information sym macenv)
     197  (cond ((and macenv (macro? sym macenv)) 'macro)
     198        ((keyword? sym)                   'keyword)
    164199        (else
    165          (let ((binding (global-ref sym)))
    166            (if (procedure? binding) (apropos-procedure-information proc) )
    167                'identifier ) ) ) )
     200          (let ((binding (global-ref sym)))
     201            (if (procedure? binding) (apropos-procedure-information proc) )
     202                'identifier ) ) ) )
    168203
    169204(define (display-spaces cnt)
    170205  (do ((i cnt (sub1 i)))
    171206      ((negative? i))
    172       (display #\space) ) )
    173 
    174 (define (display-symbol-information sym env macenv maxsymlen)
     207    (display #\space) ) )
     208
     209(define (display-symbol-information sym maxsymlen macenv)
    175210  (display sym) (display-spaces (- maxsymlen (symbol-string-length sym)))
    176   (let ((info (apropos-information sym)))
     211  (let ((info (apropos-information sym macenv)))
    177212    (display #\space)
    178213    (if (symbol? info) (display info)
    179        (begin (display (car info)) (display #\space) (display (cdr info)) ) ) )
     214        (begin (display (car info)) (display #\space) (display (cdr info)) ) ) )
    180215  (newline) )
    181216
     
    185220
    186221(define (apropos patt . rest)
    187   (let-values (((regexp env macenv) (parse-arguments args)))
    188     (let* ((syms (*apropos-list 'apropos regexp env macenv))
    189            (maxsymlen (largest-symbol-string-length syms)))
    190       (for-each (cut display-symbol-information <> env macenv maxsymlen) syms) ) ) )
     222  (receive (macenv syms) (parse-arguments 'apropos args)
     223    (let ((maxsymlen (max-symbol-print-width syms)))
     224      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
    191225
    192226(define (apropos-list patt . rest)
    193    (let-values (((regexp env macenv) (parse-arguments args)))
    194      (*apropos-list 'apropos-list regexp env macenv) ) )
     227  (receive (macenv syms) (parse-arguments 'apropos-list args) syms) )
    195228
    196229(define (apropos-information-list patt . rest)
    197    (let-values (((regexp env macenv) (parse-arguments args)))
    198     (map
    199      (lambda (sym) (list sym (apropos-information sym)))
    200      (*apropos-list 'apropos regexp env macenv)) ) )
     230  (receive (macenv syms) (parse-arguments 'apropos-information-list args)
     231    (map (lambda (sym) (list sym (apropos-information sym macenv))) syms) ) )
    201232
    202233;; Crispy
    203234
    204 (define (environment-apropos loc regexp env)
    205   (let-values (((regexp env macenv) (parse-arguments args)))
    206     (let* ((syms (*environment-apropos-list loc regexp env))
    207            (maxsymlen (largest-symbol-string-length syms)))
    208       (for-each (cut display-symbol-information <> env macenv maxsymlen) syms) ) ) )
    209 
    210 (define (environment-apropos-list loc regexp env)
    211   (let-values (((regexp env macenv) (parse-arguments args)))
    212     (*environment-apropos-list loc regexp env) ) )
    213 
    214 (define (environment-apropos-information-list loc regexp env)
    215   (let-values (((regexp env macenv) (parse-arguments args)))
    216     (map
    217      (lambda (sym) (list sym (apropos-information sym)))
    218      (*environment-apropos-list loc regexp env)) ) )
     235(define (apropos/environment patt env)
     236  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env)
     237    (let ((maxsymlen (max-symbol-print-width syms)))
     238      (newline)
     239      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
     240
     241(define (apropos-list/environment patt env)
     242  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env) syms) )
     243
     244(define (apropos-information-list/environment patt env)
     245  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env)
     246    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
     247
     248;; Extra Crispy
     249
     250(define (apropos/environments patt . envs)
     251  (let ((i 0))
     252    (for-each
     253      (lambda (macenv+syms)
     254        (set! i (add1 i))
     255        (newline) (print "** Environment " i " **") (newline)
     256        (let ((macenv (car macenv+syms))
     257              (syms (cdr macenv+syms)))
     258          (let ((maxsymlen (max-symbol-print-width syms))
     259            (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) ) )
     260      (parse-arguments/environments 'apropos/environments patt envs)) ) )
     261   
     262(define (apropos-list/environments patt . envs)
     263  (map cdr (parse-arguments/environments 'apropos-list/environments patt envs)) )
     264
     265(define (apropos-information-list/environments patt . envs)
     266  (map
     267    (lambda (macenv+syms)
     268      (let ((macenv (car macenv+syms)))
     269        (map
     270          (lambda (sym) (cons sym (apropos-information sym macenv)))
     271          (cdr macenv+syms)) ) )
     272    (parse-arguments/environments 'apropos-information-list/environments patt envs)) )
    219273
    220274) ;module apropos
Note: See TracChangeset for help on using the changeset viewer.