Changeset 38624 in project for release


Ignore:
Timestamp:
04/17/20 05:23:06 (4 months ago)
Author:
Kon Lovett
Message:

better lolevel symenv access types, dedup macro syms (?)

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

Legend:

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

    r38256 r38624  
    3737(import (chicken sort))
    3838(import (chicken type))
    39 (import (only (srfi 1) any reverse! append! last-pair))
     39(import (only (srfi 1) any reverse! append! last-pair delete-duplicates!))
    4040(import (only (srfi 13)
    4141  string-index string-join string-trim-both
     
    5858;;
    5959
     60;FIXME invalid compile-time value for named constant `KRL-OPTIONS'
     61(define KRL-OPTIONS '(
     62  #:sort #:module #:case-insensitive? #t #:macros? #t))
     63
    6064(define *tab-width* 2)
    6165
     
    140144
    141145(define (number-base? obj)
    142   (and (fixnum? obj) (<= 2 obj) (<= obj CHICKEN-MAXIMUM-BASE)) )
     146  (and (exact? obj) (integer? obj) (<= 2 obj CHICKEN-MAXIMUM-BASE)) )
    143147
    144148(define *number-base-error-message*
     
    173177
    174178(define (*apropos-list/macro-environment loc matcher macenv)
    175   (search-macro-environment-symbols macenv matcher) )
     179  (search-macro-environment-symbols matcher macenv) )
    176180
    177181(define (*apropos-list/environment loc matcher env)
    178   (search-system-environment-symbols env
     182  (search-system-environment-symbols
    179183    (lambda (sym)
    180184      (and
    181185        (global-symbol-bound? sym)
    182         (matcher sym)))) )
     186        (matcher sym)))
     187    env) )
    183188
    184189;;
     
    186191; => (envsyms . macenvsyms)
    187192(define (*apropos-list loc matcher env macenv)
    188   (append
     193  (append!
    189194    (*apropos-list/environment loc matcher env)
    190195    (if macenv
    191       (*apropos-list/macro-environment loc matcher macenv)
     196      ;FIXME why macro symbol dups?
     197      (delete-duplicates! (*apropos-list/macro-environment loc matcher macenv) eq?)
    192198      '())) )
    193199
     
    208214(define (make-apropos-matcher loc patt
    209215            #!optional
    210               (case-insensitive? #f)
    211               (split #f)
    212               (force-regexp? #f)
    213               (internal? #f))
     216            (case-insensitive? #f)
     217            (split #f)
     218            (force-regexp? #f)
     219            (internal? #f))
    214220  ;
    215221  ;(define excluded (apropos-excluded))
     
    335341;
    336342;=> (values apropos-ls macenv)
     343
    337344;
    338345(define (parse-arguments-and-match loc patt iargs)
     
    351358(define (parse-rest-arguments loc iargs)
    352359  (let (
    353     (env #f)        ;(default-environment)
     360    (env #f)        ;(default-environment) ;just the macros but looks ok in repl?
    354361    (macenv #f)
    355362    (internal? #f)
     
    382389            ;
    383390            ((eq? #:base arg)
    384               (when (cadr args)
    385                 (set! base (check-apropos-number-base loc (cadr args))) )
     391              (when (cadr args) (set! base (check-apropos-number-base loc (cadr args))))
    386392              (loop (cddr args)) )
    387393            ;
    388394            ((eq? #:macros? arg)
    389395              ;only flag supported
    390               (when (cadr args)
    391                 (set! macenv (default-macro-environment)) )
     396              (when (cadr args) (set! macenv (default-macro-environment)))
    392397              (loop (cddr args)) )
    393398            ;
     
    396401              (loop (cddr args)) )
    397402            ;environment argument?
    398             (1st-arg?
    399               ;FIXME need real 'environment?' predicate
    400               (unless (list? arg)
    401                 (error-argument loc arg) )
     403            ;FIXME need real 'environment?' predicate
     404            ((and 1st-arg? (list? arg))
    402405              (set! 1st-arg? #f)
    403406              (set! env arg)
     
    603606(define (identifier-type-details sym #!optional macenv raw?)
    604607  (cond
    605     ((macro-symbol-in-environment? sym macenv)
     608    ((and sym macenv (macro-symbol-in-environment? sym macenv))
    606609      'macro )
    607610    ((keyword? sym)
     
    749752;;; API
    750753
    751 ;FIXME invalid compile-time value for named constant `KRL-OPTIONS'
    752 (define KRL-OPTIONS '(
    753   #:sort #:module #:case-insensitive? #t #:macros? #t))
    754 
    755754(define apropos-default-options (make-parameter '() (lambda (x)
    756755  (cond
  • release/5/apropos/trunk/apropos.egg

    r38405 r38624  
    55
    66((synopsis "CHICKEN apropos")
    7  (version "3.4.0")
     7 (version "3.4.1")
    88 (category misc)
    99 (author "[[kon lovett]]")
  • release/5/apropos/trunk/symbol-environment-access.scm

    r38256 r38624  
    4141;;
    4242
     43(: system-current-environment ( -> list))
     44;
    4345(define system-current-environment ##sys#current-environment)
    4446
     47(: system-macro-environment ( -> list))
     48;
    4549(define system-macro-environment ##sys#macro-environment)
    4650
    4751;;
    4852
    49 (: macro-symbol-in-environment? ((or boolean symbol) (or boolean macro-environment) -> boolean))
     53(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
    5054;
    51 (define (macro-symbol-in-environment? sym macenv)
    52   (and sym macenv (##sys#macro? sym macenv)) )
     55(define macro-symbol-in-environment? ##sys#macro?)
    5356
    5457;;
    5558
    56 (: search-list-environment-symbols (list procedure --> list))
     59(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
    5760;
    58 (define (search-list-environment-symbols env test?)
     61(define (search-list-environment-symbols test? env)
    5962  (define (cons-if-symbol syms cell) (cons-if test? (car cell) syms))
    6063  (foldl cons-if-symbol '() env) )
    6164
    62 (: search-interaction-environment-symbols (* procedure --> list))
     65(: search-interaction-environment-symbols ((* -> boolean) -> list))
    6366;
    64 (define (search-interaction-environment-symbols env test?)
     67(define (search-interaction-environment-symbols test?)
    6568  (let loop ((cursor (cursor-first)) (syms '()))
    6669    (let ((sym (cursor-current cursor)))
     
    7174;;
    7275
    73 (: search-macro-environment-symbols (list procedure --> list))
     76(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
    7477;
    75 (define (search-macro-environment-symbols env test?)
    76   (search-list-environment-symbols env test?) )
     78(define (search-macro-environment-symbols test? env)
     79  (search-list-environment-symbols test? env) )
    7780
    78 (: search-system-environment-symbols (list procedure --> list))
     81(: search-system-environment-symbols ((* -> boolean) (or (list-of (pair symbol *)) boolean) -> list))
    7982;
    80 (define (search-system-environment-symbols env test?)
    81   (if env
    82     (search-list-environment-symbols env test?)
    83     (search-interaction-environment-symbols env test?) ) )
     83(define (search-system-environment-symbols test? #!optional env)
     84  (if (list? env)
     85    (search-list-environment-symbols test? env)
     86    (search-interaction-environment-symbols test?) ) )
    8487
    8588) ;module symbol-environment-access
Note: See TracChangeset for help on using the changeset viewer.