Changeset 34862 in project


Ignore:
Timestamp:
11/05/17 20:28:44 (4 years ago)
Author:
Kon Lovett
Message:

strip idents of gensym contrib

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

Legend:

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

    r34756 r34862  
    6363    string-trim-both string-contains string-contains-ci)
    6464  (only irregex
    65     irregex irregex? irregex-search))
     65    sre->irregex
     66    irregex irregex?
     67    irregex-num-submatches
     68    irregex-search irregex-match
     69    irregex-match-data? irregex-match-num-submatches
     70    irregex-replace))
    6671(require-library
    6772  srfi-1
     
    635640      (cons (string->symbol (car nams)) (string->symbol (cadr nams))) ) ) )
    636641
     642;FIXME make patt a param ?
     643(define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast 'small))
     644(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast 'small))
     645
     646(define (irregex-submatches? mt ire)
     647  (and
     648    (irregex-match-data? mt)
     649    (fx= (irregex-match-num-submatches mt) (irregex-num-submatches ire)) ) )
     650
     651(define (canonical-identifier-name id)
     652  (let* (
     653    (pname (symbol->string id) )
     654    (mt (irregex-match *GENSYM_SRE* pname) ) )
     655    ;
     656    (if (irregex-submatches? mt *GENSYM_SRE*)
     657      (string->symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
     658      id ) ) )
     659
     660(define (canonicalize-identifier-names form)
     661  (cond
     662    ((symbol? form)
     663      (canonical-identifier-name form) )
     664    ((pair? form)
     665      (cons
     666        (canonicalize-identifier-names (car form))
     667        (canonicalize-identifier-names (cdr form))) )
     668    (else
     669      form ) ) )
     670
    637671; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
    638672(define (procedure-details proc)
     
    642676        'procedure )
    643677      ((pair? info)
    644         `(procedure . ,(cdr info)) )
     678        `(procedure . ,(canonicalize-identifier-names (cdr info))) )
    645679      (else
    646         `(procedure . ,(symbol->string info)) ) ) ) )
     680        ;was ,(symbol->string info) (? why)
     681        `(procedure . ,(canonical-identifier-name info)) ) ) ) )
    647682
    648683; => 'macro | 'keyword | 'variable | <procedure-details>
  • release/4/apropos/trunk/apropos.setup

    r34755 r34862  
    99  (exit 1) )
    1010
    11 (setup-shared-extension-module 'apropos (extension-version "2.4.1")
     11(setup-shared-extension-module 'apropos (extension-version "2.5.0")
    1212  #:types? #t
    1313  #:inline? #t
  • release/4/apropos/trunk/tests/apropos-test.scm

    r34847 r34862  
    7373  (test "apropos-information-list" (sort lst cdar-symbol<?) (sort val cdar-symbol<?)) )
    7474
    75 (apropos-information-list-test
    76   '(((|| . foobarmacro1) . macro)
    77     ((|| . foobarmacro2) . macro)
    78     ((|| . foobarproc0) procedure)
    79     ((|| . foobarproc1) procedure a)
    80     ((|| . foobarproc2) procedure a b)
    81     ((|| . foobarprocn) procedure a b . r)
    82     ((|| . foobarprocx) procedure a b c)
    83     ((|| . foobarvar1) . variable)
    84     ((|| . foobarvar2) . variable) )
    85   (apropos-information-list 'foobar #:macros? #t #:qualified? #t))
    86 (apropos-information-list-test
    87   '(((|| . foobarprocx) procedure a b c)
    88     ((|| . foobarprocn) procedure a b . r)
    89     ((|| . foobarproc2) procedure a b)
    90     ((|| . foobarproc1) procedure a)
    91     ((|| . foobarproc0) procedure))
    92   (apropos-information-list 'foobarproc #:macros? #t #:qualified? #t))
     75(cond-expand
     76  (compiling
     77    ;reads (|| . foobarmacro1) as ( . foobarmacro1) - whatever the car is i don't know
     78    )
     79  (else
     80    (apropos-information-list-test
     81      '(((|| . foobarmacro1) . macro)
     82        ((|| . foobarmacro2) . macro)
     83        ((|| . foobarproc0) procedure)
     84        ((|| . foobarproc1) procedure a)
     85        ((|| . foobarproc2) procedure a b)
     86        ((|| . foobarprocn) procedure a b . r)
     87        ((|| . foobarprocx) procedure a b c)
     88        ((|| . foobarvar1) . variable)
     89        ((|| . foobarvar2) . variable) )
     90      (apropos-information-list 'foobar #:macros? #t #:qualified? #t))
     91    (apropos-information-list-test
     92      '(((|| . foobarprocx) procedure a b c)
     93        ((|| . foobarprocn) procedure a b . r)
     94        ((|| . foobarproc2) procedure a b)
     95        ((|| . foobarproc1) procedure a)
     96        ((|| . foobarproc0) procedure))
     97      (apropos-information-list 'foobarproc #:macros? #t #:qualified? #t)) ) )
    9398
    9499#| ;UNSUPPORTED
  • release/4/apropos/trunk/tests/run.scm

    r34848 r34862  
    22;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    33
    4 (define *egg-name* "apropos")
     4(define *this-egg-name* "apropos")
    55
    66(use files)
     
    1111(define *args* (argv))
    1212
    13 (define (test-name #!optional (eggnam *egg-name*))
     13(define (test-name #!optional (eggnam *this-egg-name*))
    1414  (string-append eggnam "-test") )
    1515
    16 (define (egg-name #!optional (def *egg-name*))
     16(define (this-egg-name #!optional (def *this-egg-name*))
    1717  (cond
    1818    ((<= 4 (length *args*))
     
    2525;;;
    2626
    27 (set! *egg-name* (egg-name))
     27(set! *this-egg-name* (this-egg-name))
    2828
    29 (define (run-test #!optional (eggnam *egg-name*) (cscopts *csc-options*))
     29(define (run-test #!optional (eggnam *this-egg-name*) (cscopts *csc-options*))
    3030  (let ((tstnam (test-name eggnam)))
    3131    (print "*** csi ***")
Note: See TracChangeset for help on using the changeset viewer.