Commit | Line | Data |
---|---|---|
6e7d5622 KR |
1 | ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- |
2 | ||
608860a5 | 3 | ;;;; Copyright (C) 2006, 2007 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 | |
8 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
9 | ;;;; | |
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. | |
14 | ;;;; | |
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 LC |
19 | (define-module (test-suite test-modules) |
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)) | |
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 | ||
37 | (pass-if "module-add!" | |
38 | (let ((m (make-module)) | |
39 | (value (cons 'x 'y))) | |
40 | (module-add! m 'something (make-variable value)) | |
41 | (eq? (module-ref m 'something) value))) | |
42 | ||
43 | (pass-if "module-define!" | |
44 | (let ((m (make-module)) | |
45 | (value (cons 'x 'y))) | |
46 | (module-define! m 'something value) | |
47 | (eq? (module-ref m 'something) value))) | |
48 | ||
49 | (pass-if "module-use!" | |
50 | (let ((m (make-module)) | |
51 | (import (make-module))) | |
52 | (module-define! m 'something 'something) | |
53 | (module-define! import 'imported 'imported) | |
54 | (module-use! m import) | |
55 | (and (eq? (module-ref m 'something) 'something) | |
56 | (eq? (module-ref m 'imported) 'imported) | |
57 | (module-local-variable m 'something) | |
58 | (not (module-local-variable m 'imported)) | |
59 | #t))) | |
60 | ||
61 | (pass-if "module-use! (duplicates local binding)" | |
62 | ;; Imported bindings can't override locale bindings. | |
63 | (let ((m (make-module)) | |
64 | (import (make-module))) | |
65 | (module-define! m 'something 'something) | |
66 | (module-define! import 'something 'imported) | |
67 | (module-use! m import) | |
68 | (eq? (module-ref m 'something) 'something))) | |
69 | ||
70 | (pass-if "module-locally-bound?" | |
71 | (let ((m (make-module)) | |
72 | (import (make-module))) | |
73 | (module-define! m 'something #t) | |
74 | (module-define! import 'imported #t) | |
75 | (module-use! m import) | |
76 | (and (module-locally-bound? m 'something) | |
77 | (not (module-locally-bound? m 'imported))))) | |
78 | ||
79 | (pass-if "module-{local-,}variable" | |
80 | (let ((m (make-module)) | |
81 | (import (make-module))) | |
82 | (module-define! m 'local #t) | |
83 | (module-define! import 'imported #t) | |
84 | (module-use! m import) | |
85 | (and (module-local-variable m 'local) | |
86 | (not (module-local-variable m 'imported)) | |
87 | (eq? (module-variable m 'local) | |
88 | (module-local-variable m 'local)) | |
89 | (eq? (module-local-variable import 'imported) | |
90 | (module-variable m 'imported))))) | |
91 | ||
92 | (pass-if "module-import-interface" | |
93 | (and (every? (lambda (sym iface) | |
94 | (eq? (module-import-interface (current-module) sym) | |
95 | iface)) | |
96 | '(current-module exception:bad-variable every) | |
97 | (cons the-scm-module | |
98 | (map resolve-interface | |
99 | '((test-suite lib) (srfi srfi-1))))) | |
100 | ||
101 | ;; For renamed bindings, a custom interface is used so we can't | |
102 | ;; check for equality with `eq?'. | |
103 | (every? (lambda (sym iface) | |
104 | (let ((import | |
105 | (module-import-interface (current-module) sym))) | |
106 | (equal? (module-name import) | |
107 | (module-name iface)))) | |
108 | '(s:make-stream s:stream-car s:stream-cdr) | |
109 | (make-list 3 (resolve-interface '(ice-9 streams)))))) | |
110 | ||
111 | (pass-if "module-reverse-lookup" | |
112 | (let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams))) | |
113 | (syms '(every exception:bad-variable make-stream)) | |
114 | (locals '(every exception:bad-variable s:make-stream))) | |
115 | (every? (lambda (var sym) | |
116 | (eq? (module-reverse-lookup (current-module) var) | |
117 | sym)) | |
118 | (map module-variable | |
119 | (map resolve-interface mods) | |
120 | syms) | |
121 | locals)))) | |
122 | ||
123 | ||
124 | \f | |
125 | ;;; | |
126 | ;;; Observers. | |
127 | ;;; | |
128 | ||
129 | (with-test-prefix "observers" | |
130 | ||
131 | (pass-if "weak observer invoked" | |
132 | (let* ((m (make-module)) | |
133 | (invoked 0)) | |
134 | (module-observe-weak m (lambda (mod) | |
135 | (if (eq? mod m) | |
136 | (set! invoked (+ invoked 1))))) | |
137 | (module-define! m 'something 2) | |
138 | (module-define! m 'something-else 1) | |
139 | (= invoked 2))) | |
140 | ||
141 | (pass-if "all weak observers invoked" | |
142 | ;; With the two-argument `module-observe-weak' available in previous | |
143 | ;; versions, the observer would get unregistered as soon as the observing | |
144 | ;; closure gets GC'd, making it impossible to use an anonymous lambda as | |
145 | ;; the observing procedure. | |
146 | ||
147 | (let* ((m (make-module)) | |
148 | (observer-count 500) | |
149 | (observer-ids (let loop ((i observer-count) | |
150 | (ids '())) | |
151 | (if (= i 0) | |
152 | ids | |
153 | (loop (- i 1) (cons (make-module) ids))))) | |
154 | (observers-invoked (make-hash-table observer-count))) | |
155 | ||
156 | ;; register weak observers | |
157 | (for-each (lambda (id) | |
158 | (module-observe-weak m id | |
159 | (lambda (m) | |
160 | (hashq-set! observers-invoked | |
161 | id #t)))) | |
162 | observer-ids) | |
163 | ||
164 | (gc) | |
165 | ||
166 | ;; invoke them | |
167 | (module-call-observers m) | |
168 | ||
169 | ;; make sure all of them were invoked | |
170 | (->bool (every (lambda (id) | |
171 | (hashq-ref observers-invoked id)) | |
172 | observer-ids)))) | |
173 | ||
174 | (pass-if "imported bindings updated" | |
175 | (let ((m (make-module)) | |
176 | (imported (make-module))) | |
177 | ;; Beautify them, notably adding them a public interface. | |
178 | (beautify-user-module! m) | |
179 | (beautify-user-module! imported) | |
180 | ||
181 | (module-use! m (module-public-interface imported)) | |
182 | (module-define! imported 'imported-binding #t) | |
183 | ||
184 | ;; At this point, `imported-binding' is local to IMPORTED. | |
185 | (and (not (module-variable m 'imported-binding)) | |
186 | (begin | |
187 | ;; Export `imported-binding' from IMPORTED. | |
188 | (module-export! imported '(imported-binding)) | |
189 | ||
190 | ;; Make sure it is now visible from M. | |
191 | (module-ref m 'imported-binding)))))) | |
192 | ||
193 | ||
194 | \f | |
195 | ;;; | |
196 | ;;; Duplicate bindings handling. | |
197 | ;;; | |
198 | ||
199 | (with-test-prefix "duplicate bindings" | |
200 | ||
201 | (pass-if "simple duplicate handler" | |
202 | ;; Import the same binding twice. | |
203 | (let* ((m (make-module)) | |
204 | (import1 (make-module)) | |
205 | (import2 (make-module)) | |
206 | (handler-invoked? #f) | |
207 | (handler (lambda (module name int1 val1 int2 val2 var val) | |
208 | (set! handler-invoked? #t) | |
209 | ;; Keep the first binding. | |
210 | (or var (module-local-variable int1 name))))) | |
211 | ||
212 | (set-module-duplicates-handlers! m (list handler)) | |
213 | (module-define! m 'something 'something) | |
214 | (set-module-name! import1 'imported-module-1) | |
215 | (set-module-name! import2 'imported-module-2) | |
216 | (module-define! import1 'imported 'imported-1) | |
217 | (module-define! import2 'imported 'imported-2) | |
218 | (module-use! m import1) | |
219 | (module-use! m import2) | |
220 | (and (eq? (module-ref m 'imported) 'imported-1) | |
221 | handler-invoked?)))) | |
222 | ||
223 | \f | |
224 | ;;; | |
225 | ;;; Lazy binder. | |
226 | ;;; | |
227 | ||
228 | (with-test-prefix "lazy binder" | |
229 | ||
230 | (pass-if "not invoked" | |
231 | (let ((m (make-module)) | |
232 | (invoked? #f)) | |
233 | (module-define! m 'something 2) | |
234 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
235 | (and (module-ref m 'something) | |
236 | (not invoked?)))) | |
237 | ||
238 | (pass-if "not invoked (module-add!)" | |
239 | (let ((m (make-module)) | |
240 | (invoked? #f)) | |
241 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
242 | (module-add! m 'something (make-variable 2)) | |
243 | (and (module-ref m 'something) | |
244 | (not invoked?)))) | |
245 | ||
246 | (pass-if "invoked (module-ref)" | |
247 | (let ((m (make-module)) | |
248 | (invoked? #f)) | |
249 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
250 | (false-if-exception (module-ref m 'something)) | |
251 | invoked?)) | |
252 | ||
253 | (pass-if "invoked (module-define!)" | |
254 | (let ((m (make-module)) | |
255 | (invoked? #f)) | |
256 | (set-module-binder! m (lambda args (set! invoked? #t) #f)) | |
257 | (module-define! m 'something 2) | |
258 | (and invoked? | |
259 | (eq? (module-ref m 'something) 2)))) | |
260 | ||
261 | (pass-if "honored (ref)" | |
262 | (let ((m (make-module)) | |
263 | (invoked? #f) | |
264 | (value (cons 'x 'y))) | |
265 | (set-module-binder! m | |
266 | (lambda (mod sym define?) | |
267 | (set! invoked? #t) | |
268 | (cond ((not (eq? m mod)) | |
269 | (error "invalid module" mod)) | |
270 | (define? | |
271 | (error "DEFINE? shouldn't be set")) | |
272 | (else | |
273 | (make-variable value))))) | |
274 | (and (eq? (module-ref m 'something) value) | |
275 | invoked?)))) | |
276 | ||
277 | ||
278 | \f | |
279 | ;;; | |
280 | ;;; Higher-level features. | |
281 | ;;; | |
6e7d5622 KR |
282 | |
283 | (with-test-prefix "autoload" | |
284 | ||
608860a5 LC |
285 | (pass-if "module-autoload!" |
286 | (let ((m (make-module))) | |
287 | (module-autoload! m '(ice-9 q) '(make-q)) | |
288 | (not (not (module-ref m 'make-q))))) | |
289 | ||
6e7d5622 KR |
290 | (pass-if "autoloaded" |
291 | (catch #t | |
292 | (lambda () | |
293 | ;; Simple autoloading. | |
294 | (eval '(begin | |
295 | (define-module (test-autoload-one) | |
296 | :autoload (ice-9 q) (make-q)) | |
297 | (not (not make-q))) | |
298 | (current-module))) | |
299 | (lambda (key . args) | |
300 | #f))) | |
301 | ||
302 | ;; In Guile 1.8.0 this failed because the binder in | |
303 | ;; `make-autoload-interface' would try to remove the autoload interface | |
304 | ;; from the module's "uses" without making sure it is still part of these | |
305 | ;; "uses". | |
306 | ;; | |
307 | (pass-if "autoloaded+used" | |
308 | (catch #t | |
309 | (lambda () | |
310 | (eval '(begin | |
311 | (define-module (test-autoload-two) | |
312 | :autoload (ice-9 q) (make-q) | |
313 | :use-module (ice-9 q)) | |
314 | (not (not make-q))) | |
315 | (current-module))) | |
316 | (lambda (key . args) | |
317 | #f)))) |