Changeset 38628 in project for release

Timestamp:

04/18/20 16:14:31 (9 months ago)

Author:

Kon Lovett

Message:

add test groups, add imported test, remove redundant -local, add strict-types

Location:

release/5/apropos/trunk

Files:

• apropos-api.scm (modified) (3 diffs)
• apropos.egg (modified) (2 diffs)
• tests/apropos-test.scm (modified) (3 diffs)

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

@@ -176 +176 @@
 ;; Environment Search
 
-(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) )
-
 ;;
 
@@ -190 +184 @@
       (if (or (not nxt) (null? nxt))
         ols
-        (if (eql? (car ls) (car nxt))
+        (if (eql? ls nxt)
           (begin
             (set-cdr! ls (cdr nxt))
             (loop ls) )
           (loop nxt) ) ) ) ) )
+
+(define (*apropos-list/macro-environment loc match? macenv)
+  (import (only (chicken sort) sort!))
+  ;FIXME why macro symbol dups? (& they are dups - assq list w/ dups)
+  (delete-duplicates!/sorted
+    (sort! (search-macro-environment-symbols match? macenv) symbol-printname<?)
+    (lambda (a b) (eq? (car a) (car b)))) )
+
+(define (*apropos-list/environment loc match? env)
+  (search-system-environment-symbols match? env) )
 
 ; => (envsyms . macenvsyms)
