Changeset 13729 in project


Ignore:
Timestamp:
03/13/09 05:32:34 (11 years ago)
Author:
Kon Lovett
Message:

Added safe/unsafe, sorting, qualified symbols.

Location:
release/4/apropos/trunk
Files:
1 added
2 edited

Legend:

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

    r13679 r13729  
    99 (needs setup-helper)
    1010 (files
     11  "chicken-primitive-object-inlines.scm"
    1112  "tests"
    1213  "apropos.scm"
  • release/4/apropos/trunk/apropos.scm

    r13726 r13729  
    55;; Issues
    66;;
     7;; - Use of Unit lolevel 'global-' routines is just wrong when an
     8;; evaluation-environment (##sys#environment?) is not the
     9;; interaction-environment.
     10;;
    711;; - Doesn't show something similar to procedure-information for macros.
    812;;
     
    1115;; - Should be re-written to use the "environments" extension. Which in turn would
    1216;; need to support syntactic environments, at least for lookup opertations.
     17;;
     18;; - The Chicken 'environment' object does not hold the (syntactic) bindings
     19;; for all syntactic keywords from the R5RS. The public API of 'apropos'
     20;; attempts to hide this fact.
    1321
    1422;;; Prelude
     
    1624(declare
    1725  (usual-integrations)
    18   (disable-interrupts)
     26  #;(disable-interrupts)
    1927  (fixnum)
    2028  (inline)
     
    2230  (no-procedure-checks)
    2331  (bound-to-procedure
     32    ##sys#qualified-symbol? ##sys#symbol->qualified-string ##sys#qualified-symbol-prefix
     33    ##sys#symbol->string
    2434    ##sys#current-environment ##sys#macro-environment
    2535    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols ##sys#macro?
    2636    ##sys#environment? ##sys#environment-symbols
    27     ##sys#qualified-symbol? ##sys#symbol->qualified-string
    28     ##sys#signal-hook ) )
    29 
    30 ;;; Support
     37    ##sys#signal-hook))
     38
     39;;
     40
     41(cond-expand
     42  (unsafe
     43    (include "chicken-primitive-object-inlines") )
     44  (else ) )
    3145
    3246;; Argument Checking
    3347
    34 (define-inline (%check-environment loc obj)
    35   (unless (##sys#environment? obj)
    36     (error-invalid-environment loc obj) ) )
    37 
    38 (define-inline (%check-macro-environment loc obj)
    39   (unless (or (not obj) (##sys#syntactic-environment? obj))
    40     (error-invalid-macro-environment loc obj) ) )
    41 
    42 (define-inline (%check-search-pattern loc obj)
     48(define-inline (%check-search-pattern loc obj argnam)
    4349  (unless (or (string? obj) (and (symbol? obj) (not (keyword? obj))) (regexp? obj))
    44     (error-invalid-search loc patt) ) )
     50    (error-invalid-search loc obj argnam) ) )
     51
     52(define-inline (%check-environment loc obj argnam)
     53  (unless (or (##sys#environment? obj) (##sys#syntactic-environment? obj))
     54    (error-invalid-environment loc obj argnam) ) )
     55
     56(define-inline (%check-environment* loc obj argnam)
     57  (cond ((##sys#environment? obj) #f)
     58        ((##sys#syntactic-environment? obj) obj)
     59        (else
     60          (error-invalid-environment loc obj argnam) ) ) )
    4561
    4662;;;
     
    6884;; Errors
    6985
    70 (define-inline (error-invalid-search loc obj)
    71   (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" obj) )
    72 
    73 (define-inline (error-invalid-environment loc obj)
    74   (##sys#signal-hook #:type-error loc "bad argument type - not an environment" obj) )
    75 
    76 (define-inline (error-invalid-macro-environment loc obj)
    77   (##sys#signal-hook #:type-error loc "bad argument type - not a macro environment" obj) )
    78 
    79 (define-inline (error-invalid-any-environment loc obj)
    80   (##sys#signal-hook #:type-error loc "bad argument type - not an environment or macro environment" obj) )
    81 
    82 ;;
    83 
    84 (define (check-any-environment/->syntactic-environment? loc obj)
    85   (cond ((##sys#environment? obj)           #f)
    86         ((##sys#syntactic-environment? obj) obj)
    87         (else
    88           (error-invalid-any-environment loc obj) ) ) )
     86(define (error-argument-type loc obj kndnam #!optional argnam)
     87  (##sys#signal-hook
     88    #:type-error
     89    loc
     90    (conc "bad " (if argnam (conc #\` argnam #\') "") " argument type - wanted " kndnam)
     91    obj) )
     92
     93(define (error-invalid-search loc obj argnam)
     94  (error-argument-type loc obj "symbol/string/regexp" argnam) )
     95
     96(define (error-invalid-environment loc obj argnam)
     97  (error-argument-type loc obj 'environment argnam) )
     98
     99(define (error-type-procedure loc obj argnam)
     100  (error-argument-type loc obj 'procedure argnam) )
    89101
    90102;; Symbols
    91103
    92 (define (symbol-string-length sym)
    93   (let ((len (string-length (##sys#symbol->qualified-string sym))))
    94     (if (keyword? sym) (- len 2) ;compensate for leading '##'
    95         len ) ) )
     104(define (symbol<? x y)
     105  (cond-expand
     106    (unsafe
     107      (%string<? (%symbol-string x) (%symbol-string y)) )
     108    (else
     109      (let ((x (##sys#symbol->string x))
     110            (y (##sys#symbol->string y))
     111            (px (##sys#qualified-symbol-prefix x))
     112            (py (##sys#qualified-symbol-prefix y)))
     113        (cond (px (and py (string<? px py) (string<? x y)))
     114              (py (or (not px) (and (string<? px py) (string<? x y))))
     115              (else (string<? x y) ) ) ) ) ) )
     116
     117(define (symbol-print-length sym)
     118  (cond-expand
     119    (unsafe
     120      (let ((siz (%string-size (%symbol-string sym))))
     121              ; assumes keyword style is not #:none
     122        (cond ((%keyword? sym) siz)
     123              ; compensate for the '##'
     124              ((%qualified-symbol? sym) (%fx+ siz 2))
     125              ; plain old string
     126              (else siz) ) ) )
     127    (else
     128      (let ([len (string-length (##sys#symbol->qualified-string sym))])
     129        (if (keyword? sym) (- len 2) ; compensate for leading '###' when only a ':' is printed
     130            len ) ) ) ) )
    96131
    97132(define (max-symbol-print-width syms)
    98133  (let ((maxlen 0))
    99     (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-string-length sym)))) syms)
     134    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-print-length sym)))) syms)
    100135    maxlen ) )
    101136
    102 (define (symbol-match? sym regexp) (string-search regexp (symbol->string sym)))
     137(define (symbol-match? sym regexp)
     138  (cond-expand
     139    (unsafe
     140      (string-search regexp (%symbol-string sym)) )
     141    (else
     142      (string-search regexp (symbol->string sym)) ) ) )
    103143
    104144;; Environment Search
    105145
    106 (define (search-environment env regexp pred)
    107   (##sys#environment-symbols
    108     env
    109     (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
    110 
    111 (define (search-macro-environment macenv regexp pred)
    112   (##sys#syntactic-environment-symbols
    113     macenv
    114     (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
    115 
    116 ;; Environment Search -> List
     146(define (search-environment/searcher searcher env regexp pred lessp)
     147  (let ((syms (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym))))))
     148    (if lessp (sort syms lessp)
     149        syms ) ) )
     150
     151(define (search-environment env regexp pred lessp)
     152  (search-environment/searcher ##sys#environment-symbols env regexp pred lessp) )
     153
     154(define (search-macro-environment macenv regexp pred lessp)
     155  (search-environment/searcher ##sys#syntactic-environment-symbols macenv regexp pred lessp) )
    117156
    118157(define (environment-predicate qualified?)
     
    124163      (lambda (x) (not (##sys#qualified-symbol? x))) ) )
    125164
    126 (define (*apropos-list loc regexp env macenv qualified?)
     165(define (*apropos-list loc regexp env macenv qualified? lessp)
    127166  (append
    128    (search-environment env regexp (environment-predicate qualified?))
     167   (search-environment env regexp (environment-predicate qualified?) lessp)
    129168    (if (not macenv) '()
    130         (search-macro-environment macenv regexp (macro-environment-predicate qualified?)))) )
    131 
    132 (define (*apropos-list/environment loc regexp env macenv qualified?)
    133   (if macenv (search-macro-environment env regexp (macro-environment-predicate qualified?))
    134       (search-environment env regexp (environment-predicate qualified?) ) ) )
     169        (search-macro-environment macenv regexp (macro-environment-predicate qualified?) lessp))) )
     170
     171(define (*apropos-list/environment loc regexp env macenv? qualified? lessp)
     172  (if macenv? (search-macro-environment env regexp (macro-environment-predicate qualified?) lessp))
     173      (search-environment env regexp (environment-predicate qualified?) lessp) )
    135174
    136175;; Argument List Parsing
     
    145184
    146185; #!optional (env (default-environment)) macenv
    147 ; #!key macros? qualified?
     186; #!key macros? qualified? sort?
    148187;
    149188; macenv is #t for default macro environment or a syntactic-environment object.
    150189;
    151190; => (values macenv syms)
     191
    152192(define (parse-arguments loc patt args)
    153   (define (parse-rest-arguments args)
     193
     194  (define (parse-rest-arguments)
    154195    (let ((env (default-environment))
    155196          (macenv #f)
    156197          (qualified? #f)
     198          (lessp #f)
    157199          (1st-optarg #t)) ;keyword argument not considered an optional argument here
    158200      (let loop ((args args))
    159         (if (null? args) (values env macenv qualified?)
     201        (if (null? args) (values env macenv qualified? lessp)
    160202            (let ((arg (car args)))
    161203                    ;keyword argument?
     
    165207                    ((eq? #:qualified? arg)
    166208                      (when (cadr args) (set! qualified? #t))
     209                      (loop (cddr args)) )
     210                    ((eq? #:sort? arg)
     211                      (and-let* ((lsp (cadr args)))
     212                        (set! lessp
     213                          (cond ((boolean? lsp) symbol<?)
     214                                ((procedure? lsp) lsp)
     215                                (else
     216                                  (error-type-procedure loc lsp #:sort?)))))
    167217                      (loop (cddr args)) )
    168218                    ;optional argument?
     
    178228                    (else
    179229                      (loop (cdr args)) ) ) ) ) ) ) )
    180   (%check-search-pattern loc patt)
    181   (receive (env macenv qualified?) (parse-rest-arguments args)
    182     (%check-environment loc env)
    183     (%check-macro-environment loc macenv)
    184     (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?)) ) )
    185 
    186 ; #!key qualified?
    187 ;
     230
     231  (%check-search-pattern loc patt 'pattern)
     232  (receive (env macenv qualified? lessp) (parse-rest-arguments)
     233    (%check-environment loc env 'environment)
     234    (when macenv (%check-environment loc macenv #:macros?))
     235    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
     236
    188237; => (values macenv syms)
    189 (define (parse-arguments/environment loc patt env qualified?)
    190   (%check-search-pattern loc patt)
    191   (let ((macenv (check-any-environment/->syntactic-environment? loc env)))
    192     (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?)) ) )
    193 
    194 ; #!key qualified?
     238
     239(define (parse-arguments/environment loc patt env qualified? lessp)
     240  (%check-search-pattern loc patt 'pattern)
     241  (when (and lessp (not (procedure? lessp))) (error-type-procedure loc lessp #:sort?))
     242  (let ((macenv (%check-environment* loc env 'environment)))
     243    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
     244
     245; #!key qualified? sort?
    195246;
    196247; => (... (macenv . syms) ...)
     248
    197249(define (parse-arguments/environments loc patt args)
    198   (define (parse-rest-arguments args)
    199     (let ((qualified? #f))
     250
     251  (define (parse-rest-arguments)
     252    (let ((qualified? #f)
     253          (lessp #f))
    200254      (let loop ((args args) (envs '()))
    201         (if (null? args) (values (reverse envs) qualified?)
     255        (if (null? args) (values (reverse envs) qualified? lessp)
    202256            (let ((arg (car args)))
    203257                    ;keyword argument?
     
    205259                      (when (cadr args) (set! qualified? #t))
    206260                      (loop (cddr args) envs) )
     261                    ((eq? #:sort? arg)
     262                      (and-let* ((lsp (cadr args)))
     263                        (set! lessp
     264                          (cond ((boolean? lsp) symbol<?)
     265                                ((procedure? lsp) lsp)
     266                                (else
     267                                  (error-type-procedure loc lsp #:sort?)))))
     268                      (loop (cddr args) envs) )
    207269                    (else
    208270                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
    209   (%check-search-pattern loc patt)
    210   (receive (envs qualified?) (parse-rest-arguments args)
     271
     272  (%check-search-pattern loc patt 'pattern)
     273  (receive (envs qualified? lessp) (parse-rest-arguments)
    211274    (let ((regexp (make-apropos-regexp patt)))
    212275      (let loop ((envs envs) (envsyms '()))
    213276        (if (null? envs) (reverse envsyms)
    214277            (let* ((env (car envs))
    215                    (macenv (check-any-environment/->syntactic-environment? loc env))
     278                   (macenv (%check-environment* loc env 'environment))
    216279                   (make-envsyms
    217280                    (lambda ()
    218                       `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
     281                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified? lessp)) ) ) )
    219282              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
    220283
     
    226289    (cond ((not info) 'procedure)
    227290          ((pair? info) `(procedure . ,(cdr info)))
    228           (else `(procedure . ,info)) ) ) )
     291          (else `(procedure . ,(symbol->string info))) ) ) )
    229292
    230293(define (apropos-information sym macenv)
     
    242305
    243306(define (display-symbol-information sym maxsymlen macenv)
    244   (display sym) (display-spaces (- maxsymlen (symbol-string-length sym)))
     307  (display sym) (display-spaces (- maxsymlen (symbol-print-length sym)))
    245308  (let ((info (apropos-information sym macenv)))
    246309    (display #\space)
    247310    (if (symbol? info) (display info)
    248         (begin (display (car info)) (display #\space) (display (cdr info)) ) ) )
     311        (begin (display (car info)) (display #\space) (write (cdr info)) ) ) )
    249312  (newline) )
    250313
     
    268331;; Crispy
    269332
    270 (define (apropos/environment patt env #!key qualified?)
    271   (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
     333(define (apropos/environment patt env #!key qualified? (sort? symbol<?))
     334  (receive (macenv syms)
     335           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
    272336    (let ((maxsymlen (max-symbol-print-width syms)))
    273337      (newline)
    274338      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
    275339
    276 (define (apropos-list/environment patt env #!key qualified?)
    277   (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
     340(define (apropos-list/environment patt env #!key qualified? (sort? symbol<?))
     341  (receive (macenv syms)
     342           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
    278343    syms ) )
    279344
    280 (define (apropos-information-list/environment patt env #!key qualified?)
    281   (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
     345(define (apropos-information-list/environment patt env #!key qualified? (sort? symbol<?))
     346  (receive (macenv syms)
     347           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
    282348    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
    283349
Note: See TracChangeset for help on using the changeset viewer.