Changeset 38625 in project for release


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

add imported (visible) vs oblist (defined), sort then uniq macro syms

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

Legend:

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

    r38624 r38625  
    3737(import (chicken sort))
    3838(import (chicken type))
    39 (import (only (srfi 1) any reverse! append! last-pair delete-duplicates!))
     39(import (only (srfi 1) any reverse! append! last-pair))
    4040(import (only (srfi 13)
    4141  string-index string-join string-trim-both
     
    5959
    6060;FIXME invalid compile-time value for named constant `KRL-OPTIONS'
    61 (define KRL-OPTIONS '(
    62   #:sort #:module #:case-insensitive? #t #:macros? #t))
     61(define KRL-OPTIONS '(#:sort #:module #:case-insensitive? #t #:macros? #t))
    6362
    6463(define *tab-width* 2)
     
    170169;;
    171170
    172 #; ;UNSUPPORTED
    173 (define (system-environment? obj)
    174   (or (##sys#environment? obj) (sys::macro-environment? obj)) )
     171;
     172(define (system-current-symbol? sym)
     173  ;must check full identifier name, so cdr
     174  (not (null? (search-list-environment-symbols (cut eq? sym <>) (system-current-environment) cdr))) )
    175175
    176176;; Environment Search
    177177
    178 (define (*apropos-list/macro-environment loc matcher macenv)
    179   (search-macro-environment-symbols matcher macenv) )
    180 
    181 (define (*apropos-list/environment loc matcher env)
    182   (search-system-environment-symbols
    183     (lambda (sym)
    184       (and
    185         (global-symbol-bound? sym)
    186         (matcher sym)))
    187     env) )
    188 
    189 ;;
     178(define (*apropos-list/macro-environment loc match? macenv)
     179  (search-macro-environment-symbols match? macenv) )
     180
     181(define (*apropos-list/environment loc match? env)
     182  (search-system-environment-symbols match? env) )
     183
     184;;
     185
     186(define (delete-duplicates!/sorted ols #!optional (eql? equal?))
     187  ;(assert (sorted? ols eql?))
     188  (let loop ((ls ols))
     189    (let ((nxt (and (not (null? ls)) (cdr ls))))
     190      (if (or (not nxt) (null? nxt))
     191        ols
     192        (if (eql? (car ls) (car nxt))
     193          (begin
     194            (set-cdr! ls (cdr nxt))
     195            (loop ls) )
     196          (loop nxt) ) ) ) ) )
    190197
    191198; => (envsyms . macenvsyms)
    192 (define (*apropos-list loc matcher env macenv)
     199(define (*apropos-list loc match/env? env match/macenv? macenv)
    193200  (append!
    194     (*apropos-list/environment loc matcher env)
     201    (*apropos-list/environment loc match/env? env)
    195202    (if macenv
    196203      ;FIXME why macro symbol dups?
    197       (delete-duplicates! (*apropos-list/macro-environment loc matcher macenv) eq?)
     204      (let ((syms (*apropos-list/macro-environment loc match/macenv? macenv)))
     205        (import (only (chicken sort) sort!))
     206        (delete-duplicates!/sorted (sort! syms symbol-printname<?) eq?) )
    198207      '())) )
    199208
     
    345354(define (parse-arguments-and-match loc patt iargs)
    346355  (let-values (
    347     ((env macenv case-insensitive? base raw? split internal?) (parse-rest-arguments loc iargs)))
     356    ((env macenv case-insensitive? base raw? split internal? imported?) (parse-rest-arguments loc iargs)))
     357    (when (and internal? imported?) (error loc "cannot be both internal & imported"))
    348358    (let* (
    349359      (patt (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern))
    350360      (force-regexp? #f)
    351       (matcher (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
    352       (als (*apropos-list loc matcher env macenv)) )
     361      (match? (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
     362      (include? (if imported? system-current-symbol? global-symbol-bound?))
     363      (als (*apropos-list loc (lambda (sym) (and (include? sym) (match? sym))) env match? macenv)) )
    353364      (values als macenv raw?) ) ) )
    354365;;
     
    365376    (split #f)
    366377    (base (apropos-default-base))
     378    (imported? #f)
    367379    (1st-arg? #t) )
    368380    ;
     
    370382      (if (null? args)
    371383        ;seen 'em all
    372         (values env macenv case-insensitive? base raw? split internal?)
     384        (values env macenv case-insensitive? base raw? split internal? imported?)
    373385        ;process potential arg
    374386        (let ((arg (car args)))
    375387          ;keyword argument?
    376388          (cond
     389            ;
     390            ((eq? #:imported? arg)
     391              (set! imported? (cadr args))
     392              (loop (cddr args)) )
    377393            ;
    378394            ((eq? #:split arg)
     
    668684
    669685(define (information-kind=? info1 info2)
    670   (symbol-printname=?
    671     (information-kind info1)
    672     (information-kind info2)) )
     686  (symbol-printname=? (information-kind info1) (information-kind info2)) )
    673687
    674688(define (information-kind<? info1 info2)
    675   (symbol-printname<?
    676     (information-kind info1)
    677     (information-kind info2)) )
     689  (symbol-printname<? (information-kind info1) (information-kind info2)) )
    678690
    679691(define (information<? info1 info2 #!optional (sort-key #:name))
     
    688700    (lessp
    689701      (case sort-key
    690         ((#:name #:module)
    691           (cut information-identifier<? <> <> sort-key) )
    692         ((#:type)
    693           (cut information<? <> <> #:name) )
    694         (else
    695           #f ) ) )
     702        ((#:name #:module)  (cut information-identifier<? <> <> sort-key))
     703        ((#:type)           information<?)
     704        (else               #f ) ) )
    696705    (ails
    697706      (*make-information-list syms macenv raw?) ) )
  • release/5/apropos/trunk/apropos-csi.scm

    r38527 r38625  
    8888                   Pattern match component; optional when last argument
    8989                   (also see the '(_ . _) pattern)
     90 imp | imported    Only imported identifiers, otherwise global symbols
    9091 all               Means `ci mac`
    9192 krl               Means `all sort mod`
     
    172173              (cons* #t #:case-insensitive? #t #:macros? oargs)))
    173174          ;
     175          ((imp imported)
     176            (arg-next #:imported? #t))
     177          ;
    174178          ((mac macros)
    175179            (arg-next #:macros? #t))
  • release/5/apropos/trunk/apropos.egg

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

    r38624 r38625  
    5757;;
    5858
    59 (: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
     59(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
    6060;
    61 (define (search-list-environment-symbols test? env)
    62   (define (cons-if-symbol syms cell) (cons-if test? (car cell) syms))
     61(define (search-list-environment-symbols test? env #!optional (itemref car))
     62  (define (cons-if-symbol syms cell) (cons-if test? (itemref cell) syms))
    6363  (foldl cons-if-symbol '() env) )
    6464
Note: See TracChangeset for help on using the changeset viewer.