~ chicken-core (chicken-5) /tests/module-tests.scm

  1;;;; module-tests.scm
  2
  3(import (chicken eval) (chicken load))
  4
  5(cond-expand
  6 (compiling
  7  (include "test.scm") )
  8 (else
  9  (load-relative "test.scm")))
 10
 11(test-begin "modules")
 12
 13(test-assert
 14 "r4rs"
 15 (module test-r4rs ()
 16   (import r4rs)
 17   (equal? 1 1)))
 18
 19(test-assert
 20 "r4rs-null"
 21 (module test-r4rs-null ()
 22   (import r4rs-null)
 23   (begin #t)))
 24
 25(test-equal "internal/variable"
 26(module foo (abc def)
 27  (import scheme)
 28  (define (abc x) (+ x 33))
 29  (define-syntax def
 30    (syntax-rules ()
 31      ((_ x) (+ 99 (abc x)))))
 32  (abc 1))
 3334)
 34
 35(test-error "external/unimported variable (fail)" (abc 2))
 36(test-error "external/unimported syntax (fail)" (def 3))
 37
 38(import foo)
 39
 40(test-equal "external/imported variable" (abc 4) 37)
 41(test-equal "external/imported syntax" (def 5) 137)
 42
 43(module bar (x y)
 44  (import (prefix scheme s:))
 45  (s:define (x y) (s:* y 2))
 46  (s:define y 1))
 47
 48(import (prefix (only (except (rename bar (x z)) y) z) "bar-"))
 49(test-equal "modified import" (bar-z 10) 20)
 50(test-error "hidden import" y)
 51
 52(module baz ((x s:list))
 53  (import (prefix scheme s:))
 54  (s:define-syntax x
 55    (syntax-rules ()
 56      ((_ x) (s:list x)))))
 57
 58(import baz)
 59(test-equal "prefixed import and reexport" (x 1) '(1))
 60
 61(module m1 ((bar gna))
 62  (import scheme)
 63  (define (gna x) (list 'gna x))
 64  (define-syntax bar
 65    (syntax-rules ()
 66      ((_ x) (baz x))))
 67  (define-syntax baz
 68    (syntax-rules ()
 69      ((_ x) (gna 'x)))))
 70
 71(module m2 (run)
 72  (import scheme (chicken base) m1)
 73  (define-syntax baz
 74    (syntax-rules ()
 75      ((_ x) (list 'goo 'x))))
 76  (define (gna x) (print "ok."))
 77  (define (run) (gna 9) (bar 99)))
 78
 79(import (only m2 run))
 80(test-equal "indirect imports" (run) '(gna 99))
 81
 82(module m1 ((s1 f1))
 83  (import scheme (chicken base))
 84  (define (f1) (print "f1") 'f1)
 85  (define-syntax s1
 86    (syntax-rules ()
 87      ((_) (f1)))))
 88
 89(module m2 (s2)
 90  (import scheme m1)
 91  (define-syntax s2
 92    (syntax-rules ()
 93      ((_) (s1)))))
 94
 95(module m3 (s3)
 96  (import scheme m2)
 97  (define-syntax s3
 98    (syntax-rules ()
 99      ((_) (s2)))))
100
101(import m3)
102(test-equal "chained indirect imports" (s3) 'f1)
103
104(module literal-compare-test (s1)
105  (import scheme)
106  (define-syntax s1
107    (syntax-rules (and)
108      ((_ (and x)) (list x))))
109)
110
111(import literal-compare-test)
112(test-equal "literal compare and export" (s1 (and 100)) '(100))
113
114(module y (y1)
115  (import scheme)
116  (define y1 10))
117
118(module x (magnitude)
119  (import (except scheme magnitude) y)
120  (define magnitude y1))
121
122(test-equal "redefinition of indirect import" (procedure? magnitude) #t)
123
124(import x)
125(test-equal "redefinition of indirect import (II)" magnitude 10)
126
127(module m10 (m10x m10y)
128  (import scheme)
129  (define m10x 99)
130  (define-syntax m10y
131    (syntax-rules ()
132      ((_ x) (list 'x)))))
133
134(module m11 (m10x m10y)
135  (import m10))
136
137(import m11)
138(test-equal "value reexport" m10x 99)
139(test-equal "syntax reexport" (m10y 3) '(3))
140
141;; found by Jim Ursetto;
142
143(module m12 (begin0)
144  (import scheme)
145  (define-syntax begin0
146    (syntax-rules ()
147      ((_ e0 e1 ...)
148       (##sys#call-with-values
149	(lambda () e0)
150	(lambda var
151	  (begin
152	    e1 ...
153	    (apply ##sys#values var))))))))
154
155(test-equal "primitive indirect value-binding reexport"
156	    (module m13 ()
157	      (import m12)		; note absence of "scheme"
158	      (begin0 1 2 3))
159	    1)
160
161(module m14 (test-extlambda)
162  (import scheme)
163  (define (test-extlambda string #!optional whatever)
164    string))
165
166(import m14)
167
168(test-equal "extended lambda list uses expansion environment"
169            "some text"
170            (test-extlambda "some text"))
171
172;;; import-forms in `require-extension':
173
174(module m15 ()
175  (import scheme (chicken base))
176  (import (prefix (rename srfi-4 (u8vector u)) 99:))
177  (print 99:u))
178
179
180;;; expansion of macros into modules:
181
182(module m16 (foo-module)
183
184(import scheme)
185
186(define-syntax foo-module
187  (syntax-rules ()
188    ((_ name)
189     (module name (maker definer)
190       (import scheme)
191       (define (maker) 'name)
192       (define-syntax definer
193         (syntax-rules () 
194           ((_) (define (name) 'name))))))))
195
196)
197
198(import m16)
199(foo-module abc)
200(import abc)
201
202(test-equal 
203 "function defined in module that is the result of an expansion"
204 'abc (maker))
205
206(definer)
207
208(test-equal 
209 "syntax defined in module that is the result of an expansion"
210 'abc (abc))
211
212(module m17 (a) (import scheme) (define a 1))
213(begin-for-syntax ; XXX workaround for missing module alias functionality
214  (##sys#register-module-alias 'm18 'm17))
215(module m19 (a) (import scheme) (define a 2))
216
217(test-equal
218 "global module alias scope (1)"
219 (module m20 ()
220   (import scheme) 
221   (import m18)
222   a)
223 1)
224
225(test-equal
226 "local module alias scope"
227 (module m21 ()
228   (import scheme (chicken syntax))
229   (begin-for-syntax ; XXX s.a.
230     (##sys#register-module-alias 'm18 'm19))
231   (import m18)
232   a)
233 2)
234
235(test-equal
236 "global module alias scope (2)"
237 (module m20 ()
238   (import scheme) 
239   (import m18)
240   a)
241 1)
242
243;; #865 - "*" export list needs special treatment when using "export"
244;; (fix contributed by "megane")
245
246(module
247 m22
248 *
249 (import scheme)
250 (define b 2))
251
252(module
253 m23
254 *
255 (import (chicken module))
256 (import m22)
257 (export b) )
258
259(test-equal
260 "`*' export-list + explicit export"
261 (module m24 ()
262   (import m23)
263   b)
264 2)
265
266;; (contributed by "megane")
267
268(module m25 *
269  (import scheme)
270  (define foo 1))
271
272(module m26 (bar)
273  (import (chicken module) scheme)
274  (reexport m25)
275  (define bar 2))
276
277(module m27 *
278  (import (chicken module) scheme)
279  (reexport m25) ;; <- oops, bar not exported anymore
280  (define bar 2))
281
282(test-equal
283 "handle star-exporting module with reexport"
284 (module m28 ()
285   (import scheme (chicken base))
286   (import (prefix m26 b/))
287   (import (prefix m27 c/))
288   (print b/foo)
289   (print c/foo)
290   (print b/bar)
291   c/bar) ;; <- Error: unbound variable: c/bar
292 2)
293
294;; somewhat related, but with syntax (#882, found by megane):
295
296(module m29 *
297  (import (chicken syntax) scheme)
298  (define-syntax m29-baz
299    (er-macro-transformer
300     (lambda _
301       ''foo))))
302
303(module m30 *
304  (import (chicken module))
305  (import m29)
306  (export m29-baz))
307
308(test-equal
309 "star-export with explicit re-export of syntax"
310 (module m31 ()
311   (import scheme)
312   (import m30)
313   (m29-baz))
314 'foo)
315
316;; list-style library names
317
318(test-assert
319 (module (m33 a) *
320   (import (scheme))
321   (define (foo) 'ok)))
322
323(test-assert
324 (module (m33 b) ()
325   (import (scheme) (m33 a))
326   (eq? (foo) 'ok)))
327
328(test-assert (import (prefix (m33 a) m33/a/)))
329(test-assert (eq? (m33/a/foo) 'ok))
330(test-assert (module-environment '(m33 a)))
331
332;; Ensure that the modules system is simply an aliasing mechanism:
333;; Module instantion does not create multiple variable copies.
334
335(module m31 *
336  (import (chicken base) scheme)
337  (define mutation-count 0)
338  (define (internally-mutate!)
339    (set! mutation-count (add1 mutation-count)))
340  (define (get-count)
341    mutation-count))
342
343(module m32 *
344  (import (chicken base) scheme m31)
345  (define (externally-mutate!)
346    (set! mutation-count (add1 mutation-count))))
347
348(import m31 m32)
349(test-equal
350 "initial state"
351 0 mutation-count)
352
353(internally-mutate!)
354
355(test-equal
356 "After mutating inside defining module"
357 1 mutation-count)
358
359(set! mutation-count 2)
360
361(test-equal
362 "After mutating outside module"
363 2 mutation-count)
364
365(externally-mutate!)
366
367(test-equal
368 "After mutation by another module"
369 3 mutation-count)
370
371(test-equal
372 "Internal getter returns same thing"
373 3 (get-count))
374
375(test-assert
376 (not (current-module)))
377
378(test-assert
379 (module m33 ()
380   (import (scheme) (chicken module))
381   (eq? (current-module) 'm33)))
382
383(module m34 ((syn bar) alias)
384  (import scheme (chicken base) (chicken module))
385  (export/rename (bar baz) (syn syn2))
386  (define bar 123)
387  (assert (equal? bar 123))
388  (define-syntax alias 
389    (syntax-rules () 
390      ((_) (syn))))
391  (define-syntax syn
392    (syntax-rules ()
393      ((_) (list bar)))))
394
395(module m35 ()
396  (import scheme (chicken base) (chicken module))
397  (import (only (rename m34 (syn2 syn3)) syn3 alias))
398  (import (rename m34 (baz bax)))
399  (define bar 99)
400  (assert (equal? bax 123))
401  (assert (equal? (syn3) '(123)))
402  (assert (equal? (alias) '(123)))
403  (assert (equal? bar 99)))
404
405;; corner case, found by DeeEff, actually not really a good idea,
406;; but the expander looped here endlessly
407(module m36 (xcons)
408  (import scheme)
409  (define (xcons x y) (cons y x)))
410  
411(module m37 ()
412  (import (rename m36
413                  (xcons m36#xcons)))
414  (import scheme (chicken base))
415  (define (xcons x y) (m36#xcons 'X x))
416  (assert (equal? '(1 . X) (xcons 1 2))))
417
418(test-end "modules")
419
420(test-exit)