Changeset 38625 in project for release

Timestamp:

04/17/20 23:12:25 (10 months ago)

Author:

Kon Lovett

Message:

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

Location:

release/5/apropos/trunk

Files:

• apropos-api.scm (modified) (8 diffs)
• apropos-csi.scm (modified) (2 diffs)
• apropos.egg (modified) (1 diff)
• symbol-environment-access.scm (modified) (1 diff)

release/5/apropos/trunk/apropos-api.scm

@@ -37 +37 @@
 (import (chicken sort))
 (import (chicken type))
-(import (only (srfi 1) any reverse! append! last-pair delete-duplicates!))
+(import (only (srfi 1) any reverse! append! last-pair))
 (import (only (srfi 13)
   string-index string-join string-trim-both
@@ -59 +59 @@
 
 ;FIXME invalid compile-time value for named constant `KRL-OPTIONS'
-(define KRL-OPTIONS '(
-  #:sort #:module #:case-insensitive? #t #:macros? #t))
+(define KRL-OPTIONS '(#:sort #:module #:case-insensitive? #t #:macros? #t))
 
 (define *tab-width* 2)
@@ -170 +169 @@
 ;;
 
-#; ;UNSUPPORTED
-(define (system-environment? obj)
-  (or (##sys#environment? obj) (sys::macro-environment? obj)) )
+;
+(define (system-current-symbol? sym)
+  ;must check full identifier name, so cdr
+  (not (null? (search-list-environment-symbols (cut eq? sym <>) (system-current-environment) cdr))) )
 
 ;; Environment Search
 
-(define (*apropos-list/macro-environment loc matcher macenv)
-  (search-macro-environment-symbols matcher macenv) )
-
-(define (*apropos-list/environment loc matcher env)
-  (search-system-environment-symbols
-    (lambda (sym)
-      (and
-        (global-symbol-bound? sym)
-        (matcher sym)))
-    env) )
-
-;;
+(define (*apropos-list/macro-environment loc match? macenv)
+  (search-macro-environment-symbols match? macenv) )
+
+(define (*apropos-list/environment loc match? env)
+  (search-system-environment-symbols match? env) )
+
+;;
+
+(define (delete-duplicates!/sorted ols #!optional (eql? equal?))
+  ;(assert (sorted? ols eql?))
+  (let loop ((ls ols))
+    (let ((nxt (and (not (null? ls)) (cdr ls))))
+      (if (or (not nxt) (null? nxt))
+        ols
+        (if (eql? (car ls) (car nxt))
+          (begin
+            (set-cdr! ls (cdr nxt))
+            (loop ls) )
+          (loop nxt) ) ) ) ) )
 
 ; => (envsyms . macenvsyms)
-(define (*apropos-list loc matcher env macenv)
+(define (*apropos-list loc match/env? env match/macenv? macenv)
   (append!
-    (*apropos-list/environment loc matcher env)
+    (*apropos-list/environment loc match/env? env)
     (if macenv
       ;FIXME why macro symbol dups?
-      (delete-duplicates! (*apropos-list/macro-environment loc matcher macenv) eq?)
+      (let ((syms (*apropos-list/macro-environment loc match/macenv? macenv)))
+        (import (only (chicken sort) sort!))
+        (delete-duplicates!/sorted (sort! syms symbol-printname<?) eq?) )
       '())) )
 
@@ -345 +354 @@
 (define (parse-arguments-and-match loc patt iargs)
   (let-values (
-    ((env macenv case-insensitive? base raw? split internal?) (parse-rest-arguments loc iargs)))
+    ((env macenv case-insensitive? base raw? split internal? imported?) (parse-rest-arguments loc iargs)))
+    (when (and internal? imported?) (error loc "cannot be both internal & imported"))
     (let* (
       (patt (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern))
       (force-regexp? #f)
-      (matcher (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
-      (als (*apropos-list loc matcher env macenv)) )
+      (match? (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
+      (include? (if imported? system-current-symbol? global-symbol-bound?))
+      (als (*apropos-list loc (lambda (sym) (and (include? sym) (match? sym))) env match? macenv)) )
       (values als macenv raw?) ) ) )
 ;;
@@ -365 +376 @@
     (split #f)
     (base (apropos-default-base))
+    (imported? #f)
     (1st-arg? #t) )
     ;
@@ -370 +382 @@
       (if (null? args)
         ;seen 'em all
-        (values env macenv case-insensitive? base raw? split internal?)
+        (values env macenv case-insensitive? base raw? split internal? imported?)
         ;process potential arg
         (let ((arg (car args)))
           ;keyword argument?
           (cond
+            ;
+            ((eq? #:imported? arg)
+              (set! imported? (cadr args))
+              (loop (cddr args)) )
             ;
             ((eq? #:split arg)
@@ -668 +684 @@
 
 (define (information-kind=? info1 info2)
-  (symbol-printname=?
-    (information-kind info1)
-    (information-kind info2)) )
+  (symbol-printname=? (information-kind info1) (information-kind info2)) )
 
 (define (information-kind<? info1 info2)
-  (symbol-printname<?
-    (information-kind info1)
-    (information-kind info2)) )
+  (symbol-printname<? (information-kind info1) (information-kind info2)) )
 
 (define (information<? info1 info2 #!optional (sort-key #:name))
@@ -688 +700 @@
     (lessp
       (case sort-key
-        ((#:name #:module)
-          (cut information-identifier<? <> <> sort-key) )
-        ((#:type)
-          (cut information<? <> <> #:name) )
-        (else
-          #f ) ) )
+        ((#:name #:module)  (cut information-identifier<? <> <> sort-key))
+        ((#:type)           information<?)
+        (else               #f ) ) )
     (ails
       (*make-information-list syms macenv raw?) ) )

release/5/apropos/trunk/apropos-csi.scm

@@ -88 +88 @@
                    Pattern match component; optional when last argument
                    (also see the '(_ . _) pattern)
+ imp | imported    Only imported identifiers, otherwise global symbols
  all               Means `ci mac`
  krl               Means `all sort mod`
@@ -172 +173 @@
               (cons* #t #:case-insensitive? #t #:macros? oargs)))
           ;
+          ((imp imported)
+            (arg-next #:imported? #t))
+          ;
           ((mac macros)
             (arg-next #:macros? #t))

release/5/apropos/trunk/apropos.egg

@@ -5 +5 @@
 
 ((synopsis "CHICKEN apropos")
- (version "3.4.1")
+ (version "3.5.0")
  (category misc)
  (author "[[kon lovett]]")

release/5/apropos/trunk/symbol-environment-access.scm

@@ -57 +57 @@
 ;;
 
-(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
+(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
 ;
-(define (search-list-environment-symbols test? env)
-  (define (cons-if-symbol syms cell) (cons-if test? (car cell) syms))
+(define (search-list-environment-symbols test? env #!optional (itemref car))
+  (define (cons-if-symbol syms cell) (cons-if test? (itemref cell) syms))
   (foldl cons-if-symbol '() env) )