Changeset 13724 in project


Ignore:
Timestamp:
03/13/09 00:46:30 (11 years ago)
Author:
Kon Lovett
Message:

Comments, reflow, defaults vars, ##sys#macro?

File:
1 edited

Legend:

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

    r13715 r13724  
    2222  (no-procedure-checks)
    2323  (bound-to-procedure
    24     ##sys#current-environment ##sys#syntactic-environment? ##sys#syntactic-environment-symbols
     24    ##sys#current-environment ##sys#macro-environment
     25    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols ##sys#macro?
    2526    ##sys#environment? ##sys#environment-symbols
    2627    ##sys#qualified-symbol? ##sys#symbol->qualified-string
     
    4041
    4142(define-inline (%check-search-pattern loc obj)
    42   (unless (or (string? obj) (symbol? obj) (regexp? obj))
     43  (unless (or (string? obj) (and (symbol? obj) (not (keyword? obj))) (regexp? obj))
    4344    (error-invalid-search loc patt) ) )
    4445
     
    6364(import scheme chicken regex lolevel data-structures)
    6465
    65 ;;; Suuport
     66;;; Support
    6667
    6768;; Errors
     
    106107  (##sys#environment-symbols
    107108    env
    108     (lambda (sym)
    109       (and (symbol-match? sym regexp) (pred sym)))) )
     109    (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
    110110
    111111(define (search-macro-environment macenv regexp pred)
    112112  (##sys#syntactic-environment-symbols
    113113    macenv
    114     (lambda (sym)
    115       (and (symbol-match? sym regexp) (pred sym)))) )
     114    (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
    116115
    117116;; Environment Search -> List
     117
     118(define (environment-predicate qualified?)
     119  (if qualified? global-bound?
     120      (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))) ) )
     121
     122(define (macro-environment-predicate qualified?)
     123  (if qualified? any?
     124      (lambda (x) (not (##sys#qualified-symbol? x))) ) )
    118125
    119126(define (*apropos-list loc regexp env macenv qualified?)
    120127  (append
    121    (search-environment
    122      env
    123      regexp
    124      (if qualified? global-bound?
    125          (lambda (x)
    126            (and (not (##sys#qualified-symbol? x)) (global-bound? x)))))
     128   (search-environment env regexp (environment-predicate qualified?))
    127129    (if (not macenv) '()
    128         (search-macro-environment
    129          macenv
    130          regexp
    131          (if qualified? any?
    132              (lambda (x)
    133                (not (##sys#qualified-symbol? x))))))) )
     130        (search-macro-environment macenv regexp (macro-environment-predicate qualified?)))) )
    134131
    135132(define (*apropos-list/environment loc regexp env macenv qualified?)
    136   (if macenv (search-macro-environment env regexp #f)
    137       (search-environment
    138         env
    139         regexp
    140         (if qualified? global-bound?
    141             (lambda (x)
    142               (and (not (##sys#qualified-symbol? x)) (global-bound? x)) ) ) ) ) )
     133  (if macenv (search-macro-environment env regexp (macro-environment-predicate qualified?))
     134      (search-environment env regexp (environment-predicate qualified?) ) ) )
    143135
    144136;; Argument List Parsing
     137
     138(define default-environment interaction-environment)
     139(define default-macro-environment ##sys#macro-environment)
    145140
    146141(define (make-apropos-regexp patt)
     
    149144  patt )
    150145
    151 ; #!optional (env (interaction-environment)) macenv
     146; #!optional (env (default-environment)) macenv
    152147; #!key macros? qualified?
    153148;
    154 ; macenv is #t for default macro environment (##sys#current-environment) or a
    155 ; syntactic-environment object.
     149; macenv is #t for default macro environment or a syntactic-environment object.
    156150;
    157 ; => (values macenv qualified? syms)
     151; => (values macenv syms)
    158152(define (parse-arguments loc patt args)
    159153  (define (parse-rest-arguments args)
    160     (let ((env (interaction-environment))
     154    (let ((env (default-environment))
    161155          (macenv #f)
    162156          (qualified? #f)
    163157          (1st-optarg #t)) ;keyword argument not considered an optional argument here
    164158      (let loop ((args args))
    165         (if (null? args) (values env qualified? macenv)
     159        (if (null? args) (values env macenv qualified?)
    166160            (let ((arg (car args)))
    167161                    ;keyword argument?
    168162              (cond ((eq? #:macros? arg)
    169                       (when (cadr args) (set! macenv (##sys#current-environment)))
     163                      (when (cadr args) (set! macenv (default-macro-environment)))
    170164                      (loop (cddr args)) )
    171165                    ((eq? #:qualified? arg)
     
    177171                      (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
    178172                            ;default macro environment?
    179                             ((boolean? args) (set! macenv (##sys#current-environment)))
     173                            ((boolean? args) (set! macenv (default-macro-environment)))
    180174                            ;specific macro environment?
    181175                            (else (set! macenv arg)))
     
    190184    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?)) ) )
    191185
     186; #!key qualified?
     187;
    192188; => (values macenv syms)
    193189(define (parse-arguments/environment loc patt env qualified?)
     
    196192    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?)) ) )
    197193
     194; #!key qualified?
     195;
    198196; => (... (macenv . syms) ...)
    199197(define (parse-arguments/environments loc patt args)
     
    215213        (if (null? envs) (reverse envsyms)
    216214            (let* ((env (car envs))
    217                    (macenv (check-any-environment/->syntactic-environment? loc env)) )
    218               (loop
    219                 (cdr envs)
    220                 (cons
    221                   `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?))
    222                   envsyms)) ) ) ) ) ) )
     215                   (macenv (check-any-environment/->syntactic-environment? loc env))
     216                   (make-envsyms
     217                    (lambda ()
     218                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
     219              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
    223220
    224221
     
    231228
    232229(define (apropos-information sym macenv)
    233   (cond ((and macenv (macro? sym macenv)) 'macro)
    234         ((keyword? sym)                   'keyword)
     230  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
     231        ((keyword? sym) 'keyword)
    235232        (else
    236233          (let ((binding (global-ref sym)))
    237             (if (procedure? binding) (apropos-procedure-information binding) )
    238                 'identifier ) ) ) )
     234            (if (procedure? binding) (apropos-procedure-information binding)
     235                'identifier ) ) ) ) )
    239236
    240237(define (display-spaces cnt)
     
    305302    (lambda (macenv+syms)
    306303      (let ((macenv (car macenv+syms)))
    307         (map
    308           (lambda (sym) (cons sym (apropos-information sym macenv)))
    309           (cdr macenv+syms)) ) )
     304        (map (lambda (sym) (cons sym (apropos-information sym macenv))) (cdr macenv+syms)) ) )
    310305    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
    311306
Note: See TracChangeset for help on using the changeset viewer.