@@ -201 +205 @@
     (*apropos-list/environment loc match/env? env)
     (if macenv
-      ;FIXME why macro symbol dups?
-      (let ((syms (*apropos-list/macro-environment loc match/macenv? macenv)))
-        (import (only (chicken sort) sort!))
-        (delete-duplicates!/sorted (sort! syms symbol-printname<?) eq?) )
+      (*apropos-list/macro-environment loc match/macenv? macenv)
       '())) )
 

release/5/apropos/trunk/apropos.egg

@@ -5 +5 @@
 
 ((synopsis "CHICKEN apropos")
- (version "3.5.0")
+ (version "3.5.1")
  (category misc)
  (author "[[kon lovett]]")
@@ -19 +19 @@
   (extension symbol-table-access
     (types-file)
-    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
   (extension symbol-access
     (types-file)
-    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
   (extension symbol-environment-access
     (types-file)
     (component-dependencies symbol-table-access)
-    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
   (extension apropos-api
     (types-file)
     (component-dependencies symbol-access symbol-environment-access)
-    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
   (extension apropos-csi
     (types-file)
     (component-dependencies apropos-api)
-    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
   (extension apropos
     (types-file)
     (component-dependencies apropos-csi apropos-api)
-    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") ) ) )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") ) ) )

release/5/apropos/trunk/tests/apropos-test.scm

@@ -18 +18 @@
 (define (cdar-symbol<? a b) (symbol<? (cdar a) (cdar b)))
 
-;;;
+(define-syntax *apropos-list-test
+  (syntax-rules ()
+    ((apropos-list-test ?msg ?lst ?val ?less?)
+      (test ?msg (sort ?lst ?less?) (sort ?val ?less?)) ) ) )
+
+(define-syntax apropos-list-test
+  (syntax-rules ()
+    ;
+    ((apropos-list-test ?lst ?val)
+      (apropos-list-test "apropos-list" ?lst ?val) )
+    ;
+    ((apropos-list-test ?msg ?lst ?val)
+      (*apropos-list-test ?msg ?lst ?val symbol<?) ) ) )
+
+(define-syntax apropos-information-list-test
+  (syntax-rules ()
+    ;
+    ((apropos-information-list-test ?lst ?val)
+      (apropos-information-list-test "apropos-information-list" ?lst ?val) )
+    ;
+    ((apropos-information-list-test ?msg ?lst ?val)
+      (*apropos-list-test ?msg ?lst ?val cdar-symbol<?) ) ) )
+
+;;
+
+(test-group "Imported"
+  (cond-expand
+    (csi
+      ;tests wildcard module but restricts to just imported
+      (apropos-list-test "test w/ imported?: #t"
+        '(test#current-test-group test#test-exit test#test-run
+        test#current-test-applier test#current-test-handler
+        test#current-test-verbosity test#test-total-count test#test-group-inc!
+        test#current-test-epsilon test#current-test-group-reporter
+        test#test-failure-count test#test-end test#current-test-skipper
+        test#test-begin test#current-test-comparator)
+        ;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
+        ;must be quoted
+        (apropos-list ''(_ . test) #:imported? #t)) )
+    (else
+      ;(almost) nothing imported so specify module & check the oblist
+      (apropos-list-test "test w/ specific module"
+        '(test#current-test-group test#test-exit test#test-run
+        test#current-test-applier test#current-test-handler
+        test#current-test-verbosity test#test-total-count test#test-group-inc!
+        test#current-test-epsilon test#current-test-group-reporter
+        test#test-failure-count test#test-end test#current-test-skipper
+        test#test-begin test#current-test-comparator)
+        ;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
+        ;must be quoted
+        (apropos-list ''(test . test))) ) )
+)
 
 ;; build test symbols
@@ -58 +109 @@
 ;; test for symbols
 
-(define (apropos-list-test lst val)
-  (test "apropos-list" (sort lst symbol<?) (sort val symbol<?)) )
-
-(apropos-list-test
-  '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
-  (apropos-list 'foobar))
-
-(apropos-list-test
-  '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
-  (apropos-list "foobar"))
-
-(apropos-list-test
-  '(##bar#foo1 ##bar#foo2 foobarmacro1 foobarmacro2 foobarproc0 foobarproc1 foobarproc2 foobarprocn foobarprocx foobarvar1 foobarvar2)
-  (apropos-list 'foo #:macros? #t #:internal? #t #:split #:name))
-
-(apropos-list-test
-  '(##foo#bar1 ##foo#bar2)
-  (apropos-list 'foo #:macros? #t #:internal? #t #:split #:module))
-
-(apropos-list-test
-  '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 foobarmacro1 foobarmacro2)
-  (apropos-list 'foobar #:macros? #t))
-
-(apropos-list-test
-  '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 Foobarvar2 Foobarvar1)
-  (apropos-list 'foobar #:case-insensitive? #t))
-
-(apropos-list-test
-  '(foobarvar2 foobarvar1 Foobarvar1 Foobarvar2)
-  (apropos-list ''".+barvar[12]"))
-
-;;
-
-(define (apropos-information-list-test lst val)
-  (test "apropos-information-list" (sort lst cdar-symbol<?) (sort val cdar-symbol<?)) )
+(test-group "Symbol List"
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
+    (apropos-list 'foobar))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
+    (apropos-list "foobar"))
+
+  (apropos-list-test
+    '(##bar#foo1 ##bar#foo2 foobarmacro1 foobarmacro2 foobarproc0 foobarproc1 foobarproc2 foobarprocn foobarprocx foobarvar1 foobarvar2)
+    (apropos-list 'foo #:macros? #t #:internal? #t #:split #:name))
+
+  (apropos-list-test
+    '(##foo#bar1 ##foo#bar2)
+    (apropos-list 'foo #:macros? #t #:internal? #t #:split #:module))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 foobarmacro1 foobarmacro2)
+    (apropos-list 'foobar #:macros? #t))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 Foobarvar2 Foobarvar1)
+    (apropos-list 'foobar #:case-insensitive? #t))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 Foobarvar1 Foobarvar2)
+    (apropos-list ''".+barvar[12]"))
+)
+
+;;
 
 #|
@@ -117 +165 @@
 ;oh , my - #:|| from reader is not eq? #:|| from symbol-table
 
-(apropos-information-list-test
-  '(
-    ((|| . foobarmacro1) . macro)
-    ((|| . foobarmacro2) . macro)
-    ((|| . foobarproc0) procedure)
-    ((|| . foobarproc1) procedure a)
-    ((|| . foobarproc2) procedure a b)
-    ((|| . foobarprocn) procedure a b . r)
-    ((|| . foobarprocx) procedure a b c)
-    ((|| . foobarvar1) . variable)
-    ((|| . foobarvar2) . variable) )
-  (apropos-information-list 'foobar #:macros? #t #:internal? #t))
-(test "apropos-information-list"
-  '(((|| . foobarproc0) procedure)
-    ((|| . foobarproc1) procedure a)
-    ((|| . foobarproc2) procedure a b)
-    ((|| . foobarprocn) procedure a b . r)
-    ((|| . foobarprocx) procedure a b c))
-  (apropos-information-list 'foobarproc #:macros? #t #:internal? #t #:sort #:module))
+(test-group "Information List"
+  (apropos-information-list-test
+    '(
+      ((|| . foobarmacro1) . macro)
+      ((|| . foobarmacro2) . macro)
+      ((|| . foobarproc0) procedure)
+      ((|| . foobarproc1) procedure a)
+      ((|| . foobarproc2) procedure a b)
+      ((|| . foobarprocn) procedure a b . r)
+      ((|| . foobarprocx) procedure a b c)
+      ((|| . foobarvar1) . variable)
+      ((|| . foobarvar2) . variable) )
+    (apropos-information-list 'foobar #:macros? #t #:internal? #t))
+
+  (test "apropos-information-list"
+    '(((|| . foobarproc0) procedure)
+      ((|| . foobarproc1) procedure a)
+      ((|| . foobarproc2) procedure a b)
+      ((|| . foobarprocn) procedure a b . r)
+      ((|| . foobarprocx) procedure a b c))
+    (apropos-information-list 'foobarproc #:macros? #t #:internal? #t #:sort #:module))
+)
 
 #| ;UNSUPPORTED