Commit | Line | Data |
---|---|---|
6e7d5622 KR |
1 | ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- |
2 | ||
7354a105 | 3 | ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc. |
6e7d5622 KR |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 NJ |
8 | ;;;; version 3 of the License, or (at your option) any later version. |
9 | ;;;; | |
6e7d5622 KR |
10 | ;;;; This library is distributed in the hope that it will be useful, |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
53befeb7 | 14 | ;;;; |
6e7d5622 KR |
15 | ;;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
608860a5 | 19 | (define-module (test-suite test-modules) |
7354a105 LC |
20 | #:use-module (srfi srfi-1) |
21 | #:use-module ((ice-9 streams) ;; for test purposes | |
22 | #:renamer (symbol-prefix-proc 's:)) | |
23 | #:use-module (test-suite lib)) | |
608860a5 LC |
24 | |
25 | ||
26 | (define (every? . args) | |
27 | (not (not (apply every args)))) | |
28 | ||
29 | ||
30 | \f | |
31 | ;;; | |
32 | ;;; Foundations. | |
33 | ;;; | |
34 | ||
35 | (with-test-prefix "foundations" | |
36 | ||
16f451f3 LC |
37 | (pass-if "modules don't remain anonymous" |
38 | ;; This is a requirement for `psyntax': it stores module names and relies | |
39 | ;; on being able to `resolve-module' them. | |
40 | (let ((m (make-module))) | |
41 | (and (module-name m) | |
42 | (eq? m (resolve-module (module-name m)))))) | |
43 | ||
608860a5 LC |
44 | (pass-if "module-add!" |
45 | (let ((m (make-module)) | |
46 | (value (cons 'x 'y))) | |
47 | (module-add! m 'something (make-variable value)) | |
48 | (eq? (module-ref m 'something) value))) | |
49 | ||
50 | (pass-if "module-define!" | |
51 | (let ((m (make-module)) | |
52 | (value (cons 'x 'y))) | |
53 | (module-define! m 'something value) | |
54 | (eq? (module-ref m 'something) value))) | |
55 | ||
56 | (pass-if "module-use!" | |
57 | (let ((m (make-module)) | |
58 | (import (make-module))) | |
59 | (module-define! m 'something 'something) | |
60 | (module-define! import 'imported 'imported) | |
61 | (module-use! m import) | |
62 | (and (eq? (module-ref m 'something) 'something) | |
63 | (eq? (module-ref m 'imported) 'imported) | |
64 | (module-local-variable m 'something) | |
65 | (not (module-local-variable m 'imported)) | |
66 | #t))) | |
67 | ||
68 | (pass-if "module-use! (duplicates local binding)" | |
69 | ;; Imported bindings can't override locale bindings. | |
70 | (let ((m (make-module)) | |
71 | (import (make-module))) | |
72 | (module-define! m 'something 'something) | |
73 | (module-define! import 'something 'imported) | |
74 | (module-use! m import) | |
75 | (eq? (module-ref m 'something) 'something))) | |
76 | ||
77 | (pass-if "module-locally-bound?" | |
78 | (let ((m (make-module)) | |
79 | (import (make-module))) | |
80 | (module-define! m 'something #t) | |
81 | (module-define! import 'imported #t) | |
82 | (module-use! m import) | |
83 | (and (module-locally-bound? m 'something) | |
84 | (not (module-locally-bound? m 'imported))))) | |
85 | ||
86 | (pass-if "module-{local-,}variable" | |
87 | (let ((m (make-module)) | |
88 | (import (make-module))) | |
89 | (module-define! m 'local #t) | |
90 | (module-define! import 'imported #t) | |
91 | (module-use! m import) | |
92 | (and (module-local-variable m 'local) | |
93 | (not (module-local-variable m 'imported)) | |
94 | (eq? (module-variable m 'local) | |
95 | (module-local-variable m 'local)) | |
96 | (eq? (module-local-variable import 'imported) | |
97 | (module-variable m 'imported))))) | |
98 | ||
99 | (pass-if "module-import-interface" | |
100 | (and (every? (lambda (sym iface) | |
101 | (eq? (module-import-interface (current-module) sym) | |
102 | iface)) | |
103 | '(current-module exception:bad-variable every) | |
104 | (cons the-scm-module | |
105 | (map resolve-interface | |
106 | '((test-suite lib) (srfi srfi-1))))) | |
107 | ||
108 | ;; For renamed bindings, a custom interface is used so we can't | |
109 | ;; check for equality with `eq?'. | |
110 | (every? (lambda (sym iface) | |
111 | (let ((import | |
112 | (module-import-interface (current-module) sym))) | |
113 | (equal? (module-name import) | |
114 | (module-name iface)))) | |
115 | '(s:make-stream s:stream-car s:stream-cdr) | |
116 | (make-list 3 (resolve-interface '(ice-9 streams)))))) | |
117 | ||
118 | (pass-if "module-reverse-lookup" | |
119 | (let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams))) | |
120 | (syms '(every exception:bad-variable make-stream)) | |
121 | (locals '(every exception:bad-variable s:make-stream))) | |
122 | (every? (lambda (var sym) | |
123 | (eq? (module-reverse-lookup (current-module) var) | |
124 | sym)) | |
125 | (map module-variable | |
126 | (map resolve-interface mods) | |
127 | syms) | |
1606312f LC |
128 | locals))) |
129 | ||
130 | (pass-if "module-reverse-lookup [pre-module-obarray]" | |
131 | (let ((var (module-variable (current-module) 'string?))) | |
132 | (eq? 'string? (module-reverse-lookup #f var)))) | |
133 | ||
134 | (pass-if-exception "module-reverse-lookup [wrong-type-arg]" | |
135 | exception:wrong-type-arg | |
7354a105 LC |
136 | (module-reverse-lookup (current-module) 'foo)) |
137 | ||
138 | (pass-if "the-root-module" | |
139 | (eq? (module-public-interface the-root-module) the-scm-module)) | |
140 | ||
141 | (pass-if "the-scm-module" | |
142 | ;; THE-SCM-MODULE is its own public interface. See | |
143 | ;; <https://savannah.gnu.org/bugs/index.php?30623>. | |
144 | (eq? (module-public-interface the-scm-module) the-scm-module))) | |
608860a5 LC |
145 | |
146 | ||
147 | \f | |
8d795c83 AW |
148 | ;;; |
149 | ;;; module-use! / module-use-interfaces! | |
150 | ;;; | |
151 | (with-test-prefix "module-use" | |
152 | (let ((m (make-module))) | |
153 | (pass-if "no uses initially" | |
154 | (null? (module-uses m))) | |
155 | ||
156 | (pass-if "using ice-9 q" | |
157 | (begin | |
158 | (module-use! m (resolve-interface '(ice-9 q))) | |
159 | (equal? (module-uses m) | |
160 | (list (resolve-interface '(ice-9 q)))))) | |
161 | ||
162 | (pass-if "using ice-9 q again" | |
163 | (begin | |
164 | (module-use! m (resolve-interface '(ice-9 q))) | |
165 | (equal? (module-uses m) | |
166 | (list (resolve-interface '(ice-9 q)))))) | |
167 | ||
168 | (pass-if "using ice-9 ftw" | |
169 | (begin | |
170 | (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw)))) | |
171 | (equal? (module-uses m) | |
172 | (list (resolve-interface '(ice-9 q)) | |
173 | (resolve-interface '(ice-9 ftw)))))) | |
174 | ||
175 | (pass-if "using ice-9 ftw again" | |
176 | (begin | |
177 | (module-use-interfaces! m (list (resolve-interface '(ice-9 ftw)))) | |
178 | (equal? (module-uses m) | |
179 | (list (resolve-interface '(ice-9 q)) | |
180 | (resolve-interface '(ice-9 ftw)))))) | |
181 | ||
182 | (pass-if "using ice-9 control twice" | |
183 | (begin | |
184 | (module-use-interfaces! m (list (resolve-interface '(ice-9 control)) | |
185 | (resolve-interface '(ice-9 control)))) | |
186 | (equal? (module-uses m) | |
187 | (list (resolve-interface '(ice-9 q)) | |
188 | (resolve-interface '(ice-9 ftw)) | |
189 | (resolve-interface '(ice-9 control)))))))) | |
190 | ||
191 | ||
192 | \f | |
7e314766 AW |
193 | ;;; |
194 | ;;; Resolve-module. | |
195 | ;;; | |
196 | ||
197 | (with-test-prefix "resolve-module" | |
198 | ||
199 | (pass-if "#:ensure #t by default" | |
200 | (module? (resolve-module (list (gensym))))) | |
201 | ||
202 | (pass-if "#:ensure #t explicitly" | |
203 | (module? (resolve-module (list (gensym)) #:ensure #t))) | |
204 | ||
205 | (pass-if "#:ensure #f" | |
206 | (not (resolve-module (list (gensym)) #:ensure #f)))) | |
207 | ||
208 | ||
209 | \f | |
608860a5 LC |
210 | ;;; |
211 | ;;; Observers. | |
212 | ;;; | |
213 | ||
214 | (with-test-prefix "observers" | |
215 | ||
216 | (pass-if "weak observer invoked" | |
217 | (let* ((m (make-module)) | |
218 | (invoked 0)) | |
219 | (module-observe-weak m (lambda (mod) | |
220 | (if (eq? mod m) | |
221 | (set! invoked (+ invoked 1))))) | |
222 | (module-define! m 'something 2) | |
223 | (module-define! m 'something-else 1) | |
224 | (= invoked 2))) | |
225 | ||
226 | (pass-if "all weak observers invoked" | |
227 | ;; With the two-argument `module-observe-weak' available in previous | |
228 | ;; versions, the observer would get unregistered as soon as the observing | |
229 | ;; closure gets GC'd, making it impossible to use an anonymous lambda as | |
230 | ;; the observing procedure. | |
231 | ||
232 | (let* ((m (make-module)) | |
233 | (observer-count 500) | |
234 | (observer-ids (let loop ((i observer-count) | |
235 | (ids '())) | |
236 | (if (= i 0) | |
237 | ids | |
238 | (loop (- i 1) (cons (make-module) ids))))) | |
239 | (observers-invoked (make-hash-table observer-count))) | |
240 | ||
241 | ;; register weak observers | |
242 | (for-each (lambda (id) | |
243 | (module-observe-weak m id | |
244 | (lambda (m) | |
245 | (hashq-set! observers-invoked | |
246 | id #t)))) | |
247 | observer-ids) | |
248 | ||
249 | (gc) | |
250 | ||
251 | ;; invoke them | |
252 | (module-call-observers m) | |
253 | ||
254 | ;; make sure all of them were invoked | |
255 | (->bool (every (lambda (id) | |
256 | (hashq-ref observers-invoked id)) | |
257 | observer-ids)))) | |
258 | ||
259 | (pass-if "imported bindings updated" | |
260 | (let ((m (make-module)) | |
261 | (imported (make-module))) | |
262 | ;; Beautify them, notably adding them a public interface. | |
263 | (beautify-user-module! m) | |
264 | (beautify-user-module! imported) | |
265 | ||
266 | (module-use! m (module-public-interface imported)) | |
267 | (module-define! imported 'imported-binding #t) | |
268 | ||
269 | ;; At this point, `imported-binding' is local to IMPORTED. | |
270 | (and (not (module-variable m 'imported-binding)) | |
271 | (begin | |
272 | ;; Export `imported-binding' from IMPORTED. | |
273 | (module-export! imported '(imported-binding)) | |
274 | ||
275 | ;; Make sure it is now visible from M. | |
276 | (module-ref m 'imported-binding)))))) | |
277 | ||
278 | ||
279 | \f | |
280 | ;;; | |
281 | ;;; Duplicate bindings handling. | |
282 | ;;; | |
283 | ||
284 | (with-test-prefix "duplicate bindings" | |
285 | ||
286 | (pass-if "simple duplicate handler" | |
287 | ;; Import the same binding twice. | |
288 | (let* ((m (make-module)) | |
289 | (import1 (make-module)) | |
290 | (import2 (make-module)) | |
291 | (handler-invoked? #f) | |
292 | (handler (lambda (module name int1 val1 int2 val2 var val) | |
319dd089 AW |
293 | ;; We expect both VAR and VAL to be #f, as there |
294 | ;; is no previous binding for 'imported in M. | |
295 | (if var (error "unexpected var" var)) | |
296 | (if val (error "unexpected val" val)) | |
608860a5 LC |
297 | (set! handler-invoked? #t) |
298 | ;; Keep the first binding. | |
299 | (or var (module-local-variable int1 name))))) | |
300 | ||
301 | (set-module-duplicates-handlers! m (list handler)) | |
302 | (module-define! m 'something 'something) | |
303 | (set-module-name! import1 'imported-module-1) | |
304 | (set-module-name! import2 'imported-module-2) | |
305 | (module-define! import1 'imported 'imported-1) | |
306 | (module-define! import2 'imported 'imported-2) | |
307 | (module-use! m import1) | |
308 | (module-use! m import2) | |
309 | (and (eq? (module-ref m 'imported) 'imported-1) | |
310 | handler-invoked?)))) | |
311 | ||
312 | \f | |
313 | ;;; | |
314 | ;;; Lazy binder. | |
315 | ;;; | |
316 | ||
317 | (with-test-prefix "lazy binder" | |
318 | ||
319 | (pass-if "not invoked" | |
320 | (let ((m (make-module)) | |
321 | (invoked? #f)) | |
322 | (module-define! m 'something 2) | |
323 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
324 | (and (module-ref m 'something) | |
325 | (not invoked?)))) | |
326 | ||
327 | (pass-if "not invoked (module-add!)" | |
328 | (let ((m (make-module)) | |
329 | (invoked? #f)) | |
330 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
331 | (module-add! m 'something (make-variable 2)) | |
332 | (and (module-ref m 'something) | |
333 | (not invoked?)))) | |
334 | ||
335 | (pass-if "invoked (module-ref)" | |
336 | (let ((m (make-module)) | |
337 | (invoked? #f)) | |
338 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
339 | (false-if-exception (module-ref m 'something)) | |
340 | invoked?)) | |
341 | ||
342 | (pass-if "invoked (module-define!)" | |
343 | (let ((m (make-module)) | |
344 | (invoked? #f)) | |
345 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
346 | (module-define! m 'something 2) | |
347 | (and invoked? | |
764246cf | 348 | (eqv? (module-ref m 'something) 2)))) |
608860a5 LC |
349 | |
350 | (pass-if "honored (ref)" | |
351 | (let ((m (make-module)) | |
352 | (invoked? #f) | |
353 | (value (cons 'x 'y))) | |
354 | (set-module-binder! m | |
355 | (lambda (mod sym define?) | |
356 | (set! invoked? #t) | |
357 | (cond ((not (eq? m mod)) | |
358 | (error "invalid module" mod)) | |
359 | (define? | |
360 | (error "DEFINE? shouldn't be set")) | |
361 | (else | |
362 | (make-variable value))))) | |
363 | (and (eq? (module-ref m 'something) value) | |
364 | invoked?)))) | |
365 | ||
366 | ||
367 | \f | |
368 | ;;; | |
369 | ;;; Higher-level features. | |
370 | ;;; | |
6e7d5622 KR |
371 | |
372 | (with-test-prefix "autoload" | |
373 | ||
608860a5 LC |
374 | (pass-if "module-autoload!" |
375 | (let ((m (make-module))) | |
376 | (module-autoload! m '(ice-9 q) '(make-q)) | |
377 | (not (not (module-ref m 'make-q))))) | |
378 | ||
6e7d5622 KR |
379 | (pass-if "autoloaded" |
380 | (catch #t | |
381 | (lambda () | |
382 | ;; Simple autoloading. | |
383 | (eval '(begin | |
384 | (define-module (test-autoload-one) | |
385 | :autoload (ice-9 q) (make-q)) | |
386 | (not (not make-q))) | |
387 | (current-module))) | |
388 | (lambda (key . args) | |
389 | #f))) | |
390 | ||
391 | ;; In Guile 1.8.0 this failed because the binder in | |
392 | ;; `make-autoload-interface' would try to remove the autoload interface | |
393 | ;; from the module's "uses" without making sure it is still part of these | |
394 | ;; "uses". | |
395 | ;; | |
396 | (pass-if "autoloaded+used" | |
397 | (catch #t | |
398 | (lambda () | |
399 | (eval '(begin | |
400 | (define-module (test-autoload-two) | |
401 | :autoload (ice-9 q) (make-q) | |
402 | :use-module (ice-9 q)) | |
403 | (not (not make-q))) | |
404 | (current-module))) | |
405 | (lambda (key . args) | |
406 | #f)))) | |
e96bac45 JG |
407 | |
408 | \f | |
409 | ;;; | |
410 | ;;; R6RS compatibility | |
411 | ;;; | |
412 | ||
413 | (with-test-prefix "module versions" | |
414 | ||
415 | (pass-if "version-matches? for matching versions" | |
416 | (version-matches? '(1 2 3) '(1 2 3))) | |
417 | ||
418 | (pass-if "version-matches? for non-matching versions" | |
419 | (not (version-matches? '(3 2 1) '(1 2 3)))) | |
420 | ||
421 | (pass-if "version-matches? against more specified version" | |
422 | (version-matches? '(1 2) '(1 2 3))) | |
423 | ||
424 | (pass-if "version-matches? against less specified version" | |
425 | (not (version-matches? '(1 2 3) '(1 2))))) |