source: project/release/5/apropos/trunk/tests/apropos-test.scm @ 38628

Last change on this file since 38628 was 38628, checked in by Kon Lovett, 6 months ago

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

File size: 6.4 KB
Line 
1;;;; apropos-test.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(import test)
5
6(test-begin "Apropos")
7
8;;;
9
10(import (chicken syntax))
11(import (chicken sort))
12(import apropos-api)
13
14;;
15
16(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))
17(define (car-symbol<? a b) (symbol<? (car a) (car b)))
18(define (cdar-symbol<? a b) (symbol<? (cdar a) (cdar b)))
19
20(define-syntax *apropos-list-test
21  (syntax-rules ()
22    ((apropos-list-test ?msg ?lst ?val ?less?)
23      (test ?msg (sort ?lst ?less?) (sort ?val ?less?)) ) ) )
24
25(define-syntax apropos-list-test
26  (syntax-rules ()
27    ;
28    ((apropos-list-test ?lst ?val)
29      (apropos-list-test "apropos-list" ?lst ?val) )
30    ;
31    ((apropos-list-test ?msg ?lst ?val)
32      (*apropos-list-test ?msg ?lst ?val symbol<?) ) ) )
33
34(define-syntax apropos-information-list-test
35  (syntax-rules ()
36    ;
37    ((apropos-information-list-test ?lst ?val)
38      (apropos-information-list-test "apropos-information-list" ?lst ?val) )
39    ;
40    ((apropos-information-list-test ?msg ?lst ?val)
41      (*apropos-list-test ?msg ?lst ?val cdar-symbol<?) ) ) )
42
43;;
44
45(test-group "Imported"
46  (cond-expand
47    (csi
48      ;tests wildcard module but restricts to just imported
49      (apropos-list-test "test w/ imported?: #t"
50        '(test#current-test-group test#test-exit test#test-run
51        test#current-test-applier test#current-test-handler
52        test#current-test-verbosity test#test-total-count test#test-group-inc!
53        test#current-test-epsilon test#current-test-group-reporter
54        test#test-failure-count test#test-end test#current-test-skipper
55        test#test-begin test#current-test-comparator)
56        ;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
57        ;must be quoted
58        (apropos-list ''(_ . test) #:imported? #t)) )
59    (else
60      ;(almost) nothing imported so specify module & check the oblist
61      (apropos-list-test "test w/ specific module"
62        '(test#current-test-group test#test-exit test#test-run
63        test#current-test-applier test#current-test-handler
64        test#current-test-verbosity test#test-total-count test#test-group-inc!
65        test#current-test-epsilon test#current-test-group-reporter
66        test#test-failure-count test#test-end test#current-test-skipper
67        test#test-begin test#current-test-comparator)
68        ;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
69        ;must be quoted
70        (apropos-list ''(test . test))) ) )
71)
72
73;; build test symbols
74
75(define (foobarproc0) 'foobarproc0)
76(define (foobarproc1 a) 'foobarproc1)
77(define (foobarproc2 a b) 'foobarproc2)
78(define (foobarprocn a b . r) 'foobarprocn)
79
80(define foobarprocx (lambda (a b c) 'foobarprocx))
81
82;RQRD due to use of macro identifiers
83(declare (compile-syntax))
84
85(define-syntax foobarmacro1
86  (er-macro-transformer
87    (lambda (f r c)
88      'foobarmacro1 ) ) )
89
90(define-syntax foobarmacro2
91  (syntax-rules ()
92    ((_) 'foobarmacro1 ) ) )
93
94(define foobarvar1 'foobarvar1)
95(define foobarvar2 'foobarvar2)
96
97(define Foobarvar1 'Foobarvar1)
98(define Foobarvar2 'Foobarvar2)
99
100#;(define (foocoreinline flag) (##core#inline "C_set_gc_report" flag))
101#;(define fooprimitive (##core#primitive "C_get_memory_info"))
102
103(define ##foo#bar1 '##foo#bar1)
104(define ##foo#bar2 (lambda () '##foo#bar2))
105
106(define ##bar#foo1 '##bar#foo1)
107(define ##bar#foo2 (lambda () '##bar#foo2))
108
109;; test for symbols
110
111(test-group "Symbol List"
112
113  (apropos-list-test
114    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
115    (apropos-list 'foobar))
116
117  (apropos-list-test
118    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
119    (apropos-list "foobar"))
120
121  (apropos-list-test
122    '(##bar#foo1 ##bar#foo2 foobarmacro1 foobarmacro2 foobarproc0 foobarproc1 foobarproc2 foobarprocn foobarprocx foobarvar1 foobarvar2)
123    (apropos-list 'foo #:macros? #t #:internal? #t #:split #:name))
124
125  (apropos-list-test
126    '(##foo#bar1 ##foo#bar2)
127    (apropos-list 'foo #:macros? #t #:internal? #t #:split #:module))
128
129  (apropos-list-test
130    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 foobarmacro1 foobarmacro2)
131    (apropos-list 'foobar #:macros? #t))
132
133  (apropos-list-test
134    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 Foobarvar2 Foobarvar1)
135    (apropos-list 'foobar #:case-insensitive? #t))
136
137  (apropos-list-test
138    '(foobarvar2 foobarvar1 Foobarvar1 Foobarvar2)
139    (apropos-list ''".+barvar[12]"))
140)
141
142;;
143
144#|
145#;14> (define foobarprocx (lambda (a b c) 'foobarprocx))
146#;15> '(((|| . foobarmacro1) . macro))
147(((||: . foobarmacro1) . macro))
148#;16> '(((||: . foobarmacro1) . macro))
149(((: . foobarmacro1) . macro))
150#;17> ||
151||:
152#;18> ||:
153
154Error: unbound variable: :
155#;19> #:||
156||:
157#;20> (eq? #:|| #:||)
158#t
159#;21> (caaar (apropos-information-list 'foobarproc))
160||:
161#;22> (eq? #:|| (caaar (apropos-information-list 'foobarproc)))
162#f
163|#
164
165;oh , my - #:|| from reader is not eq? #:|| from symbol-table
166
167(test-group "Information List"
168  (apropos-information-list-test
169    '(
170      ((|| . foobarmacro1) . macro)
171      ((|| . foobarmacro2) . macro)
172      ((|| . foobarproc0) procedure)
173      ((|| . foobarproc1) procedure a)
174      ((|| . foobarproc2) procedure a b)
175      ((|| . foobarprocn) procedure a b . r)
176      ((|| . foobarprocx) procedure a b c)
177      ((|| . foobarvar1) . variable)
178      ((|| . foobarvar2) . variable) )
179    (apropos-information-list 'foobar #:macros? #t #:internal? #t))
180
181  (test "apropos-information-list"
182    '(((|| . foobarproc0) procedure)
183      ((|| . foobarproc1) procedure a)
184      ((|| . foobarproc2) procedure a b)
185      ((|| . foobarprocn) procedure a b . r)
186      ((|| . foobarprocx) procedure a b c))
187    (apropos-information-list 'foobarproc #:macros? #t #:internal? #t #:sort #:module))
188)
189
190#| ;UNSUPPORTED
191;;
192
193(use environments)
194
195(define tstenv1 (make-environment #t))
196
197(environment-extend! tstenv1 'foobarprocx (lambda (a b c) 'foobarprocx))
198(environment-extend! tstenv1 'foobarvar1 'foobarvar1)
199(environment-extend! tstenv1 'foobarvar2 'foobarvar2)
200(environment-extend! tstenv1 '##bar#foo1 '##bar#foo1)
201(environment-extend! tstenv1 '##bar#foo1 (lambda () '##bar#foo1))
202
203;make-environment cannot create a syntax-environment
204;apropos always uses the ##sys#macro-environment for macro lookup
205
206(test '(foobarprocx foobarvar2 foobarvar1 ##bar#foo1)
207      (apropos-list 'foo tstenv1 #:internal? #t))
208|#
209
210;;;
211
212(test-end "Apropos")
213
214(test-exit)
Note: See TracBrowser for help on using the repository browser.