Changeset 36298 in project


Ignore:
Timestamp:
08/16/18 21:38:13 (12 months ago)
Author:
Kon Lovett
Message:

more own mods

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

Legend:

Unmodified
Added
Removed
  • release/5/apropos/trunk/apropos-api.scm

    r36254 r36298  
    66
    77;; Issues
    8 ;;
    9 ;; - too much padding (+2) when no module names in list
    10 ;;
     8;;;
    119;; - Use of 'global-symbol' routines is just wrong when an
    1210;; evaluation-environment (##sys#environment?) is not the
     
    2220;; for any syntactic keywords from the R5RS. The public API of 'apropos'
    2321;; attempts to hide this fact.
    24 
    25 (declare
    26   (bound-to-procedure
    27     ##sys#symbol-has-toplevel-binding?
    28     ##sys#macro-environment
    29     ##sys#current-environment
    30     ##sys#macro?))
    3122
    3223(module apropos-api
     
    3627  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
    3728  apropos-default-base apropos-interning apropos-default-options
     29  ;
    3830  apropos apropos-list apropos-information-list)
    3931
     
    5042    string-join
    5143    string-trim-both
    52     string-contains string-contains-ci
    53     string-drop string-take string-index)
     44    string-contains string-contains-ci)
    5445  (only (chicken irregex)
    5546    sre->irregex
     
    6758  (only type-checks check-fixnum define-check+error-type)
    6859  (only type-errors define-error-type error-argument-type)
    69   symbol-table-access)
     60  symbol-environment-access
     61  symbol-access)
    7062
    7163;;; Support
     
    8072;for our purposes
    8173(define-constant CHICKEN-MAXIMUM-BASE 16)
    82 
    83 ;; Raw Access Renames
    84 
    85 (define system-current-environment ##sys#current-environment)
    86 
    87 (define system-macro-environment ##sys#macro-environment)
    88 
    89 (define (global-symbol-bound? sym)
    90   (##sys#symbol-has-toplevel-binding? sym) )
    91 
    92 (define (global-symbol-ref sym)
    93   (##sys#slot sym 0) )
    94 
    95 (define (symbol-macro-in-environment? sym macenv)
    96   (and sym macenv (##sys#macro? sym macenv)) )
    9774
    9875;; irregex extensions
     
    10784        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
    10885
     86;; String
     87
     88(define (string-match? str patt)
     89  (irregex-search patt str) )
     90
     91(define (string-exact-match? str patt)
     92  (string-contains str patt) )
     93
     94(define (string-ci-match? str patt)
     95  (string-contains-ci str patt) )
     96
     97;; Symbols
     98
     99(define (symbol-match? sym patt)
     100  (string-match? (symbol->string sym) patt) )
     101
     102(define (symbol-exact-match? sym patt)
     103  (string-exact-match? (symbol->string sym) patt) )
     104
     105(define (symbol-ci-match? sym patt)
     106  (string-ci-match? (symbol->string sym) patt) )
     107
    109108;; Types
    110109
     
    173172    (else
    174173      (error-argument-type loc obj *number-base-error-message* var)) ) )
    175 
    176 ;; Symbols
    177 
    178 (define (string-irregex-match? str patt)
    179   (irregex-search patt str) )
    180 
    181 (define (string-exact-match? str patt)
    182   (string-contains str patt) )
    183 
    184 (define (string-ci-match? str patt)
    185   (string-contains-ci str patt) )
    186 
    187 (define (symbol-irregex-match? sym patt)
    188   (string-irregex-match? (symbol->string sym) patt) )
    189 
    190 (define (symbol-exact-match? sym patt)
    191   (string-exact-match? (symbol->string sym) patt) )
    192 
    193 (define (symbol-ci-match? sym patt)
    194   (string-ci-match? (symbol->string sym) patt) )
    195 
    196 (define TOPLEVEL-MODULE-SYMBOL '||)
    197 (define TOPLEVEL-MODULE-STRING "" #;(symbol->string TOPLEVEL-MODULE-SYMBOL))
    198 
    199 (: split-prefixed-symbol (symbol --> string string))
    200 ;
    201 (define (split-prefixed-symbol sym)
    202   (let* (
    203     (str (symbol->string sym))
    204     ;assume # not part of module name
    205     (idx (string-index str #\#))
    206     (mod (if idx (string-take str idx) TOPLEVEL-MODULE-STRING))
    207     (nam (if idx (string-drop str (fx+ 1 idx)) str)) )
    208     ;
    209     (values mod nam) ) )
    210 
    211 ;; Environments
    212 
    213 (: search-interaction-environment-symbols (* procedure --> list))
    214 ;
    215 (define (search-interaction-environment-symbols env optarg?)
    216   (let loop ((cursor (cursor-first)) (syms '()))
    217     (let ((sym (cursor-current cursor)))
    218       (if (not sym)
    219         syms
    220         (let ((syms (if (optarg? sym) (cons sym syms) syms)))
    221           (loop (cursor-next cursor) syms) ) ) ) ) )
    222 
    223 (: search-list-environment-symbols (list procedure --> list))
    224 ;
    225 (define (search-list-environment-symbols env optarg?)
    226   (foldl
    227     (lambda (syms cell)
    228       (let ((sym (car cell)))
    229         (if (optarg? sym)
    230           (cons sym syms)
    231           syms ) ) )
    232     '()
    233     env) )
    234 
    235 (: search-macro-environment-symbols (list procedure --> list))
    236 ;
    237 (define (search-macro-environment-symbols env optarg?)
    238   (search-list-environment-symbols env optarg?) )
    239 
    240 (: search-system-environment-symbols (list procedure --> list))
    241 ;
    242 (define (search-system-environment-symbols env optarg?)
    243   (if env
    244     (search-list-environment-symbols env optarg?)
    245     (search-interaction-environment-symbols env optarg?) ) )
    246174
    247175;;
     
    317245          (let-values (
    318246            ((mod nam) (split-prefixed-symbol sym)) )
    319             (string-irregex-match? mod irx) ) ) )
     247            (string-match? mod irx) ) ) )
    320248      ((eq? #:name split)
    321249        (lambda (sym)
    322250          (let-values (
    323251            ((mod nam) (split-prefixed-symbol sym)) )
    324             (string-irregex-match? nam irx) ) ) )
     252            (string-match? nam irx) ) ) )
    325253      ((not split)
    326         (cut symbol-irregex-match? <> irx) ) ) )
     254        (cut symbol-match? <> irx) ) ) )
    327255  ;
    328256  (define (gen-string-matcher str)
     
    592520;;
    593521
    594 ;;
    595 
    596522#| ;A Work In Progress
    597523
     
    647573  (cond
    648574    (raw?
    649       (cons TOPLEVEL-MODULE-SYMBOL sym) )
     575      (cons *toplevel-module-symbol* sym) )
    650576    ((qualified-symbol? sym)
    651       (cons TOPLEVEL-MODULE-SYMBOL sym) )
     577      (cons *toplevel-module-symbol* sym) )
    652578    (else
    653579      (let-values (
     
    698624(define (identifier-type-details sym #!optional macenv raw?)
    699625  (cond
    700     ((symbol-macro-in-environment? sym macenv)
     626    ((macro-symbol-in-environment? sym macenv)
    701627      'macro )
    702628    ((keyword? sym)
     
    823749        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
    824750        ;
    825         (if (eq? TOPLEVEL-MODULE-SYMBOL mod)
     751        (if (eq? *toplevel-module-symbol* mod)
    826752          (display (make-string+ (fx+ 2 mod-padlen)))
    827753          (begin
  • release/5/apropos/trunk/apropos-csi.scm

    r36149 r36298  
    3535(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
    3636  (let ((rem (fx- n (string-length x))))
    37     (if (positive? rem)
     37    (define (shorter?) (positive? rem))
     38    (if (shorter?)
    3839      (string-append x (make-string rem pad))
    3940      (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
  • release/5/apropos/trunk/apropos.egg

    r36254 r36298  
    33
    44((synopsis "Chicken apropos")
    5  (version "3.2.1")
     5 (version "3.3.0")
    66 (category misc)
    77 (author "[[kon lovett]]")
     
    1919    (types-file)
    2020    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     21  (extension symbol-access
     22    #;(inline-file)
     23    (types-file)
     24    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     25  (extension symbol-environment-access
     26    #;(inline-file)
     27    (types-file)
     28    (component-dependencies symbol-table-access)
     29    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    2130  (extension apropos-api
    2231    #;(inline-file)
    2332    (types-file)
    24     (component-dependencies symbol-table-access)
     33    (component-dependencies symbol-access symbol-environment-access)
    2534    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    2635  (extension apropos-csi
Note: See TracChangeset for help on using the changeset viewer.