Changeset 37095 in project


Ignore:
Timestamp:
01/20/19 22:24:42 (4 weeks ago)
Author:
kon
Message:

fix #1578, add internal kwd arg, add split test

Location:
release/5/apropos/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed

  • release/5/apropos/trunk/apropos-api.scm

    r37049 r37095  
    6767  #t )
    6868
    69 (define (qualified-symbol? sym)
    70   #f )
    71 
    7269;;
    7370
    … …  
    9996;; Symbols
    10097
     98#; ;UNUSED
    10199(define (symbol-match? sym patt)
    102100  (string-match? (symbol->string sym) patt) )
    103101
     102#; ;UNUSED
    104103(define (symbol-exact-match? sym patt)
    105104  (string-exact-match? (symbol->string sym) patt) )
    106105
     106#; ;UNUSED
    107107(define (symbol-ci-match? sym patt)
    108108  (string-ci-match? (symbol->string sym) patt) )
    … …  
    183183;; Environment Search
    184184
    185 (define (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
    186   (let (
    187     (optarg?
    188       (if qualified?
    189         any?
    190         (lambda (x) (not (qualified-symbol? x))))) )
    191     (search-macro-environment-symbols macenv
    192       (lambda (sym)
    193         (and
    194           (symbol-match? sym)
    195           (optarg? sym)))) ) )
    196 
    197 (define (*apropos-list/environment loc symbol-match? env qualified?)
    198   (let (
    199     (optarg?
    200       (if qualified?
    201         global-symbol-bound?
    202         (lambda (x)
    203           (and
    204             (not (qualified-symbol? x))
    205             (global-symbol-bound? x))))))
    206     ;
    207     (search-system-environment-symbols env
    208       (lambda (sym)
    209         (and
    210           (symbol-match? sym)
    211           (optarg? sym)))) ) )
     185(define (*apropos-list/macro-environment loc matcher macenv)
     186  (search-macro-environment-symbols macenv matcher) )
     187
     188(define (*apropos-list/environment loc matcher env)
     189  (search-system-environment-symbols env
     190    (lambda (sym)
     191      (and
     192        (global-symbol-bound? sym)
     193        (matcher sym)))) )
    212194
    213195;;
    214196
    215197; => (envsyms . macenvsyms)
    216 (define (*apropos-list loc symbol-match? env macenv qualified?)
     198(define (*apropos-list loc matcher env macenv)
    217199  (append
    218     (*apropos-list/environment loc symbol-match? env qualified?)
     200    (*apropos-list/environment loc matcher env)
    219201    (if macenv
    220       (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
     202      (*apropos-list/macro-environment loc matcher macenv)
    221203      '())) )
    222204
    … …  
    232214              (case-insensitive? #f)
    233215              (split #f)
    234               (force-regexp? #f))
     216              (force-regexp? #f)
     217              (internal? #f))
    235218  ;
    236219  (define (gen-irregex-options-list)
    … …  
    242225  (define (gen-irregex-matcher irx)
    243226    (cond
     227      ((not split)
     228        (lambda (sym)
     229          (let ((symstr (symbol->string sym)))
     230            (and
     231              (or internal? (not (internal-module-name? symstr)))
     232              (string-match? symstr irx) ) ) ) )
    244233      ((eq? #:module split)
    245234        (lambda (sym)
    246235          (let-values (
    247236            ((mod nam) (split-prefixed-symbol sym)) )
    248             (string-match? mod irx) ) ) )
     237            (and
     238              (or internal? (not (internal-module-name? mod)))
     239              (string-match? mod irx) ) ) ) )
    249240      ((eq? #:name split)
    250241        (lambda (sym)
    251242          (let-values (
    252243            ((mod nam) (split-prefixed-symbol sym)) )
    253             (string-match? nam irx) ) ) )
    254       ((not split)
    255         (cut symbol-match? <> irx) ) ) )
     244            (and
     245              (or internal? (not (internal-module-name? mod)))
     246              (string-match? nam irx) ) ) ) ) ) )
    256247  ;
    257248  (define (gen-string-matcher str)
    258     (if (not split)
    259       ;no split
    260       (cut (if case-insensitive? symbol-ci-match? symbol-exact-match?) <> str)
    261       ;splitting
    262       (let (
    263         (matcher (if case-insensitive? string-ci-match? string-exact-match?)) )
    264         (cond
    265           ((eq? #:module split)
    266             (lambda (sym)
    267               (let-values (
    268                 ((mod nam) (split-prefixed-symbol sym)) )
    269                 (matcher mod str) ) ) )
    270           ((eq? #:name split)
    271             (lambda (sym)
    272               (let-values (
    273                 ((mod nam) (split-prefixed-symbol sym)) )
     249    (let (
     250      (matcher (if case-insensitive? string-ci-match? string-exact-match?)) )
     251      (cond
     252        ((not split)
     253          (lambda (sym)
     254            (let ((symstr (symbol->string sym)))
     255              (and
     256                (or internal? (not (internal-module-name? symstr)))
     257                (matcher symstr str) ) ) ) )
     258        ((eq? #:module split)
     259          (lambda (sym)
     260            (let-values (
     261              ((mod nam) (split-prefixed-symbol sym)) )
     262              (and
     263                (or internal? (not (internal-module-name? mod)))
     264                (matcher mod str) ) ) ) )
     265        ((eq? #:name split)
     266          (lambda (sym)
     267            (let-values (
     268              ((mod nam) (split-prefixed-symbol sym)) )
     269              (and
     270                (or internal? (not (internal-module-name? mod)))
    274271                (matcher nam str) ) ) ) ) ) ) )
    275272  ;
    … …  
    278275      (make-apropos-matcher loc
    279276        (symbol->string patt)
    280         case-insensitive? split force-regexp?) )
     277        case-insensitive? split force-regexp? internal?) )
    281278    ((string? patt)
    282279      (if force-regexp?
    … …  
    297294              ;elaborate match any
    298295              ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
    299                 (make-apropos-matcher loc '(: (* any)) #f #f #t) )
     296                (make-apropos-matcher loc '(: (* any)) #f #f #t internal?) )
    300297              ;name split?
    301298              ((eq? ANY-SYMBOL (car quoted))
    302299                (make-apropos-matcher loc
    303300                  (cdr quoted)
    304                   case-insensitive? #:name force-regexp?) )
     301                  case-insensitive? #:name force-regexp? internal?) )
    305302              ;module split?
    306303              ((eq? ANY-SYMBOL (cdr quoted))
    307304                (make-apropos-matcher loc
    308305                  (car quoted)
    309                   case-insensitive? #:module force-regexp?) )
     306                  case-insensitive? #:module force-regexp? internal?) )
    310307              ;both name & module
    311308              (else
    … …  
    314311                    (make-apropos-matcher loc
    315312                      (car quoted)
    316                       case-insensitive? #:module force-regexp?))
     313                      case-insensitive? #:module force-regexp? internal?))
    317314                  (namr
    318315                    (make-apropos-matcher loc
    319316                      (cdr quoted)
    320                       case-insensitive? #:name force-regexp?)) )
     317                      case-insensitive? #:name force-regexp? internal?)) )
    321318                  (lambda (sym)
    322319                    (and (modr sym) (namr sym)) ) ) ) )
    … …  
    324321            (make-apropos-matcher loc
    325322              quoted
    326               case-insensitive? split #t) ) ) ) )
     323              case-insensitive? split #t internal?) ) ) ) )
    327324    (else
    328325      (error loc "invalid apropos pattern form" patt) ) ) )
    … …  
    350347;;
    351348
    352 ;#!optional (env (default-environment)) macenv #!key macros? qualified? base (split #:all)
     349;#!optional (env (default-environment)) macenv #!key macros? internal? base (split #:all)
    353350;
    354351;macenv is #t for default macro environment or a macro-environment object.
    355352;
    356353;=> (values apropos-ls macenv)
     354;
    357355(define (parse-arguments-and-match loc patt iargs)
    358356  (let-values (
    359     ((env macenv qualified? case-insensitive? base raw? split)
    360       (parse-rest-arguments loc iargs)))
    361     ;
     357    ((env macenv case-insensitive? base raw? split internal?) (parse-rest-arguments loc iargs)))
    362358    (let* (
    363       (patt
    364         (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern) )
    365       (matcher
    366         (make-apropos-matcher loc patt case-insensitive? split) )
    367       (als
    368         (*apropos-list loc matcher env macenv qualified?) ) )
    369       ;
     359      (patt (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern))
     360      (force-regexp? #f)
     361      (matcher (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
     362      (als (*apropos-list loc matcher env macenv)) )
    370363      (values als macenv raw?) ) ) )
    371364;;
    372365
    373 ;=> (values env macenv qualified? base)
     366;=> (values env macenv base raw? split internal?)
     367;
    374368(define (parse-rest-arguments loc iargs)
    375369  (let (
    376370    (env #f)        ;(default-environment)
    377371    (macenv #f)
    378     (qualified? #f)
     372    (internal? #f)
    379373    (raw? #f)
    380374    (case-insensitive? #f)
    … …  
    386380      (if (null? args)
    387381        ;seen 'em all
    388         (values env macenv qualified? case-insensitive? base raw? split)
     382        (values env macenv case-insensitive? base raw? split internal?)
    389383        ;process potential arg
    390384        (let ((arg (car args)))
    … …  
    394388            ((eq? #:split arg)
    395389              (set! split (check-split-component loc (cadr args)))
     390              (loop (cddr args)) )
     391            ;
     392            ((eq? #:internal? arg)
     393              (set! internal? (cadr args))
    396394              (loop (cddr args)) )
    397395            ;
    … …  
    452450; => (values envsyms macenv)
    453451
    454 (define (parse-arguments/environment loc patt env qualified?)
     452(define (parse-arguments/environment loc patt env)
    455453  (check-search-pattern loc patt 'pattern)
    456454  (let ((macenv (macro-environment (check-environment loc env 'environment))))
    457455    (values
    458       (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv qualified?)
     456      (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv)
    459457      macenv) ) )
    460458
    461459;;
    462460
    463 ; #!key qualified?
     461; #!key internal?
    464462;
    465463; => (... (macenv . syms) ...)
    … …  
    468466  ;
    469467  (define (parse-rest-arguments)
    470     (let ((qualified? #f))
     468    (let ((internal? #f))
    471469      (let loop ((args args) (envs '()))
    472470        (if (null? args)
    473           (values (reverse! envs) qualified?)
     471          (values (reverse! envs) internal?)
    474472          (let ((arg (car args)))
    475473            ;keyword argument?
    476474            (cond
    477               ((eq? #:qualified? arg)
    478                 (when (cadr args) (set! qualified? #t))
     475              ((eq? #:internal? arg)
     476                (when (cadr args) (set! internal? #t))
    479477                (loop (cddr args) envs) )
    480478              ;environment argument?
    … …  
    486484  (let ((patt (fixup-pattern-argument patt)))
    487485    (check-search-pattern loc patt 'pattern)
    488     (receive (envs qualified?) (parse-rest-arguments)
     486    (receive (envs internal?) (parse-rest-arguments)
    489487      (let ((regexp (make-apropos-matcher loc patt)))
    490488        (let loop ((envs envs) (envsyms '()))
    … …  
    497495                       (cons
    498496                         macenv
    499                          (*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
     497                         (*apropos-list/environment loc regexp env macenv)) ) ) )
    500498              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
    501499|#
    … …  
    539537;When > limit need to keep leading digit
    540538
    541 ; un-qualified symbols only!
    542539(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
    543540  (let* (
    … …  
    572569  (cond
    573570    (raw?
    574       (cons *toplevel-module-symbol* sym) )
    575     ((qualified-symbol? sym)
    576571      (cons *toplevel-module-symbol* sym) )
    577572    (else
    … …  
    827822==== apropos/environment
    828823
    829 <procedure>(apropos/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?) (#:sort SORT))</procedure>
     824<procedure>(apropos/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?) (#:sort SORT))</procedure>
    830825
    831826Displays information about identifiers matching {{PATTERN}} in the
    … …  
    838833==== apropos-list/environment
    839834
    840 <procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
     835<procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
    841836
    842837Like {{apropos-list}}.
    … …  
    844839==== apropos-information-list/environment
    845840
    846 <procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
     841<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
    847842
    848843Like {{apropos-information-list}}.
    849844
    850 (define (apropos/environment patt env #!key qualified? (sort #:name))
     845(define (apropos/environment patt env #!key internal? (sort #:name))
    851846  (check-sort-key 'apropos/environment sort #:sort)
    852847  (receive
    853848    (syms macenv)
    854       (parse-arguments/environment 'apropos/environment patt env qualified?)
     849      (parse-arguments/environment 'apropos/environment patt env internal?)
    855850    ;
    856851    (newline)
    857852    (display-apropos syms macenv sort-key) ) )
    858853
    859 (define (apropos-list/environment patt env #!key qualified?)
     854(define (apropos-list/environment patt env #!key internal?)
    860855  (receive
    861856    (syms macenv)
    862       (parse-arguments/environment 'apropos/environment patt env qualified?)
     857      (parse-arguments/environment 'apropos/environment patt env internal?)
    863858    ;
    864859    syms ) )
    865860
    866 (define (apropos-information-list/environment patt env #!key qualified?)
     861(define (apropos-information-list/environment patt env #!key internal?)
    867862  (receive
    868863    (syms macenv)
    869       (parse-arguments/environment 'apropos/environment patt env qualified?)
     864      (parse-arguments/environment 'apropos/environment patt env internal?)
    870865    ;
    871866    (*make-information-list syms macenv) ) )
    … …  
    875870==== apropos/environments
    876871
    877 <procedure>(apropos/environments PATTERN (#:qualified? QUALIFIED?) (#:sort SORT) ENVIRONMENT...)</procedure>
     872<procedure>(apropos/environments PATTERN (#:internal? INTERNAL?) (#:sort SORT) ENVIRONMENT...)</procedure>
    878873
    879874Displays information about identifiers matching {{PATTERN}} in each
    … …  
    886881==== apropos-list/environments
    887882
    888 <procedure>(apropos-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
     883<procedure>(apropos-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
    889884
    890885Like {{apropos-list}}.
    … …  
    892887==== apropos-information-list/environments
    893888
    894 <procedure>(apropos-information-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
     889<procedure>(apropos-information-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
    895890
    896891Like {{apropos-information-list}}.

  • release/5/apropos/trunk/apropos-csi.scm

    r37049 r37095  
    3636
    3737(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
    38   (let ((rem (fx- n (string-length x))))
    39     (define (shorter?) (positive? rem))
    40     (if (shorter?)
     38  (let* (
     39    (rem (fx- n (string-length x)))
     40    (shorter? (positive? rem)) )
     41    (if shorter?
    4142      (string-append x (make-string rem pad))
    4243      (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
    … …  
    9293 base              For number valued pattern
    9394 raw               No listing symbol interpretation (i.e. x123 ~> x)
     95 internal          Include internal "modules"
    9496EOS
    9597)
    … …  
    101103(define (interp-split-arg loc arg)
    102104  (case arg
    103     ((n nam name)     #:name )
    104     ((m mod module)   #:module )
     105    ((n nam name)     #:name)
     106    ((m mod module)   #:module)
    105107    (else
    106108      (if (not arg)
    … …  
    110112(define (interp-sort-arg loc arg)
    111113  (case arg
    112     ((n nam name)     #:name )
    113     ((m mod module)   #:module )
    114     ((t typ type)     #:type )
     114    ((n nam name)     #:name)
     115    ((m mod module)   #:module)
     116    ((t typ type)     #:type)
    115117    (else
    116118      (if (not arg)
    … …  
    132134          '() )
    133135        (optarg?
    134           (cdr next) )
     136          (cdr next))
    135137        (else
    136138          next ) ) )
    … …  
    141143        (cond
    142144          ((null? next)
    143             (cons* init kwd oargs) )
     145            (cons* init kwd oargs))
    144146          (optarg?
    145             (cons* (optarg? (car next)) kwd oargs) )
     147            (cons* (optarg? (car next)) kwd oargs))
    146148          (else
    147149            (cons* init kwd oargs) ) ) )
    148150      ;
    149151      (let* (
    150         (next (cdr args) )
    151         (args (restargs next optarg?) )
     152        (next (cdr args))
     153        (args (restargs next optarg?))
    152154        (oargs (thisargs next kwd init optarg?) ) )
    153155        ;
    … …  
    164166            (loop
    165167              (restargs (cons* 'all (cdr args)) #f)
    166               (cons* #:module #:sort oargs)) )
     168              (cons* #:module #:sort oargs)))
    167169          ;
    168170          ((all)
    169171            (loop
    170172              (restargs (cdr args) #f)
    171               (cons* #t #:case-insensitive? #t #:macros? oargs)) )
     173              (cons* #t #:case-insensitive? #t #:macros? oargs)))
    172174          ;
    173175          ((mac macros)
    174             (arg-next #:macros? #t) )
     176            (arg-next #:macros? #t))
    175177          ;
    176178          ((ci case-insensitive)
    177             (arg-next #:case-insensitive? #t) )
     179            (arg-next #:case-insensitive? #t))
     180          ;
     181          ((internal)
     182            (arg-next #:internal? #t))
    178183          ;
    179184          ((raw)
    180             (arg-next #:raw? #t) )
     185            (arg-next #:raw? #t))
    181186          ;
    182187          ((base)
    183             (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)) )
     188            (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)))
    184189          ;
    185190          ((sort)
    186             (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) )
     191            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)))
    187192          ;
    188193          ((split)
    189             (arg-next #:split #f (cut interp-split-arg ',a <>)) )
     194            (arg-next #:split #f (cut interp-split-arg ',a <>)))
    190195          ;
    191196          ((?)
    192             (loop '() '()) )
     197            (loop '() '()))
    193198          ;
    194199          (else

  • release/5/apropos/trunk/apropos.egg

    r37049 r37095  
    55
    66((synopsis "CHICKEN apropos")
    7  (version "3.2.3")
     7 (version "3.3.0")
    88 (category misc)
    99 (author "[[kon lovett]]")

  • release/5/apropos/trunk/symbol-access.scm

    r36630 r37095  
    1313  global-symbol-ref
    1414  ;
     15  internal-module-name?
     16  ;
    1517  *toplevel-module-symbol*
    1618  split-prefixed-symbol)
    … …  
    2022  (chicken fixnum)
    2123  (chicken type)
    22   (only (srfi 13) string-drop string-take string-index))
     24  (only (srfi 13) string-prefix? string-drop string-take string-index))
    2325
    2426;;; Raw Access Renames
    … …  
    2830(define (global-symbol-ref sym) (##sys#slot sym 0))
    2931
     32(define (global-symbol-name-offset str)
     33  (if (string-prefix? "##" str) 2 0) )
     34
    3035;;; Toplevel Symbols
    3136
    … …  
    3439(define *toplevel-module-string* (symbol->string *toplevel-module-symbol*))
    3540
     41(: internal-module-name? (string --> boolean))
     42;
     43(define (internal-module-name? str)
     44  (not (zero? (global-symbol-name-offset str))) )
     45
    3646(: split-prefixed-symbol (symbol --> string string))
    3747;
    … …  
    3949  (let* (
    4050    (str (symbol->string sym))
    41     ;assume # not part of module name (-right would mean # not part of symbol)
    42     ;so cannot handle qualified symbols
    43     (idx (string-index str #\#))
     51    (idx (string-index str #\# (global-symbol-name-offset str)))
    4452    (mod (if idx (string-take str idx) *toplevel-module-string*))
    4553    (nam (if idx (string-drop str (fx+ 1 idx)) str)) )

  • release/5/apropos/trunk/tests/apropos-test.scm

    r37049 r37095  
    1212  (chicken sort)
    1313  apropos-api)
    14 
    15 ;FIXME need #:split tests
    1614
    1715;;
    … …  
    7270  (apropos-list "foobar"))
    7371
    74 #;
    7572(apropos-list-test
    7673  '(##bar#foo1 ##bar#foo2 foobarmacro1 foobarmacro2 foobarproc0 foobarproc1 foobarproc2 foobarprocn foobarprocx foobarvar1 foobarvar2)
    77   (apropos-list 'foo #:macros? #t))
     74  (apropos-list 'foo #:macros? #t #:internal? #t #:split #:name))
     75
     76(apropos-list-test
     77  '(##foo#bar1 ##foo#bar2)
     78  (apropos-list 'foo #:macros? #t #:internal? #t #:split #:module))
    7879
    7980(apropos-list-test
    … …  
    132133        ((|| . foobarvar1) . variable)
    133134        ((|| . foobarvar2) . variable) )
    134       (apropos-information-list 'foobar #:macros? #t))
     135      (apropos-information-list 'foobar #:macros? #t #:internal? #t))
    135136    (test "apropos-information-list"
    136137      '(((|| . foobarproc0) procedure)
    … …  
    139140        ((|| . foobarprocn) procedure a b . r)
    140141        ((|| . foobarprocx) procedure a b c))
    141       (apropos-information-list 'foobarproc #:macros? #t #:sort #:module)) ) )
     142      (apropos-information-list 'foobarproc #:macros? #t #:internal? #t #:sort #:module)) ) )
    142143
    143144#| ;UNSUPPORTED
    … …  
    158159
    159160(test '(foobarprocx foobarvar2 foobarvar1 ##bar#foo1)
    160       (apropos-list 'foo tstenv1))
     161      (apropos-list 'foo tstenv1 #:internal? #t))
    161162|#
    162163
Note: See TracChangeset for help on using the changeset viewer.