Changeset 34868 in project


Ignore:
Timestamp:
11/06/17 00:24:42 (4 years ago)
Author:
Kon Lovett
Message:

add interning switch

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

Legend:

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

    r34862 r34868  
    2727
    2828(;export
     29  ;
     30  apropos-interning
    2931  ;Original
    3032  apropos apropos-list apropos-information-list
     
    575577;;; Display
    576578
     579;;
     580
     581;procedure cache
     582(define *str->sym*)
     583
     584(define apropos-interning (make-parameter #t (lambda (x)
     585  (if (boolean? x)
     586    (begin
     587      (set! *str->sym* (if x string->symbol string->uninterned-symbol))
     588      x )
     589    (begin
     590      (warning 'apropos-interning "not a boolean: " x)
     591      (apropos-interning))))))
     592
     593(define-inline (string->display-symbol str)
     594  (*str->sym* str) )
     595
     596;;
     597
     598(define *TOPLEVEL-MODULE-SYMBOL* '||)
     599(define *TOPLEVEL-MODULE-STRING* (symbol->string *TOPLEVEL-MODULE-SYMBOL*))
     600
     601;;
     602
    577603#| ;A Work In Progress
    578604
     
    608634        sym )
    609635      (else
    610         (string->symbol (substring str 0 idx)) ) ) ) )
     636        (string->display-symbol (substring str 0 idx)) ) ) ) )
    611637
    612638; arg-lst-template is-a pair!
     
    625651|#
    626652
    627 (define *TOPLEVEL-MODULE-SYMBOL* '||)
    628 
    629 (define (symbol-with-module sym)
     653(define (identifier-components sym)
    630654  (if (qualified-symbol? sym)
    631655    (cons *TOPLEVEL-MODULE-SYMBOL* sym)
     
    635659      (nams
    636660        (if (null? (cdr nams))
    637           (cons (symbol->string *TOPLEVEL-MODULE-SYMBOL*) nams)
     661          (cons *TOPLEVEL-MODULE-STRING* nams)
    638662          nams ) ) )
    639663      ;
    640       (cons (string->symbol (car nams)) (string->symbol (cadr nams))) ) ) )
     664      (cons (string->display-symbol (car nams)) (string->display-symbol (cadr nams))) ) ) )
    641665
    642666;FIXME make patt a param ?
     
    644668(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast 'small))
    645669
    646 (define (irregex-submatches? mt ire)
     670(define (irregex-submatches? mt #!optional ire)
    647671  (and
    648672    (irregex-match-data? mt)
    649     (fx= (irregex-match-num-submatches mt) (irregex-num-submatches ire)) ) )
     673    (or
     674      (not ire)
     675      (fx=
     676        (irregex-match-num-submatches mt)
     677        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
    650678
    651679(define (canonical-identifier-name id)
     
    655683    ;
    656684    (if (irregex-submatches? mt *GENSYM_SRE*)
    657       (string->symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
     685      (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
    658686      id ) ) )
    659687
     
    682710
    683711; => 'macro | 'keyword | 'variable | <procedure-details>
    684 (define (type-details sym macenv)
     712(define (identifier-type-details sym #!optional macenv)
    685713  (cond
    686714    ((symbol-macro-in-environment? sym macenv)
     
    697725
    698726(define (make-information sym macenv)
    699   (cons (symbol-with-module sym) (type-details sym macenv)) )
     727  (cons (identifier-components sym) (identifier-type-details sym macenv)) )
    700728
    701729(define (*make-information-list syms macenv)
     
    10001028              (string-trim-both (read-line))
    10011029              read-file))))
    1002         ;
     1030        ;will not dump the symbol-table unless explicit ; '(: (* any))
    10031031        (unless (null? args)
    10041032          (apply apropos args) ) ) )
  • release/4/apropos/trunk/apropos.setup

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

    r34862 r34868  
    7373  (test "apropos-information-list" (sort lst cdar-symbol<?) (sort val cdar-symbol<?)) )
    7474
     75#; ;not using interned symbols anymore
    7576(cond-expand
    7677  (compiling
Note: See TracChangeset for help on using the changeset viewer.