Changeset 13744 in project


Ignore:
Timestamp:
03/14/09 07:39:53 (11 years ago)
Author:
Kon Lovett
Message:

Added csi command. Better sorting, arg chck.

Location:
release/4/apropos
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/apropos/tags/1.0.0/chicken-primitive-object-inlines.scm

    r13730 r13744  
    361361; generic-byteblock isa bytevector, string, flonum, or lambda-info
    362362(define-inline (%generic-byteblock? x)
    363   (or (bytevector? x) (string? x) (flonum? x) (lambda-info? x)) )
     363  (or (%bytevector? x) (%string? x) (%flonum? x) (%lambda-info? x)) )
    364364
    365365;; Bytevector (byteblock)
     
    834834    (%closure-set! tc i (%closure-ref fc i)) ) )
    835835
    836 (define-inline (%closure-decoration c t)
     836(define-inline (%closure-decoration c test)
    837837  (let find-decor ((i (%fxsub1 (%closure-length c))))
    838838    (and (%fxpositive? i)
    839839         (let ((x (%closure-ref c i)))
    840            (if (t x) x
     840           (if (test x) x
    841841               (find-decor (%fxsub1 i)) ) ) ) ) )
    842842
    843 (define-inline (%closure-decorate! c t d)
     843(define-inline (%closure-decorate! c test dcor)
    844844  (let ((l (%closure-length c)))
    845845    (let find-decor ((i (%fxsub l)))
     
    848848               (%closure-copy nc c l)
    849849               (##core#inline "C_copy_pointer" c nc)
    850                (d nc i) ) )
     850               (dcor nc i) ) )
    851851            (else
    852852             (let ((x (%closure-ref c i)))
    853                (if (t x) (d c i)
     853               (if (test x) (dcor c i)
    854854                   (find-decor (%fxsub i)) ) ) ) ) ) ) )
    855855
     
    870870  (let ((str (%symbol-string s)))
    871871    (and (%fxpositive? (%string-size str))
    872          (fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
     872         (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
    873873
    874874;Safe
  • release/4/apropos/trunk/apropos.scm

    r13738 r13744  
    4747
    4848(define-inline (%check-search-pattern loc obj argnam)
    49   (unless (or (string? obj) (and (symbol? obj) (not (keyword? obj))) (regexp? obj))
    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 
     49  (cond-expand
     50    (unsafe
     51      (unless (or (%keyword? obj) (%symbol? obj) (%string? obj) (regexp? obj))
     52        (error-invalid-search loc obj argnam) ) )
     53    (else
     54      (unless (or (keyword? obj) (symbol? obj) (string? obj) (regexp? obj))
     55        (error-invalid-search loc obj argnam) ) ) ) )
     56
     57#; ;UNUSED
    5658(define-inline (%check-environment* loc obj argnam)
    5759  (cond ((##sys#environment? obj) #f)
     
    6062          (error-invalid-environment loc obj argnam) ) ) )
    6163
    62 (define-inline (%check-sort-argument loc obj)
    63   (unless (or (eq? #:name obj) (eq? #:kind obj))
    64     (error-invalid-sort loc obj) ) )
     64(define-inline (%check-sortkey-argument loc obj)
     65  (unless (or (not obj) (eq? #:name obj) (eq? #:kind obj))
     66    (error-invalid-sortkey loc obj) ) )
    6567
    6668;;;
    6769
    68 #;(require-library regex lolevel data-structures extras srfi-13 csi)
     70(require-library regex lolevel data-structures ports extras utils srfi-13)
    6971
    7072(module apropos (;export
     
    7678  #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments)
    7779
    78 (import scheme chicken regex lolevel data-structures extras srfi-13 csi)
     80(import scheme chicken regex lolevel data-structures ports extras utils srfi-13 csi)
    7981
    8082;;; Support
     
    9294  (error-argument-type loc obj "symbol/string/regexp" argnam) )
    9395
     96#; ;UNUSED
    9497(define (error-invalid-environment loc obj argnam)
    9598  (error-argument-type loc obj 'environment argnam) )
    9699
    97 (define (error-invalid-sort loc obj)
    98   (error-argument-type loc obj "#:name or #:kind" #:sort) )
     100(define (error-invalid-sortkey loc obj)
     101  (error-argument-type loc obj "#:name, #:kind or #f" #:sort) )
     102
     103(define (error-invalid-argument loc arg)
     104  (if (keyword? arg) (error loc "unrecognized keyword argument" arg)
     105      (error loc "unrecognized argument" arg) ) )
    99106
    100107;; Symbols
     108
     109(define (symbol->keyword sym)
     110  (if (keyword? sym) sym
     111      (string->keyword (symbol->string sym)) ) )
     112
     113(define (symbol=? x y)
     114  (cond-expand
     115    (unsafe
     116      (%string=? (%symbol-string x) (%symbol-string y)) )
     117    (else
     118      (let ((sx (##sys#symbol->string x))
     119            (sy (##sys#symbol->string y))
     120            (px (##sys#qualified-symbol-prefix x))
     121            (py (##sys#qualified-symbol-prefix y)))
     122        (cond (px (and py (string=? px py) (string=? sx sy)))
     123              (py (or (not px) (and (string=? px py) (string=? sx sy))))
     124              (else (string=? sx sy) ) ) ) ) ) )
    101125
    102126(define (symbol<? x y)
     
    105129      (%string<? (%symbol-string x) (%symbol-string y)) )
    106130    (else
    107       (let ((x (##sys#symbol->string x))
    108             (y (##sys#symbol->string y))
     131      (let ((sx (##sys#symbol->string x))
     132            (sy (##sys#symbol->string y))
    109133            (px (##sys#qualified-symbol-prefix x))
    110134            (py (##sys#qualified-symbol-prefix y)))
    111         (cond (px (and py (string<? px py) (string<? x y)))
    112               (py (or (not px) (and (string<? px py) (string<? x y))))
    113               (else (string<? x y) ) ) ) ) ) )
     135        (cond (px (and py (string<? px py) (string<? sx sy)))
     136              (py (or (not px) (and (string<? px py) (string<? sx sy))))
     137              (else (string<? sx sy) ) ) ) ) ) )
    114138
    115139(define (symbol-print-length sym)
     
    166190    (*apropos-list/environment loc regexp env #f qualified?)
    167191    (if (not macenv) '()
    168         (*apropos-list/environment loc regexp macenv macenv qualified?))) )
     192        (*apropos-list/environment loc regexp macenv #t qualified?))) )
    169193
    170194;; Argument List Parsing
     
    178202  patt )
    179203
    180 ; => (values args val)
     204; => (values val args)
    181205(define (keyword-argument args kwd #!optional val)
    182   (let loop ((iargs args) (oargs '()))
    183     (if (null? args) (values (reverse oargs) val)
     206  (let loop ((args args) (oargs '()))
     207    (if (null? args) (values val (reverse oargs))
    184208        (let ((arg (car args)))
    185209          (cond ((eq? kwd arg)
    186210                  (set! val (cadr args))
    187                   (loop (cddr iargs) oargs) )
     211                  (loop (cddr args) oargs) )
    188212                (else
    189                   (loop (cdr iargs) (cons arg oargs)) ) ) ) ) ) )
    190 
    191 ; => (values args sort)
    192 (define (parse-sort-argument loc args)
    193   (receive (args sort) (keyword-argument args #:sort #:name)
    194     (%check-sort-argument loc sort)
    195     (values args sort) ) )
     213                  (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
     214
     215; => (values sortkey args)
     216(define (parse-sortkey-argument loc args)
     217  (receive (sortkey args) (keyword-argument args #:sort #:kind)
     218    (%check-sortkey-argument loc sortkey)
     219    (values sortkey args) ) )
    196220
    197221; #!optional (env (default-environment)) macenv
     
    204228(define (parse-arguments loc patt args)
    205229
     230  ; => (values env macenv qualified?)
    206231  (define (parse-rest-arguments)
    207232    (let ((env (default-environment))
    208233          (macenv #f)
    209234          (qualified? #f)
    210           (1st-optarg #t)) ;keyword argument not considered an optional argument here
     235          (1st-arg? #t))
    211236      (let loop ((args args))
    212237        (if (null? args) (values env macenv qualified?)
     
    219244                      (when (cadr args) (set! qualified? #t))
    220245                      (loop (cddr args)) )
    221                     ;optional argument?
    222                     (arg
    223                            ;specific environment?
    224                       (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
    225                             ;default macro environment?
    226                             ((boolean? args) (set! macenv (default-macro-environment)))
    227                             ;specific macro environment?
    228                             (else (set! macenv arg)))
     246                    ;environment argument?
     247                    (1st-arg?
     248                      (unless (##sys#environment? arg)
     249                        (error-invalid-argument loc arg) )
     250                      (set! 1st-arg? #f)
     251                      (set! env arg)
    229252                      (loop (cdr args)) )
    230                     ;accept #f for macenv
     253                    ;unkown argument
    231254                    (else
    232                       (loop (cdr args)) ) ) ) ) ) ) )
     255                      (error-invalid-argument loc arg) ) ) ) ) ) ) )
    233256
    234257  (%check-search-pattern loc patt 'pattern)
    235258  (receive (env macenv qualified?) (parse-rest-arguments)
    236     (%check-environment loc env 'environment)
    237     (when macenv (%check-environment loc macenv #:macros?))
    238259    (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
    239260
     
    257278        (if (null? args) (values (reverse envs) qualified?)
    258279            (let ((arg (car args)))
     280                    ;keyword argument?
    259281              (cond ((eq? #:qualified? arg)
    260282                      (when (cadr args) (set! qualified? #t))
    261283                      (loop (cddr args) envs) )
     284                    ;environment argument?
    262285                    (else
    263                       (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
     286                      (unless (##sys#environment? arg)
     287                        (error-invalid-argument loc arg) )
     288                      (loop (cdr args) (cons env envs)) ) ) ) ) ) ) )
    264289
    265290  (%check-search-pattern loc patt 'pattern)
     
    299324(define (display-spaces cnt)
    300325  (do ((i cnt (sub1 i)))
    301       ((negative? i))
     326      ((zero? i))
    302327    (display #\space) ) )
    303328
    304 (define (display-apropos syms macenv sort)
    305   (let ((maxsymlen (max-symbol-print-width syms))
    306         (lessp
    307           (case sort
    308             ((#:name)
    309               (lambda (pr1 pr2) (symbol<? (car pr1) (car pr2))) )
    310             ((#:kind)
    311               (lambda (pr1 pr2)
    312                 (let ((s1 (car pr1)) (s2 (car pr2)))
    313                   (symbol<? (if (symbol? s1) s1 (car s1)) (if (symbol? s2) s2 (car s2)))))))) )
     329(define (apropos-information-name<? apr1 apr2)
     330  (symbol<? (car apr1) (car apr2)) )
     331
     332(define (apropos-information-kind=? apr1 apr2)
     333  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
     334    (symbol=? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
     335
     336(define (apropos-information-kind<? apr1 apr2)
     337  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
     338    (symbol<? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
     339
     340(define (apropos-information<? apr1 apr2)
     341  (if (apropos-information-kind=? apr1 apr2) (apropos-information-name<? apr1 apr2)
     342      (apropos-information-kind<? apr1 apr2) ) )
     343
     344(define (display-apropos syms macenv sortkey)
     345  (let ((maxsymlen (max-symbol-print-width syms)))
    314346
    315347    (define (display-symbol-information apr)
    316       (let ((sym (car apr))
    317             (info (cdr apr)))
    318         (display sym) (display-spaces (- maxsymlen (symbol-print-length sym)))
    319         (display #\space)
    320         (if (symbol? info) (display info)
    321             (begin (display (car info)) (display #\space) (write (cdr info)) ) )
    322       (newline) ) )
    323 
    324     (for-each
    325       (cut display-symbol-information <>)
    326       (sort (*apropos-information-list syms macenv) lessp)) ) )
     348      (let ((sym (car apr)))
     349        (display sym) (display #\space) (display-spaces (- maxsymlen (symbol-print-length sym))) )
     350      (display #\space)
     351      (let ((info (cdr apr)))
     352        (cond ((symbol? info) (display info) )
     353              (else (display (car info)) (display #\space) (write (cdr info)) ) ) )
     354      (newline) )
     355
     356    (let ((lessp
     357            (case sortkey
     358              ((#:name) apropos-information-name<? )
     359              ((#:kind) apropos-information<? )
     360              (else     #f ) ) )
     361          (ail (*apropos-information-list syms macenv)))
     362      (for-each display-symbol-information (if lessp (sort ail lessp) ail)) ) ) )
    327363
    328364;;; API
     
    331367
    332368(define (apropos patt . args)
    333   (receive (args sort) (parse-sort-argument 'apropos args)
     369  (receive (sortkey args) (parse-sortkey-argument 'apropos args)
    334370    (receive (syms macenv) (parse-arguments 'apropos patt args)
    335       (display-apropos syms macenv sort) ) ) )
     371      (display-apropos syms macenv sortkey) ) ) )
    336372
    337373(define (apropos-list patt . args)
     
    370406
    371407(define (apropos/environment patt env #!key qualified? (sort #:name))
    372   (%check-sort-argument 'apropos/environment sort)
     408  (%check-sortkey-argument 'apropos/environment sort)
    373409  (receive (syms macenv)
    374410           (parse-arguments/environment 'apropos/environment patt env qualified?)
    375411    (newline)
    376     (display-apropos syms macenv sort) ) )
     412    (display-apropos syms macenv sortkey) ) )
    377413
    378414(define (apropos-list/environment patt env #!key qualified?)
     
    413449
    414450(define (apropos/environments patt . args)
    415   (receive (args sort) (parse-sort-argument 'apropos/environments args)
     451  (receive (sortkey args) (parse-sortkey-argument 'apropos/environments args)
    416452    (let ((i 0))
    417453      (for-each
     
    419455          (set! i (add1 i))
    420456          (newline) (print "** Environment " i " **") (newline)
    421           (display-apropos (cdr macenv+syms) (car macenv+syms) sort) )
     457          (display-apropos (cdr macenv+syms) (car macenv+syms) sortkey) )
    422458        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
    423459
     
    433469;;;
    434470
     471(define (parse-csi-apropos-arguments args)
     472  (let loop ((args args) (oargs '()))
     473    (if (null? args) (reverse oargs)
     474        (let ((arg (car args)))
     475          (case arg
     476            ((macros)
     477              (loop (cdr args) (cons #t (cons #:macros? oargs))) )
     478            ((qualified)
     479              (loop (cdr args) (cons #t (cons #:qualified? oargs))) )
     480            ((sort)
     481              (let* ((val (cadr args))
     482                     (key (if (symbol? val) (symbol->keyword val) val)))
     483                (loop (cddr args) (cons key (cons #:sort oargs))) ) )
     484            (else
     485              (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
     486
    435487(when (feature? csi:)
    436488  (toplevel-command 'a
    437     (lambda () (apropos (string-trim-both (read-line))))
    438     " ,a PATT ...       Apropos identifier") )
     489    (lambda ()
     490      (apply apropos
     491        (parse-csi-apropos-arguments
     492          (with-input-from-string (string-trim-both (read-line)) read-file))) )
     493    ",a PATT [ARG...]  Apropos of PATT with ARG from macros, qualified, or sort name/#f") )
    439494
    440495) ;module apropos
  • release/4/apropos/trunk/chicken-primitive-object-inlines.scm

    r13729 r13744  
    361361; generic-byteblock isa bytevector, string, flonum, or lambda-info
    362362(define-inline (%generic-byteblock? x)
    363   (or (bytevector? x) (string? x) (flonum? x) (lambda-info? x)) )
     363  (or (%bytevector? x) (%string? x) (%flonum? x) (%lambda-info? x)) )
    364364
    365365;; Bytevector (byteblock)
     
    834834    (%closure-set! tc i (%closure-ref fc i)) ) )
    835835
    836 (define-inline (%closure-decoration c t)
     836(define-inline (%closure-decoration c test)
    837837  (let find-decor ((i (%fxsub1 (%closure-length c))))
    838838    (and (%fxpositive? i)
    839839         (let ((x (%closure-ref c i)))
    840            (if (t x) x
     840           (if (test x) x
    841841               (find-decor (%fxsub1 i)) ) ) ) ) )
    842842
    843 (define-inline (%closure-decorate! c t d)
     843(define-inline (%closure-decorate! c test dcor)
    844844  (let ((l (%closure-length c)))
    845845    (let find-decor ((i (%fxsub l)))
     
    848848               (%closure-copy nc c l)
    849849               (##core#inline "C_copy_pointer" c nc)
    850                (d nc i) ) )
     850               (dcor nc i) ) )
    851851            (else
    852852             (let ((x (%closure-ref c i)))
    853                (if (t x) (d c i)
     853               (if (test x) (dcor c i)
    854854                   (find-decor (%fxsub i)) ) ) ) ) ) ) )
    855855
     
    870870  (let ((str (%symbol-string s)))
    871871    (and (%fxpositive? (%string-size str))
    872          (fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
     872         (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
    873873
    874874;Safe
Note: See TracChangeset for help on using the changeset viewer.