Changeset 36031 in project


Ignore:
Timestamp:
08/04/18 22:27:43 (2 years ago)
Author:
Kon Lovett
Message:

split into csi & api modules

Location:
release/5/apropos/trunk
Files:
2 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/apropos/trunk/apropos.egg

    r35899 r36031  
    33
    44((synopsis "Chicken apropos")
    5  (version "3.0.0")
     5 (version "3.1.0")
    66 (category misc)
    7  (author "[[Kon Lovett|kon lovett]]")
     7 (author "[[kon lovett]]")
    88 (license "BSD")
    99 (dependencies
     
    1616 (test-dependencies test)
    1717 (components
     18  (extension apropos-api
     19    #;(inline-file)
     20    (types-file)
     21    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     22  (extension apropos-csi
     23    #;(inline-file)
     24    (types-file)
     25    (component-dependencies apropos-api)
     26    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    1827  (extension apropos
    1928    #;(inline-file)
    2029    (types-file)
    21     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") ) ) )
     30    (component-dependencies apropos-csi apropos-api)
     31    (csc-options "-O3" "-d1" "-local") ) ) )
  • release/5/apropos/trunk/apropos.scm

    r35825 r36031  
    2525;; ; {{SEARCH-MODE}} : Either {{#:prefix}}, {{#:suffix}}, or {{#t}} for contains. The default is {{#t}}.
    2626
    27 (declare
    28   (bound-to-procedure
    29     ##sys#fast-reverse
    30     ##sys#symbol-has-toplevel-binding?
    31     ##sys#macro-environment
    32     ##sys#current-environment
    33     ##sys#macro?))
     27(module apropos ()
    3428
    35 (module apropos
     29(import scheme (chicken module))
     30(import apropos-api apropos-csi)
    3631
    37 (;export
    38   ;
    39   apropos-interning apropos-default-options
    40   ;Original
    41   apropos apropos-list apropos-information-list
    42   ;Crispy
    43   ;apropos/environment apropos-list/environment apropos-information-list/environment
    44   ;Extra Crispy
    45   ;apropos/environments apropos-list/environments apropos-information-list/environments
    46 )
    47 
    48 (import scheme
    49   (chicken base)
    50   (chicken foreign)
    51   (chicken platform)
    52   (chicken io)
    53   (chicken syntax)
    54   (chicken keyword)
    55   (chicken fixnum)
    56   (chicken port)
    57   (chicken sort)
    58   (chicken type)
    59   (only (chicken csi) toplevel-command)
    60   (only (srfi 1) cons* reverse! append! last-pair)
    61   (only (srfi 13)
    62     string-join
    63     string-trim-both
    64     string-contains string-contains-ci
    65     string-drop string-take string-index)
    66   (only (chicken irregex)
    67     sre->irregex
    68     irregex irregex?
    69     irregex-num-submatches
    70     irregex-search irregex-match
    71     irregex-match-data? irregex-match-num-submatches
    72     irregex-replace)
    73   miscmacros
    74   (only memoized-string make-string+)
    75   (only symbol-name-utils
    76     symbol->keyword
    77     symbol-printname=? symbol-printname<?
    78     symbol-printname-length max-symbol-printname-length)
    79   (only symbol-qualified-utils qualified-symbol?)
    80   (only type-checks check-fixnum define-check+error-type)
    81   (only type-errors define-error-type error-argument-type))
    82 
    83 ;;; Support
    84 
    85 ;;; File Utilities
    86 
    87 (define (read-file #!optional (port ##sys#standard-input) (reader read) max)
    88   ;
    89   (define (slurp port)
    90     (do ((x (reader port) (reader port))
    91          (i 0 (fx+ i 1))
    92          (xs '() (cons x xs)) )
    93       ((or (eof-object? x) (and max (fx>= i max))) (##sys#fast-reverse xs)) ) )
    94   ;
    95   (if (port? port)
    96     (slurp port)
    97           (call-with-input-file port slurp) ) )
    98 
    99 ;;
    100 
    101 (define (any? x)
    102   #t )
    103 
    104 ;; Raw Access Renames
    105 
    106 (define system-current-environment ##sys#current-environment)
    107 
    108 (define system-macro-environment ##sys#macro-environment)
    109 
    110 (define (global-symbol-bound? sym)
    111   (##sys#symbol-has-toplevel-binding? sym) )
    112 
    113 (define (global-symbol-ref sym)
    114   (##sys#slot sym 0) )
    115 
    116 (define (symbol-macro-in-environment? sym macenv)
    117   (and sym macenv (##sys#macro? sym macenv)) )
    118 
    119 ;;
    120 
    121 ;for our purposes
    122 (define-constant *CHICKEN-MAXIMUM-BASE* 16)
    123 
    124 ;;
    125 
    126 (define (->boolean obj)
    127   (and obj #t ) )
    128 
    129 ;; irregex extensions
    130 
    131 (define (irregex-submatches? mt #!optional ire)
    132   (and
    133     (irregex-match-data? mt)
    134     (or
    135       (not ire)
    136       (fx=
    137         (irregex-match-num-submatches mt)
    138         (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
    139 
    140 ;; string extensions
    141 
    142 (define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
    143   (let ((rem (fx- n (string-length x))))
    144     (if (positive? rem)
    145       (string-append x (make-string rem pad))
    146       (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
    147 
    148 ;; Constants
    149 
    150 (define-constant CSI-HELP-HEAD-WIDTH 18)
    151 
    152 (define (csi-help-command-pad x)
    153   (string-fixed-length x CSI-HELP-HEAD-WIDTH) )
    154 
    155 (define (csi-help cmd arg)
    156   (string-append (string-fixed-length cmd CSI-HELP-HEAD-WIDTH) arg) )
    157 
    158 ;rmvd ", raw, base [#]"
    159 (define CSI-HELP
    160   (csi-help
    161     ",a PATT ARG..."
    162     "Apropos of PATT with ARG from ?, mac, qual, ci, sort nam|mod|typ|#f, split nam|mod|#f"))
    163 
    164 (define-constant HELP-TEXT
    165 #<<EOS
    166 Pattern:
    167 
    168  The pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
    169  strings are interpreted as a substring match.
    170 
    171  The quoted PATT:
    172 
    173    '(PATT . PATT):
    174 
    175       '(PATT . _) is a synonym for `PATT split module`.
    176 
    177       '(_ . PATT) is a synonym for `PATT split name`.
    178 
    179       '(_ . _) is a synonym for `(: (* any))` or match any.
    180 
    181       '(PATT . PATT) performs as if `PATT+PATT split module+name` worked.
    182 
    183   '<atom>
    184 
    185     interpret `<atom>` as an irregex.
    186 
    187  Use "?" as a PATT to list symbols containing a `?`.
    188 
    189 Arguments:
    190 
    191  macros            Include macro bound symbols
    192  qualified         Include "qualified" symbols
    193  ci | case-insensitive
    194                    Pattern has no capitals
    195  sort name | module | type | #f
    196                    Order items; optional when last argument
    197  split name | module | #f
    198                    Pattern match component; optional when last argument
    199                    (also see the '(_ . _) pattern)
    200  all               Means `ci qual mac`
    201  krl               Means `all sort mod`
    202  base              For number valued pattern
    203  raw               No listing symbol interpretation (i.e. x123 ~> x)
    204 EOS
    205 )
    206 
    207 ;; Types
    208 
    209 (define (search-pattern? obj)
    210   (or
    211     (keyword? obj)
    212     (symbol? obj)
    213     (string? obj)
    214     (irregex? obj)
    215     (pair? obj)) )
    216 
    217 (define (sort-key? obj)
    218   (or
    219     (not obj)
    220     (eq? #:name obj)
    221     (eq? #:module obj)
    222     (eq? #:type obj)) )
    223 
    224 ;; Errors
    225 
    226 (define (error-argument loc arg)
    227   (if (keyword? arg)
    228     (error loc "unrecognized keyword argument" arg)
    229     (error loc "unrecognized argument" arg) ) )
    230 
    231 ;; Argument Checking
    232 
    233 (define-check+error-type search-pattern search-pattern?
    234   "symbol/keyword/string/irregex/irregex-sre/quoted")
    235 
    236 (define-check+error-type sort-key sort-key? "#:name, #:module, #:type or #f")
    237 
    238 #; ;UNSUPPORTED
    239 (define-check+error-type environment system-environment?)
    240 
    241 ;; Number Base
    242 
    243 (define-constant *APROPOS-DEFAULT-BASE* 10)
    244 
    245 (define (number-base? obj)
    246   (and (fixnum? obj) (fx<= 2 obj) (<= obj *CHICKEN-MAXIMUM-BASE*)) )
    247 
    248 (define *number-base-error-message*
    249   (string-append "fixnum in 2.." (number->string *CHICKEN-MAXIMUM-BASE*)))
    250 
    251 (define (check-number-base loc obj #!optional (var 'base))
    252   (unless (number-base? obj)
    253     (error-argument-type loc obj *number-base-error-message* var) )
    254   obj )
    255 
    256 (define (check-split-component loc obj #!optional (var 'split))
    257   (case obj
    258     ((#f)
    259       obj )
    260     ((#:module #:name)
    261       obj )
    262     (else
    263       (error-argument-type loc obj "invalid identifier component" var)) ) )
    264 
    265 ;; Symbols
    266 
    267 (define (string-irregex-match? str patt)
    268   (irregex-search patt str) )
    269 
    270 (define (string-exact-match? str patt)
    271   (string-contains str patt) )
    272 
    273 (define (string-ci-match? str patt)
    274   (string-contains-ci str patt) )
    275 
    276 (define (symbol-irregex-match? sym patt)
    277   (string-irregex-match? (symbol->string sym) patt) )
    278 
    279 (define (symbol-exact-match? sym patt)
    280   (string-exact-match? (symbol->string sym) patt) )
    281 
    282 (define (symbol-ci-match? sym patt)
    283   (string-ci-match? (symbol->string sym) patt) )
    284 
    285 (define *TOPLEVEL-MODULE-SYMBOL* '||)
    286 (define *TOPLEVEL-MODULE-STRING* "" #;(symbol->string *TOPLEVEL-MODULE-SYMBOL*))
    287 
    288 (: split-prefixed-symbol (symbol --> string string))
    289 ;
    290 (define (split-prefixed-symbol sym)
    291   (let* (
    292     (str (symbol->string sym))
    293     ;assume # not part of module name
    294     (idx (string-index str #\#))
    295     (mod (if idx (string-take str idx) *TOPLEVEL-MODULE-STRING*))
    296     (nam (if idx (string-drop str (fx+ 1 idx)) str)) )
    297     ;
    298     (values mod nam) ) )
    299 
    300 ;; special stuff from the runtime & scheme API
    301 
    302 #>
    303 #define ROOT_SYMBOL_TABLE_NAME  "."
    304 
    305 #define raw_symbol_table_size( stable )       ((stable)->size)
    306 #define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
    307 
    308 #define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
    309 #define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
    310 
    311 static C_regparm C_SYMBOL_TABLE *
    312 find_root_symbol_table()
    313 {
    314   return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
    315 }
    316 
    317 static C_regparm C_SYMBOL_TABLE *
    318 remember_root_symbol_table()
    319 {
    320   static C_SYMBOL_TABLE *root_symbol_table = NULL;
    321   if(!root_symbol_table) {
    322     root_symbol_table = find_root_symbol_table();
    323   }
    324 
    325   return root_symbol_table;
    326 }
    327 
    328 //FIXME root_symbol_table re-allocated?
    329 //#define use_root_symbol_table   find_root_symbol_table
    330 #define use_root_symbol_table    remember_root_symbol_table
    331 <#
    332 
    333 (: root-symbol-table-size (--> fixnum))
    334 ;
    335 (define root-symbol-table-size
    336   (foreign-lambda* int ()
    337     "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )
    338 
    339 (: root-symbol-table-element (fixnum --> pair))
    340 ;
    341 (define root-symbol-table-element
    342   (foreign-lambda* scheme-object ((int i))
    343     "C_return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
    344 
    345 (: bucket-symbol (pair --> symbol))
    346 ;
    347 (define bucket-symbol
    348   (foreign-lambda* scheme-object ((scheme-object bucket))
    349     "C_return( raw_bucket_symbol( bucket ) );"))
    350 
    351 (: bucket-link (pair --> list))
    352 ;
    353 (define bucket-link
    354   (foreign-lambda* scheme-object ((scheme-object bucket))
    355     "C_return( raw_bucket_link( bucket ) );"))
    356 
    357 (: bucket-last? (list --> boolean))
    358 ;
    359 (define bucket-last? null?)
    360 
    361 ;;
    362 
    363 (define-type <symbol-table-cursor> (or boolean pair))
    364 
    365 (: make-symbol-table-cursor (* * --> <symbol-table-cursor>))
    366 ;
    367 (define make-symbol-table-cursor cons)
    368 
    369 (: symbol-table-cursor-active? (* --> boolean))
    370 ;
    371 (define symbol-table-cursor-active? pair?)
    372 
    373 (: symbol-table-cursor? (* --> boolean))
    374 ;
    375 (define (symbol-table-cursor? obj)
    376   (or
    377     (not obj)
    378     (symbol-table-cursor-active? obj)) )
    379 
    380 (: symbol-table-cursor-index (<symbol-table-cursor> --> *))
    381 ;
    382 (define symbol-table-cursor-index car)
    383 
    384 (: set-symbol-table-cursor-index! (<symbol-table-cursor> * -> void))
    385 ;
    386 (define set-symbol-table-cursor-index! set-car!)
    387 
    388 (: symbol-table-cursor-bucket (<symbol-table-cursor> --> *))
    389 ;
    390 (define symbol-table-cursor-bucket cdr)
    391 
    392 (: set-symbol-table-cursor-bucket! (<symbol-table-cursor> * -> void))
    393 ;
    394 (define set-symbol-table-cursor-bucket! set-cdr!)
    395 
    396 (: symbol-table-cursor (--> <symbol-table-cursor>))
    397 ;
    398 (define (symbol-table-cursor)
    399   (make-symbol-table-cursor -1 '()) )
    400 
    401 ;;
    402 
    403 (: search-interaction-environment-symbols (* procedure --> list))
    404 ;
    405 (define (search-interaction-environment-symbols env optarg?)
    406   (let loop ((cursor (initial-symbol-table-cursor)) (syms '()))
    407     (let ((sym (root-symbol cursor)))
    408       (if (not sym)
    409         syms
    410         (let ((syms (if (optarg? sym) (cons sym syms) syms)))
    411           (loop (next-root-symbol cursor) syms) ) ) ) ) )
    412 
    413 (: search-list-environment-symbols (list procedure --> list))
    414 ;
    415 (define (search-list-environment-symbols env optarg?)
    416   (foldl
    417     (lambda (syms cell)
    418       (let ((sym (car cell)))
    419         (if (optarg? sym)
    420           (cons sym syms)
    421           syms ) ) )
    422     '()
    423     env) )
    424 
    425 (: search-macro-environment-symbols (list procedure --> list))
    426 ;
    427 (define (search-macro-environment-symbols env optarg?)
    428   (search-list-environment-symbols env optarg?) )
    429 
    430 (: search-system-environment-symbols (list procedure --> list))
    431 ;
    432 (define (search-system-environment-symbols env optarg?)
    433   (if env
    434     (search-list-environment-symbols env optarg?)
    435     (search-interaction-environment-symbols env optarg?) ) )
    436 
    437 ;;
    438 
    439 (: next-root-symbol (<symbol-table-cursor> --> <symbol-table-cursor>))
    440 ;
    441 (define (next-root-symbol cursor)
    442   (and
    443     (symbol-table-cursor-active? cursor)
    444     (let loop (
    445       (bkt (bucket-link-ref (symbol-table-cursor-bucket cursor)))
    446       (idx (symbol-table-cursor-index cursor)))
    447       ;gotta bucket ?
    448       (if (and bkt (not (bucket-last? bkt)))
    449         ;then found something => where we are
    450         (make-symbol-table-cursor idx bkt)
    451         ;else try next hash-root slot
    452         (let ((idx (fx+ 1 idx)))
    453           (and
    454             ;more to go ?
    455             (< idx (root-symbol-table-size))
    456             ;this slot
    457             (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
    458 
    459 (: initial-symbol-table-cursor (--> <symbol-table-cursor>))
    460 ;
    461 (define (initial-symbol-table-cursor)
    462   (next-root-symbol (symbol-table-cursor)) )
    463 
    464 (: root-symbol (<symbol-table-cursor> --> (or boolean symbol)))
    465 ;
    466 (define (root-symbol cursor)
    467   (and
    468     (symbol-table-cursor-active? cursor)
    469     (bucket-symbol-ref (symbol-table-cursor-bucket cursor)) ) )
    470 
    471 (: bucket-symbol-ref (list --> (or boolean symbol)))
    472 ;
    473 (define (bucket-symbol-ref bkt)
    474   (and
    475     (not (bucket-last? bkt))
    476     (bucket-symbol bkt) ) )
    477 
    478 (: bucket-link-ref (list --> (or boolean list)))
    479 ;
    480 (define (bucket-link-ref bkt)
    481   (and
    482     (not (bucket-last? bkt))
    483     (bucket-link bkt)) )
    484 
    485 ;;
    486 
    487 ;;
    488 
    489 #; ;UNSUPPORTED
    490 (define (system-environment? obj)
    491   (or (##sys#environment? obj) (sys::macro-environment? obj)) )
    492 
    493 ;; Environment Search
    494 
    495 (define (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
    496   (let (
    497     (optarg?
    498       (if qualified?
    499         any?
    500         (lambda (x)
    501           (not (qualified-symbol? x))))))
    502     (search-macro-environment-symbols macenv
    503       (lambda (sym)
    504         (and
    505           (symbol-match? sym)
    506           (optarg? sym)))) ) )
    507 
    508 (define (*apropos-list/environment loc symbol-match? env qualified?)
    509   (let (
    510     (optarg?
    511       (if qualified?
    512         global-symbol-bound?
    513         (lambda (x)
    514           (and
    515             (not (qualified-symbol? x))
    516             (global-symbol-bound? x))))))
    517     ;
    518     (search-system-environment-symbols env
    519       (lambda (sym)
    520         (and
    521           (symbol-match? sym)
    522           (optarg? sym)))) ) )
    523 
    524 ;;
    525 
    526 ; => (envsyms . macenvsyms)
    527 (define (*apropos-list loc symbol-match? env macenv qualified?)
    528   (append
    529     (*apropos-list/environment loc symbol-match? env qualified?)
    530     (if macenv
    531       (*apropos-list/macro-environment loc symbol-match? macenv qualified?)
    532       '())) )
    533 
    534 ;; Argument List Parsing
    535 
    536 (define default-environment system-current-environment)
    537 (define default-macro-environment system-macro-environment)
    538 
    539 (define-constant ANY-SYMBOL '_)
    540 
    541 (define (make-apropos-matcher loc patt
    542             #!optional
    543               (case-insensitive? #f)
    544               (split #f)
    545               (force-regexp? #f))
    546   ;
    547   (define (gen-irregex-options-list)
    548     (if case-insensitive? '(case-insensitive) '()) )
    549   ;
    550   (define (gen-irregex patt)
    551     (apply irregex patt (gen-irregex-options-list)) )
    552   ;
    553   (define (gen-irregex-matcher irx)
    554     (cond
    555       ((eq? #:module split)
    556         (lambda (sym)
    557           (let-values (
    558             ((mod nam) (split-prefixed-symbol sym)) )
    559             (string-irregex-match? mod irx) ) ) )
    560       ((eq? #:name split)
    561         (lambda (sym)
    562           (let-values (
    563             ((mod nam) (split-prefixed-symbol sym)) )
    564             (string-irregex-match? nam irx) ) ) )
    565       ((not split)
    566         (cut symbol-irregex-match? <> irx) ) ) )
    567   ;
    568   (define (gen-string-matcher str)
    569     (if (not split)
    570       ;no split
    571       (cut (if case-insensitive? symbol-ci-match? symbol-exact-match?) <> str)
    572       ;splitting
    573       (let (
    574         (matcher (if case-insensitive? string-ci-match? string-exact-match?)) )
    575         (cond
    576           ((eq? #:module split)
    577             (lambda (sym)
    578               (let-values (
    579                 ((mod nam) (split-prefixed-symbol sym)) )
    580                 (matcher mod str) ) ) )
    581           ((eq? #:name split)
    582             (lambda (sym)
    583               (let-values (
    584                 ((mod nam) (split-prefixed-symbol sym)) )
    585                 (matcher nam str) ) ) ) ) ) ) )
    586   ;
    587   (cond
    588     ((symbol? patt)
    589       (make-apropos-matcher loc
    590         (symbol->string patt)
    591         case-insensitive? split force-regexp?) )
    592     ((string? patt)
    593       (if force-regexp?
    594         (gen-irregex-matcher (gen-irregex patt))
    595         (gen-string-matcher patt)) )
    596     ((irregex? patt)
    597       (gen-irregex-matcher patt) )
    598     ((pair? patt)
    599       (if (not (eq? 'quote (car patt)))
    600         ;then assume an irregex
    601         (gen-irregex-matcher (gen-irregex patt))
    602         ;else some form of pattern
    603         (let ((quoted (cadr patt)))
    604           ;'(___ . <atom>)
    605           (if (pair? quoted)
    606             ;then could be a split (name|module) pattern
    607             (cond
    608               ;elaborate match any
    609               ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
    610                 (make-apropos-matcher loc '(: (* any)) #f #f #t) )
    611               ;name split?
    612               ((eq? ANY-SYMBOL (car quoted))
    613                 (make-apropos-matcher loc
    614                   (cdr quoted)
    615                   case-insensitive? #:name force-regexp?) )
    616               ;module split?
    617               ((eq? ANY-SYMBOL (cdr quoted))
    618                 (make-apropos-matcher loc
    619                   (car quoted)
    620                   case-insensitive? #:module force-regexp?) )
    621               ;both name & module
    622               (else
    623                 (let (
    624                   (modr
    625                     (make-apropos-matcher loc
    626                       (car quoted)
    627                       case-insensitive? #:module force-regexp?))
    628                   (namr
    629                     (make-apropos-matcher loc
    630                       (cdr quoted)
    631                       case-insensitive? #:name force-regexp?)) )
    632                   (lambda (sym)
    633                     (and (modr sym) (namr sym)) ) ) ) )
    634             ;else interpretation of stripped
    635             (make-apropos-matcher loc
    636               quoted
    637               case-insensitive? split #t) ) ) ) )
    638     (else
    639       (error loc "invalid apropos pattern form" patt) ) ) )
    640 
    641 ;;
    642 
    643 ; => (values val args)
    644 (define (keyword-argument args kwd #!optional val)
    645   (let loop ((args args) (oargs '()))
    646     (if (null? args)
    647       (values val (reverse! oargs))
    648       (let ((arg (car args)))
    649         (cond
    650           ((eq? kwd arg)
    651             (set! val (cadr args))
    652             (loop (cddr args) oargs) )
    653           (else
    654             (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
    655 
    656 ; => (values sort-key args)
    657 (define (parse-sort-key-argument loc args)
    658   (receive (sort-key args) (keyword-argument args #:sort #:type)
    659     (values (check-sort-key loc sort-key #:sort) args) ) )
    660 
    661 ;;
    662 
    663 ;#!optional (env (default-environment)) macenv #!key macros? qualified? base (split #:all)
    664 ;
    665 ;macenv is #t for default macro environment or a macro-environment object.
    666 ;
    667 ;=> (values apropos-ls macenv)
    668 (define (parse-arguments-and-match loc patt iargs)
    669   (let-values (
    670     ((env macenv qualified? case-insensitive? base raw? split)
    671       (parse-rest-arguments loc iargs)))
    672     ;
    673     (let* (
    674       (patt
    675         (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern) )
    676       (matcher
    677         (make-apropos-matcher loc patt case-insensitive? split) )
    678       (als
    679         (*apropos-list loc matcher env macenv qualified?) ) )
    680       ;
    681       (values als macenv raw?) ) ) )
    682 ;;
    683 
    684 ;=> (values env macenv qualified? base)
    685 (define (parse-rest-arguments loc iargs)
    686   (let (
    687     (env #f)        ;(default-environment)
    688     (macenv #f)
    689     (qualified? #f)
    690     (raw? #f)
    691     (case-insensitive? #f)
    692     (split #f)
    693     (base *APROPOS-DEFAULT-BASE*)
    694     (1st-arg? #t) )
    695     ;
    696     (let loop ((args iargs))
    697       (if (null? args)
    698         ;seen 'em all
    699         (values env macenv qualified? case-insensitive? base raw? split)
    700         ;process potential arg
    701         (let ((arg (car args)))
    702           ;keyword argument?
    703           (cond
    704             ;
    705             ((eq? #:split arg)
    706               (set! split (check-split-component loc (cadr args)))
    707               (loop (cddr args)) )
    708             ;
    709             ((eq? #:raw? arg)
    710               (set! raw? (cadr args))
    711               (loop (cddr args)) )
    712             ;
    713             ((eq? #:base arg)
    714               (when (cadr args)
    715                 (set! base (check-number-base loc (cadr args))) )
    716               (loop (cddr args)) )
    717             ;
    718             ((eq? #:macros? arg)
    719               ;only flag supported
    720               (when (cadr args)
    721                 (set! macenv (default-macro-environment)) )
    722               (loop (cddr args)) )
    723             ;
    724             ((eq? #:qualified? arg)
    725               (set! qualified? (cadr args))
    726               (loop (cddr args)) )
    727             ;
    728             ((eq? #:case-insensitive? arg)
    729               (set! case-insensitive? (cadr args))
    730               (loop (cddr args)) )
    731             ;environment argument?
    732             (1st-arg?
    733               ;FIXME need real 'environment?' predicate
    734               (unless (list? arg)
    735                 (error-argument loc arg) )
    736               (set! 1st-arg? #f)
    737               (set! env arg)
    738               (loop (cdr args)) )
    739             ;unkown argument
    740             (else
    741               (error-argument loc arg) ) ) ) ) ) ) )
    742 
    743 ;;
    744 
    745 (define (fixup-pattern-argument patt #!optional (base *APROPOS-DEFAULT-BASE*))
    746   (cond
    747     ((boolean? patt)
    748       (if patt "#t" "#f") )
    749     ((char? patt)
    750       (string patt) )
    751     ((number? patt)
    752       (number->string patt base) )
    753     ;? pair vector ... ->string , struct use tag as patt ?
    754     (else
    755       patt ) ) )
    756 
    757 #| ;UNSUPPORTED ;FIXME case-insensitive support
    758 ;;
    759 
    760 (define (macro-environment obj)
    761   (and
    762     (sys::macro-environment? obj)
    763     obj) )
    764 
    765 ;;
    766 
    767 ; => (values envsyms macenv)
    768 
    769 (define (parse-arguments/environment loc patt env qualified?)
    770   (check-search-pattern loc patt 'pattern)
    771   (let ((macenv (macro-environment (check-environment loc env 'environment))))
    772     (values
    773       (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv qualified?)
    774       macenv) ) )
    775 
    776 ;;
    777 
    778 ; #!key qualified?
    779 ;
    780 ; => (... (macenv . syms) ...)
    781 
    782 (define (parse-arguments/environments loc patt args)
    783   ;
    784   (define (parse-rest-arguments)
    785     (let ((qualified? #f))
    786       (let loop ((args args) (envs '()))
    787         (if (null? args)
    788           (values (reverse! envs) qualified?)
    789           (let ((arg (car args)))
    790             ;keyword argument?
    791             (cond
    792               ((eq? #:qualified? arg)
    793                 (when (cadr args) (set! qualified? #t))
    794                 (loop (cddr args) envs) )
    795               ;environment argument?
    796               (else
    797                 (unless (##sys#environment? arg)
    798                   (error-argument loc arg) )
    799                 (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
    800   ;
    801   (let ((patt (fixup-pattern-argument patt)))
    802     (check-search-pattern loc patt 'pattern)
    803     (receive (envs qualified?) (parse-rest-arguments)
    804       (let ((regexp (make-apropos-matcher loc patt)))
    805         (let loop ((envs envs) (envsyms '()))
    806           (if (null? envs)
    807             (reverse! envsyms)
    808             (let* ((env (car envs))
    809                    (macenv (macro-environment (check-environment loc env 'environment)))
    810                    (make-envsyms
    811                      (lambda ()
    812                        (cons
    813                          macenv
    814                          (*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
    815               (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
    816 |#
    817 
    818 ;;; Display
    819 
    820 ;;
    821 
    822 (define apropos-interning (make-parameter #t (lambda (x)
    823   (if (boolean? x)
    824     x
    825     (begin
    826       (warning 'apropos-interning "not a boolean: " x)
    827       (apropos-interning))))))
    828 
    829 (define (string->display-symbol str)
    830   ((if (apropos-interning) string->symbol string->uninterned-symbol) str) )
    831 
    832 ;;
    833 
    834 ;;
    835 
    836 #| ;A Work In Progress
    837 
    838 ; UNDECIDEDABLE - given the data available from `procedure-information',
    839 ; serial nature of `gensym', and serial nature of argument coloring by
    840 ; compiler.
    841 
    842 ; `pointer+' is an example of a `foreign-lambda*', here all info is lost & the
    843 ; gensym identifiers can just be colored using a base of 1.
    844 
    845 ;best guess:
    846 ;
    847 ;here `(cs1806 cs2807 . csets808)'        `(cs1 cs2 . csets)'
    848 ;here `(foo a1 b2)'                       `(foo a1 b2)'
    849 ;here `(a380384 a379385)'                 `(arg1 arg2)'
    850 ;here `(=1133 lis11134 . lists1135)'      `(= lis1 . lists)'
    851 
    852 (define apropos-gensym-suffix-limit 1)
    853 
    854 ;When > limit need to keep leading digit
    855 
    856 ; un-qualified symbols only!
    857 (define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
    858   (let* (
    859     (str (symbol->string sym))
    860     (idx (string-skip-right str char-set:digit))
    861     (idx (and idx (fx+ 1 idx))) )
    862     ;
    863     (cond
    864       ((not idx)
    865         sym )
    866       ((fx< (fx- (string-length str) idx) limit)
    867         sym )
    868       (else
    869         (string->display-symbol (substring str 0 idx)) ) ) ) )
    870 
    871 ; arg-lst-template is-a pair!
    872 (define (scrub-gensym-effect arg-lst-template)
    873   (let (
    874     (heads (butlast arg-lst-template))
    875     (tailing (last-pair arg-lst-template)) )
    876     ;
    877     (append!
    878       (map scrub-gensym-taste heads)
    879       (if (null? (cdr tailing))
    880         (list (scrub-gensym-taste (car tailing)))
    881         (cons
    882           (scrub-gensym-taste (car tailing))
    883           (scrub-gensym-taste (cdr tailing)))) ) ) )
    884 |#
    885 
    886 (define (identifier-components sym raw?)
    887   (cond
    888     (raw?
    889       (cons *TOPLEVEL-MODULE-SYMBOL* sym) )
    890     ((qualified-symbol? sym)
    891       (cons *TOPLEVEL-MODULE-SYMBOL* sym) )
    892     (else
    893       (let-values (
    894         ((mod nam) (split-prefixed-symbol sym)) )
    895         (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) ) )
    896 
    897 ;FIXME make patt a param ?
    898 (define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
    899 (define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast))
    900 
    901 (define (canonical-identifier-name id raw?)
    902   (if raw?
    903     id
    904     (let* (
    905       (pname (symbol->string id) )
    906       (mt (irregex-match *GENSYM_SRE* pname) ) )
    907       ;
    908       (if (irregex-submatches? mt *GENSYM_SRE*)
    909         (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
    910         id ) ) ) )
    911 
    912 (define (canonicalize-identifier-names form raw?)
    913   (cond
    914     (raw?
    915       form )
    916     ((symbol? form)
    917       (canonical-identifier-name form raw?) )
    918     ((pair? form)
    919       (cons
    920         (canonicalize-identifier-names (car form) raw?)
    921         (canonicalize-identifier-names (cdr form) raw?)) )
    922     (else
    923       form ) ) )
    924 
    925 ; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
    926 (define (procedure-details proc raw?)
    927   (let ((info (procedure-information proc)))
    928     (cond
    929       ((not info)
    930         'procedure )
    931       ((pair? info)
    932         `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
    933       (else
    934         ;was ,(symbol->string info) (? why)
    935         `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
    936 
    937 ; => 'macro | 'keyword | 'variable | <procedure-details>
    938 (define (identifier-type-details sym #!optional macenv raw?)
    939   (cond
    940     ((symbol-macro-in-environment? sym macenv)
    941       'macro )
    942     ((keyword? sym)
    943       'keyword )
    944     (else
    945       (let ((val (global-symbol-ref sym)))
    946         (if (procedure? val)
    947           (procedure-details val raw?)
    948           'variable ) ) ) ) )
    949 
    950 ;;
    951 
    952 (define (make-information sym macenv raw?)
    953   (cons
    954     (identifier-components sym raw?)
    955     (identifier-type-details sym macenv raw?)) )
    956 
    957 (define (*make-information-list syms macenv raw?)
    958   (map (cut make-information <> macenv raw?) syms) )
    959 
    960 (define (identifier-information-module ident-info)
    961   (car ident-info) )
    962 
    963 (define (identifier-information-name ident-info)
    964   (cdr ident-info) )
    965 
    966 (define (detail-information-kind dets-info)
    967   (car dets-info) )
    968 
    969 (define (detail-information-arguments dets-info)
    970   (cdr dets-info) )
    971 
    972 (define (information-identifiers info)
    973   (car info) )
    974 
    975 (define (information-module info)
    976   (identifier-information-module (information-identifiers info)) )
    977 
    978 (define (information-name info)
    979   (identifier-information-name (information-identifiers info)) )
    980 
    981 (define (information-details info)
    982   (cdr info) )
    983 
    984 (define (information-identifier<? info1 info2 #!optional (sort-key #:name))
    985   (receive
    986     (field-1-ref field-2-ref)
    987       (if (eq? #:name sort-key)
    988         (values information-name information-module)
    989         (values information-module information-name) )
    990     (let (
    991       (sym-1-1 (field-1-ref info1) )
    992       (sym-1-2 (field-1-ref info2) ) )
    993       (if (not (symbol-printname=? sym-1-1 sym-1-2))
    994         (symbol-printname<? sym-1-1 sym-1-2)
    995         (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )
    996 
    997 (define (information-kind info)
    998   (let ((d (information-details info)))
    999     (if (symbol? d) d (car d)) ) )
    1000 
    1001 (define (information-kind=? info1 info2)
    1002   (symbol-printname=?
    1003     (information-kind info1)
    1004     (information-kind info2)) )
    1005 
    1006 (define (information-kind<? info1 info2)
    1007   (symbol-printname<?
    1008     (information-kind info1)
    1009     (information-kind info2)) )
    1010 
    1011 (define (information<? info1 info2 #!optional (sort-key #:name))
    1012   (if (information-kind=? info1 info2)
    1013     (information-identifier<? info1 info2 sort-key)
    1014     (information-kind<? info1 info2) ) )
    1015 
    1016 ;;
    1017 
    1018 (define (make-sorted-information-list syms macenv sort-key raw?)
    1019   (let (
    1020     (lessp
    1021       (case sort-key
    1022         ((#:name #:module)
    1023           (cut information-identifier<? <> <> sort-key) )
    1024         ((#:type)
    1025           (cut information<? <> <> #:name) )
    1026         (else
    1027           #f ) ) )
    1028     (ails
    1029       (*make-information-list syms macenv raw?) ) )
    1030     ;
    1031     (if lessp
    1032       (sort! ails lessp)
    1033       ails ) ) )
    1034 
    1035 (define (symbol-pad-length sym maxsymlen)
    1036   (let* (
    1037     (len (symbol-printname-length sym) )
    1038     (maxlen (fxmin maxsymlen len) ) )
    1039     ;
    1040     (fx- maxsymlen maxlen) ) )
    1041 
    1042 (define (display-apropos isyms macenv sort-key raw?)
    1043   ;
    1044   (let* (
    1045     (ails (make-sorted-information-list isyms macenv sort-key raw?) )
    1046     (mods (map information-module ails) )
    1047     (syms (map information-name ails) )
    1048     (maxmodlen (max-symbol-printname-length mods) )
    1049     (maxsymlen (max-symbol-printname-length syms) ) )
    1050     ;
    1051     (define (display-symbol-information info)
    1052       ;<sym><tab>
    1053       (let* (
    1054         (sym (information-name info) )
    1055         (sym-padlen (symbol-pad-length sym maxsymlen) ) )
    1056         ;
    1057         (display sym)
    1058         (display (make-string+ (fx+ 2 sym-padlen))) )
    1059       ;<mod><tab>
    1060       (let* (
    1061         (mod (information-module info) )
    1062         (mod-padlen (symbol-pad-length mod maxmodlen) ) )
    1063         ;
    1064         (if (eq? *TOPLEVEL-MODULE-SYMBOL* mod)
    1065           (display (make-string+ mod-padlen))
    1066           (begin
    1067             (display mod)
    1068             (display (make-string+ (fx+ 2 mod-padlen))) ) ) )
    1069       ;<details>
    1070       (let ((dets (information-details info)))
    1071         (cond
    1072           ((symbol? dets)
    1073             (display dets) )
    1074           (else
    1075             (display (detail-information-kind dets))
    1076             (display #\space)
    1077             (write (detail-information-arguments dets)) ) ) )
    1078       ;d'oy
    1079       (newline) )
    1080     ;
    1081     (for-each display-symbol-information ails) ) )
    1082 
    1083 ;;; API
    1084 
    1085 (define-constant KRL-OPTIONS '(
    1086   #:sort #:module #:case-insensitive? #t #:qualified? #t #:macros? #t))
    1087 
    1088 (define apropos-default-options (make-parameter '() (lambda (x)
    1089   (cond
    1090     ((boolean? x)
    1091       (or
    1092         (and x KRL-OPTIONS)
    1093         '() ) )
    1094     ((list? x)
    1095       x )
    1096     (else
    1097       (warning 'apropos-default-options "not a list of options" x)
    1098       (apropos-default-options))))))
    1099 
    1100 ;; Original
    1101 
    1102 (define (apropos patt . args)
    1103   (let (
    1104     (args (if (null? args) (apropos-default-options) args)) )
    1105     (let*-values (
    1106       ((sort-key args) (parse-sort-key-argument 'apropos args) )
    1107       ((syms macenv raw?) (parse-arguments-and-match 'apropos patt args) ) )
    1108       ;
    1109       (display-apropos syms macenv sort-key raw?) ) ) )
    1110 
    1111 (define (apropos-list patt . args)
    1112   (let (
    1113     (args (if (null? args) (apropos-default-options) args)) )
    1114     (let*-values (
    1115       ((sort-key args) (parse-sort-key-argument 'apropos-list args) )
    1116       ((syms macenv raw?) (parse-arguments-and-match 'apropos-list patt args) ) )
    1117       ;
    1118       syms ) ) )
    1119 
    1120 (define (apropos-information-list patt . args)
    1121   (let (
    1122     (args (if (null? args) (apropos-default-options) args)) )
    1123     (let*-values (
    1124       ((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
    1125       ((syms macenv raw?) (parse-arguments-and-match 'apropos-information-list patt args) ) )
    1126       ;
    1127       (make-sorted-information-list syms macenv sort-key raw?) ) ) )
    1128 
    1129 ;;;
    1130 ;;; REPL Integeration
    1131 ;;;
    1132 
    1133 (define (interp-split-arg loc arg)
    1134   (case arg
    1135     ((n nam name)
    1136       #:name )
    1137     ((m mod module)
    1138       #:module )
    1139     (else
    1140       (if (not arg)
    1141         #f
    1142         (error-sort-key loc "unknown split key" arg) ) ) ) )
    1143 
    1144 (define (interp-sort-arg loc arg)
    1145   (case arg
    1146     ((n nam name)
    1147       #:name )
    1148     ((m mod module)
    1149       #:module )
    1150     ((t typ type)
    1151       #:type )
    1152     (else
    1153       (if (not arg)
    1154         #f
    1155         (error-sort-key loc "unknown sort key" arg) ) ) ) )
    1156 
    1157 (define (display-apropos-help)
    1158   (print CSI-HELP)
    1159   (print)
    1160   (print HELP-TEXT) )
    1161 
    1162 (define (parse-csi-apropos-arguments iargs)
    1163   (let loop ((args iargs) (oargs '()))
    1164     ;
    1165     (define (restargs next optarg?)
    1166       (cond
    1167         ((null? next)
    1168           '() )
    1169         (optarg?
    1170           (cdr next) )
    1171         (else
    1172           next ) ) )
    1173     ;
    1174     (define (arg-next kwd init #!optional optarg?)
    1175       ;
    1176       (define (thisargs next kwd init optarg?)
    1177         (cond
    1178           ((null? next)
    1179             (cons* init kwd oargs) )
    1180           (optarg?
    1181             (cons* (optarg? (car next)) kwd oargs) )
    1182           (else
    1183             (cons* init kwd oargs) ) ) )
    1184       ;
    1185       (let* (
    1186         (next (cdr args) )
    1187         (args (restargs next optarg?) )
    1188         (oargs (thisargs next kwd init optarg?) ) )
    1189         ;
    1190         (loop args oargs) ) )
    1191     ;
    1192     (if (null? args)
    1193       ; original ordering
    1194       (reverse! oargs)
    1195       ;csi-apropos-syntax => keyword-apropos-syntax
    1196       (let ((arg (car args)))
    1197         (case arg
    1198           ;
    1199           ((krl)
    1200             (loop
    1201               (restargs (cons* 'all (cdr args)) #f)
    1202               (cons* #:module #:sort oargs)) )
    1203           ;
    1204           ((all)
    1205             (loop
    1206               (restargs (cdr args) #f)
    1207               (cons* #t #:case-insensitive? #t #:qualified? #t #:macros? oargs)) )
    1208           ;
    1209           ((mac macros)
    1210             (arg-next #:macros? #t) )
    1211           ;
    1212           ((qual qualified)
    1213             (arg-next #:qualified? #t) )
    1214           ;
    1215           ((ci case-insensitive)
    1216             (arg-next #:case-insensitive? #t) )
    1217           ;
    1218           ((raw)
    1219             (arg-next #:raw? #t) )
    1220           ;
    1221           ((base)
    1222             (arg-next #:base *APROPOS-DEFAULT-BASE* (cut check-number-base ',a <>)) )
    1223           ;
    1224           ((sort)
    1225             (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) )
    1226           ;
    1227           ((split)
    1228             (arg-next #:split #f (cut interp-split-arg ',a <>)) )
    1229           ;
    1230           ((?)
    1231             (loop '() '()) )
    1232           ;
    1233           (else
    1234             (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
    1235 
    1236 (define (csi-apropos-command)
    1237   ;FIXME could be empty of args
    1238   (let* (
    1239     (cmdlin (read-line))
    1240     (args (with-input-from-string cmdlin read-file))
    1241     (apropos-args (parse-csi-apropos-arguments args)) )
    1242     ;NOTE will not dump the symbol-table unless explicit ; use '(: (* any))
    1243     (cond
    1244       ((null? apropos-args)
    1245         (display-apropos-help) )
    1246       ((null? (cdr apropos-args))
    1247         (apply apropos (car apropos-args) (apropos-default-options)) )
    1248       (else
    1249         (apply apropos apropos-args) ) ) ) )
    1250 
    1251 ;;; Main
    1252 
    1253 (when (feature? csi:)
    1254   (toplevel-command 'a csi-apropos-command CSI-HELP) )
     32(reexport apropos-api apropos-csi)
    125533
    125634) ;module apropos
    1257 
    1258 #| ;UNSUPPORTED ;FIXME case-insensitive support
    1259 
    1260 ;; Crispy
    1261 
    1262 ==== apropos/environment
    1263 
    1264 <procedure>(apropos/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?) (#:sort SORT))</procedure>
    1265 
    1266 Displays information about identifiers matching {{PATTERN}} in the
    1267 {{ENVIRONMENT}}.
    1268 
    1269 Like {{apropos}}.
    1270 
    1271 ; {{ENVIRONMENT}} : An {{environment}} or a {{macro-environment}}.
    1272 
    1273 ==== apropos-list/environment
    1274 
    1275 <procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
    1276 
    1277 Like {{apropos-list}}.
    1278 
    1279 ==== apropos-information-list/environment
    1280 
    1281 <procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:qualified? QUALIFIED?))</procedure>
    1282 
    1283 Like {{apropos-information-list}}.
    1284 
    1285 (define (apropos/environment patt env #!key qualified? (sort #:name))
    1286   (check-sort-key 'apropos/environment sort #:sort)
    1287   (receive
    1288     (syms macenv)
    1289       (parse-arguments/environment 'apropos/environment patt env qualified?)
    1290     ;
    1291     (newline)
    1292     (display-apropos syms macenv sort-key) ) )
    1293 
    1294 (define (apropos-list/environment patt env #!key qualified?)
    1295   (receive
    1296     (syms macenv)
    1297       (parse-arguments/environment 'apropos/environment patt env qualified?)
    1298     ;
    1299     syms ) )
    1300 
    1301 (define (apropos-information-list/environment patt env #!key qualified?)
    1302   (receive
    1303     (syms macenv)
    1304       (parse-arguments/environment 'apropos/environment patt env qualified?)
    1305     ;
    1306     (*make-information-list syms macenv) ) )
    1307 
    1308 ;; Extra Crispy
    1309 
    1310 ==== apropos/environments
    1311 
    1312 <procedure>(apropos/environments PATTERN (#:qualified? QUALIFIED?) (#:sort SORT) ENVIRONMENT...)</procedure>
    1313 
    1314 Displays information about identifiers matching {{PATTERN}} in each
    1315 {{ENVIRONMENT}}.
    1316 
    1317 Like {{apropos}}.
    1318 
    1319 ; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
    1320 
    1321 ==== apropos-list/environments
    1322 
    1323 <procedure>(apropos-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
    1324 
    1325 Like {{apropos-list}}.
    1326 
    1327 ==== apropos-information-list/environments
    1328 
    1329 <procedure>(apropos-information-list/environments PATTERN (#:qualified? QUALIFIED?) ENVIRONMENT...)</procedure>
    1330 
    1331 Like {{apropos-information-list}}.
    1332 
    1333 (define (apropos/environments patt . args)
    1334   (let-values (((sort-key args) (parse-sort-key-argument 'apropos/environments args)))
    1335     (let ((i 0))
    1336       (for-each
    1337         (lambda (macenv+syms)
    1338           (set! i (fx+ 1 i))
    1339           (newline) (display "** Environment " i " **") (newline) (newline)
    1340           (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
    1341         (parse-arguments/environments 'apropos/environments patt args)) ) ) )
    1342 
    1343 (define (apropos-list/environments patt . args)
    1344   (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
    1345 
    1346 (define (apropos-information-list/environments patt . args)
    1347   (map
    1348     (lambda (macenv+syms) (*make-information-list (cdr macenv+syms) (car macenv+syms)))
    1349     (parse-arguments/environments 'apropos-information-list/environments patt args)) )
    1350 |#
  • release/5/apropos/trunk/tests/apropos-test.scm

    r35819 r36031  
    1111  (chicken syntax)
    1212  (chicken sort)
    13   apropos)
     13  apropos-api)
    1414
    1515;FIXME need #:split tests
Note: See TracChangeset for help on using the changeset viewer.