Changeset 37095 in project
- Timestamp:
- 01/20/19 22:24:42 (11 months ago)
- Location:
- release/5/apropos/trunk
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/apropos/trunk/apropos-api.scm
r37049 r37095 67 67 #t ) 68 68 69 (define (qualified-symbol? sym)70 #f )71 72 69 ;; 73 70 … … 99 96 ;; Symbols 100 97 98 #; ;UNUSED 101 99 (define (symbol-match? sym patt) 102 100 (string-match? (symbol->string sym) patt) ) 103 101 102 #; ;UNUSED 104 103 (define (symbol-exact-match? sym patt) 105 104 (string-exact-match? (symbol->string sym) patt) ) 106 105 106 #; ;UNUSED 107 107 (define (symbol-ci-match? sym patt) 108 108 (string-ci-match? (symbol->string sym) patt) ) … … 183 183 ;; Environment Search 184 184 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)))) ) 212 194 213 195 ;; 214 196 215 197 ; => (envsyms . macenvsyms) 216 (define (*apropos-list loc symbol-match? env macenv qualified?)198 (define (*apropos-list loc matcher env macenv) 217 199 (append 218 (*apropos-list/environment loc symbol-match? env qualified?)200 (*apropos-list/environment loc matcher env) 219 201 (if macenv 220 (*apropos-list/macro-environment loc symbol-match? macenv qualified?)202 (*apropos-list/macro-environment loc matcher macenv) 221 203 '())) ) 222 204 … … 232 214 (case-insensitive? #f) 233 215 (split #f) 234 (force-regexp? #f)) 216 (force-regexp? #f) 217 (internal? #f)) 235 218 ; 236 219 (define (gen-irregex-options-list) … … 242 225 (define (gen-irregex-matcher irx) 243 226 (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) ) ) ) ) 244 233 ((eq? #:module split) 245 234 (lambda (sym) 246 235 (let-values ( 247 236 ((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) ) ) ) ) 249 240 ((eq? #:name split) 250 241 (lambda (sym) 251 242 (let-values ( 252 243 ((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) ) ) ) ) ) ) 256 247 ; 257 248 (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))) 274 271 (matcher nam str) ) ) ) ) ) ) ) 275 272 ; … … 278 275 (make-apropos-matcher loc 279 276 (symbol->string patt) 280 case-insensitive? split force-regexp? ) )277 case-insensitive? split force-regexp? internal?) ) 281 278 ((string? patt) 282 279 (if force-regexp? … … 297 294 ;elaborate match any 298 295 ((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?) ) 300 297 ;name split? 301 298 ((eq? ANY-SYMBOL (car quoted)) 302 299 (make-apropos-matcher loc 303 300 (cdr quoted) 304 case-insensitive? #:name force-regexp? ) )301 case-insensitive? #:name force-regexp? internal?) ) 305 302 ;module split? 306 303 ((eq? ANY-SYMBOL (cdr quoted)) 307 304 (make-apropos-matcher loc 308 305 (car quoted) 309 case-insensitive? #:module force-regexp? ) )306 case-insensitive? #:module force-regexp? internal?) ) 310 307 ;both name & module 311 308 (else … … 314 311 (make-apropos-matcher loc 315 312 (car quoted) 316 case-insensitive? #:module force-regexp? ))313 case-insensitive? #:module force-regexp? internal?)) 317 314 (namr 318 315 (make-apropos-matcher loc 319 316 (cdr quoted) 320 case-insensitive? #:name force-regexp? )) )317 case-insensitive? #:name force-regexp? internal?)) ) 321 318 (lambda (sym) 322 319 (and (modr sym) (namr sym)) ) ) ) ) … … 324 321 (make-apropos-matcher loc 325 322 quoted 326 case-insensitive? split #t ) ) ) ) )323 case-insensitive? split #t internal?) ) ) ) ) 327 324 (else 328 325 (error loc "invalid apropos pattern form" patt) ) ) ) … … 350 347 ;; 351 348 352 ;#!optional (env (default-environment)) macenv #!key macros? qualified? base (split #:all)349 ;#!optional (env (default-environment)) macenv #!key macros? internal? base (split #:all) 353 350 ; 354 351 ;macenv is #t for default macro environment or a macro-environment object. 355 352 ; 356 353 ;=> (values apropos-ls macenv) 354 ; 357 355 (define (parse-arguments-and-match loc patt iargs) 358 356 (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))) 362 358 (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)) ) 370 363 (values als macenv raw?) ) ) ) 371 364 ;; 372 365 373 ;=> (values env macenv qualified? base) 366 ;=> (values env macenv base raw? split internal?) 367 ; 374 368 (define (parse-rest-arguments loc iargs) 375 369 (let ( 376 370 (env #f) ;(default-environment) 377 371 (macenv #f) 378 ( qualified? #f)372 (internal? #f) 379 373 (raw? #f) 380 374 (case-insensitive? #f) … … 386 380 (if (null? args) 387 381 ;seen 'em all 388 (values env macenv qualified? case-insensitive? base raw? split)382 (values env macenv case-insensitive? base raw? split internal?) 389 383 ;process potential arg 390 384 (let ((arg (car args))) … … 394 388 ((eq? #:split arg) 395 389 (set! split (check-split-component loc (cadr args))) 390 (loop (cddr args)) ) 391 ; 392 ((eq? #:internal? arg) 393 (set! internal? (cadr args)) 396 394 (loop (cddr args)) ) 397 395 ; … … 452 450 ; => (values envsyms macenv) 453 451 454 (define (parse-arguments/environment loc patt env qualified?)452 (define (parse-arguments/environment loc patt env) 455 453 (check-search-pattern loc patt 'pattern) 456 454 (let ((macenv (macro-environment (check-environment loc env 'environment)))) 457 455 (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) 459 457 macenv) ) ) 460 458 461 459 ;; 462 460 463 ; #!key qualified?461 ; #!key internal? 464 462 ; 465 463 ; => (... (macenv . syms) ...) … … 468 466 ; 469 467 (define (parse-rest-arguments) 470 (let (( qualified? #f))468 (let ((internal? #f)) 471 469 (let loop ((args args) (envs '())) 472 470 (if (null? args) 473 (values (reverse! envs) qualified?)471 (values (reverse! envs) internal?) 474 472 (let ((arg (car args))) 475 473 ;keyword argument? 476 474 (cond 477 ((eq? #: qualified? arg)478 (when (cadr args) (set! qualified? #t))475 ((eq? #:internal? arg) 476 (when (cadr args) (set! internal? #t)) 479 477 (loop (cddr args) envs) ) 480 478 ;environment argument? … … 486 484 (let ((patt (fixup-pattern-argument patt))) 487 485 (check-search-pattern loc patt 'pattern) 488 (receive (envs qualified?) (parse-rest-arguments)486 (receive (envs internal?) (parse-rest-arguments) 489 487 (let ((regexp (make-apropos-matcher loc patt))) 490 488 (let loop ((envs envs) (envsyms '())) … … 497 495 (cons 498 496 macenv 499 (*apropos-list/environment loc regexp env macenv qualified?)) ) ) )497 (*apropos-list/environment loc regexp env macenv)) ) ) ) 500 498 (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) ) 501 499 |# … … 539 537 ;When > limit need to keep leading digit 540 538 541 ; un-qualified symbols only!542 539 (define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit)) 543 540 (let* ( … … 572 569 (cond 573 570 (raw? 574 (cons *toplevel-module-symbol* sym) )575 ((qualified-symbol? sym)576 571 (cons *toplevel-module-symbol* sym) ) 577 572 (else … … 827 822 ==== apropos/environment 828 823 829 <procedure>(apropos/environment PATTERN ENVIRONMENT (#: qualified? QUALIFIED?) (#:sort SORT))</procedure>824 <procedure>(apropos/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?) (#:sort SORT))</procedure> 830 825 831 826 Displays information about identifiers matching {{PATTERN}} in the … … 838 833 ==== apropos-list/environment 839 834 840 <procedure>(apropos-list/environment PATTERN ENVIRONMENT (#: qualified? QUALIFIED?))</procedure>835 <procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure> 841 836 842 837 Like {{apropos-list}}. … … 844 839 ==== apropos-information-list/environment 845 840 846 <procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#: qualified? QUALIFIED?))</procedure>841 <procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure> 847 842 848 843 Like {{apropos-information-list}}. 849 844 850 (define (apropos/environment patt env #!key qualified? (sort #:name))845 (define (apropos/environment patt env #!key internal? (sort #:name)) 851 846 (check-sort-key 'apropos/environment sort #:sort) 852 847 (receive 853 848 (syms macenv) 854 (parse-arguments/environment 'apropos/environment patt env qualified?)849 (parse-arguments/environment 'apropos/environment patt env internal?) 855 850 ; 856 851 (newline) 857 852 (display-apropos syms macenv sort-key) ) ) 858 853 859 (define (apropos-list/environment patt env #!key qualified?)854 (define (apropos-list/environment patt env #!key internal?) 860 855 (receive 861 856 (syms macenv) 862 (parse-arguments/environment 'apropos/environment patt env qualified?)857 (parse-arguments/environment 'apropos/environment patt env internal?) 863 858 ; 864 859 syms ) ) 865 860 866 (define (apropos-information-list/environment patt env #!key qualified?)861 (define (apropos-information-list/environment patt env #!key internal?) 867 862 (receive 868 863 (syms macenv) 869 (parse-arguments/environment 'apropos/environment patt env qualified?)864 (parse-arguments/environment 'apropos/environment patt env internal?) 870 865 ; 871 866 (*make-information-list syms macenv) ) ) … … 875 870 ==== apropos/environments 876 871 877 <procedure>(apropos/environments PATTERN (#: qualified? QUALIFIED?) (#:sort SORT) ENVIRONMENT...)</procedure>872 <procedure>(apropos/environments PATTERN (#:internal? INTERNAL?) (#:sort SORT) ENVIRONMENT...)</procedure> 878 873 879 874 Displays information about identifiers matching {{PATTERN}} in each … … 886 881 ==== apropos-list/environments 887 882 888 <procedure>(apropos-list/environments PATTERN (#: qualified? QUALIFIED?) ENVIRONMENT...)</procedure>883 <procedure>(apropos-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure> 889 884 890 885 Like {{apropos-list}}. … … 892 887 ==== apropos-information-list/environments 893 888 894 <procedure>(apropos-information-list/environments PATTERN (#: qualified? QUALIFIED?) ENVIRONMENT...)</procedure>889 <procedure>(apropos-information-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure> 895 890 896 891 Like {{apropos-information-list}}. -
release/5/apropos/trunk/apropos-csi.scm
r37049 r37095 36 36 37 37 (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? 41 42 (string-append x (make-string rem pad)) 42 43 (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) ) … … 92 93 base For number valued pattern 93 94 raw No listing symbol interpretation (i.e. x123 ~> x) 95 internal Include internal "modules" 94 96 EOS 95 97 ) … … 101 103 (define (interp-split-arg loc arg) 102 104 (case arg 103 ((n nam name) #:name 104 ((m mod module) #:module 105 ((n nam name) #:name) 106 ((m mod module) #:module) 105 107 (else 106 108 (if (not arg) … … 110 112 (define (interp-sort-arg loc arg) 111 113 (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) 115 117 (else 116 118 (if (not arg) … … 132 134 '() ) 133 135 (optarg? 134 (cdr next) 136 (cdr next)) 135 137 (else 136 138 next ) ) ) … … 141 143 (cond 142 144 ((null? next) 143 (cons* init kwd oargs) 145 (cons* init kwd oargs)) 144 146 (optarg? 145 (cons* (optarg? (car next)) kwd oargs) 147 (cons* (optarg? (car next)) kwd oargs)) 146 148 (else 147 149 (cons* init kwd oargs) ) ) ) 148 150 ; 149 151 (let* ( 150 (next (cdr args) 151 (args (restargs next optarg?) 152 (next (cdr args)) 153 (args (restargs next optarg?)) 152 154 (oargs (thisargs next kwd init optarg?) ) ) 153 155 ; … … 164 166 (loop 165 167 (restargs (cons* 'all (cdr args)) #f) 166 (cons* #:module #:sort oargs)) 168 (cons* #:module #:sort oargs))) 167 169 ; 168 170 ((all) 169 171 (loop 170 172 (restargs (cdr args) #f) 171 (cons* #t #:case-insensitive? #t #:macros? oargs)) 173 (cons* #t #:case-insensitive? #t #:macros? oargs))) 172 174 ; 173 175 ((mac macros) 174 (arg-next #:macros? #t) 176 (arg-next #:macros? #t)) 175 177 ; 176 178 ((ci case-insensitive) 177 (arg-next #:case-insensitive? #t) ) 179 (arg-next #:case-insensitive? #t)) 180 ; 181 ((internal) 182 (arg-next #:internal? #t)) 178 183 ; 179 184 ((raw) 180 (arg-next #:raw? #t) 185 (arg-next #:raw? #t)) 181 186 ; 182 187 ((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 <>))) 184 189 ; 185 190 ((sort) 186 (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) 191 (arg-next #:sort #:type (cut interp-sort-arg ',a <>))) 187 192 ; 188 193 ((split) 189 (arg-next #:split #f (cut interp-split-arg ',a <>)) 194 (arg-next #:split #f (cut interp-split-arg ',a <>))) 190 195 ; 191 196 ((?) 192 (loop '() '()) 197 (loop '() '())) 193 198 ; 194 199 (else -
release/5/apropos/trunk/apropos.egg
r37049 r37095 5 5 6 6 ((synopsis "CHICKEN apropos") 7 (version "3. 2.3")7 (version "3.3.0") 8 8 (category misc) 9 9 (author "[[kon lovett]]") -
release/5/apropos/trunk/symbol-access.scm
r36630 r37095 13 13 global-symbol-ref 14 14 ; 15 internal-module-name? 16 ; 15 17 *toplevel-module-symbol* 16 18 split-prefixed-symbol) … … 20 22 (chicken fixnum) 21 23 (chicken type) 22 (only (srfi 13) string- drop string-take string-index))24 (only (srfi 13) string-prefix? string-drop string-take string-index)) 23 25 24 26 ;;; Raw Access Renames … … 28 30 (define (global-symbol-ref sym) (##sys#slot sym 0)) 29 31 32 (define (global-symbol-name-offset str) 33 (if (string-prefix? "##" str) 2 0) ) 34 30 35 ;;; Toplevel Symbols 31 36 … … 34 39 (define *toplevel-module-string* (symbol->string *toplevel-module-symbol*)) 35 40 41 (: internal-module-name? (string --> boolean)) 42 ; 43 (define (internal-module-name? str) 44 (not (zero? (global-symbol-name-offset str))) ) 45 36 46 (: split-prefixed-symbol (symbol --> string string)) 37 47 ; … … 39 49 (let* ( 40 50 (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))) 44 52 (mod (if idx (string-take str idx) *toplevel-module-string*)) 45 53 (nam (if idx (string-drop str (fx+ 1 idx)) str)) ) -
release/5/apropos/trunk/tests/apropos-test.scm
r37049 r37095 12 12 (chicken sort) 13 13 apropos-api) 14 15 ;FIXME need #:split tests16 14 17 15 ;; … … 72 70 (apropos-list "foobar")) 73 71 74 #;75 72 (apropos-list-test 76 73 '(##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)) 78 79 79 80 (apropos-list-test … … 132 133 ((|| . foobarvar1) . variable) 133 134 ((|| . foobarvar2) . variable) ) 134 (apropos-information-list 'foobar #:macros? #t ))135 (apropos-information-list 'foobar #:macros? #t #:internal? #t)) 135 136 (test "apropos-information-list" 136 137 '(((|| . foobarproc0) procedure) … … 139 140 ((|| . foobarprocn) procedure a b . r) 140 141 ((|| . 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)) ) ) 142 143 143 144 #| ;UNSUPPORTED … … 158 159 159 160 (test '(foobarprocx foobarvar2 foobarvar1 ##bar#foo1) 160 (apropos-list 'foo tstenv1 ))161 (apropos-list 'foo tstenv1 #:internal? #t)) 161 162 |# 162 163
Note: See TracChangeset
for help on using the changeset viewer.