Commit | Line | Data |
---|---|---|
f764e6d1 MG |
1 | ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*- |
2 | ;;;; Martin Grabmueller, 2001-05-10 | |
3 | ;;;; | |
5ef102cc | 4 | ;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 Free Software Foundation, Inc. |
f764e6d1 | 5 | ;;;; |
53befeb7 NJ |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
f764e6d1 | 10 | ;;;; |
53befeb7 | 11 | ;;;; This library is distributed in the hope that it will be useful, |
f764e6d1 | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
f764e6d1 | 15 | ;;;; |
53befeb7 NJ |
16 | ;;;; You should have received a copy of the GNU Lesser General Public |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
f764e6d1 | 19 | |
8ab3d8a0 KR |
20 | (define-module (test-suite test-numbers) |
21 | #:use-module (test-suite lib) | |
30a700c8 | 22 | #:use-module ((system base compile) #:select (compile)) |
d9e36897 MW |
23 | #:use-module (srfi srfi-26) |
24 | #:use-module (srfi srfi-9) | |
25 | #:use-module (srfi srfi-9 gnu)) | |
8ab3d8a0 KR |
26 | |
27 | ||
c4a8200f AR |
28 | (define-record-type :qux (make-qux) qux?) |
29 | ||
d9e36897 MW |
30 | (define-record-type :foo (make-foo x) foo? |
31 | (x foo-x) | |
32 | (y foo-y set-foo-y!) | |
33 | (z foo-z set-foo-z!)) | |
f764e6d1 | 34 | |
d9e36897 MW |
35 | (define-record-type :bar (make-bar i j) bar? |
36 | (i bar-i) | |
37 | (j bar-j set-bar-j!)) | |
8ab3d8a0 | 38 | |
f764e6d1 | 39 | (define f (make-foo 1)) |
d9e36897 | 40 | (set-foo-y! f 2) |
f764e6d1 | 41 | |
8ab3d8a0 KR |
42 | (define b (make-bar 123 456)) |
43 | ||
44 | (with-test-prefix "constructor" | |
45 | ||
30a700c8 LC |
46 | ;; Constructors are defined using `define-integrable', meaning that direct |
47 | ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the | |
48 | ;; distinction below. | |
49 | ||
50 | (pass-if-exception "foo 0 args (inline)" exception:syntax-pattern-unmatched | |
51 | (compile '(make-foo) #:env (current-module))) | |
52 | (pass-if-exception "foo 2 args (inline)" exception:syntax-pattern-unmatched | |
53 | (compile '(make-foo 1 2) #:env (current-module))) | |
54 | ||
8ab3d8a0 | 55 | (pass-if-exception "foo 0 args" exception:wrong-num-args |
30a700c8 LC |
56 | (let ((make-foo make-foo)) |
57 | (make-foo))) | |
8ab3d8a0 | 58 | (pass-if-exception "foo 2 args" exception:wrong-num-args |
30a700c8 LC |
59 | (let ((make-foo make-foo)) |
60 | (make-foo 1 2)))) | |
8ab3d8a0 KR |
61 | |
62 | (with-test-prefix "predicate" | |
f764e6d1 | 63 | |
8ab3d8a0 | 64 | (pass-if "pass" |
f764e6d1 | 65 | (foo? f)) |
8ab3d8a0 KR |
66 | (pass-if "fail wrong record type" |
67 | (eq? #f (foo? b))) | |
68 | (pass-if "fail number" | |
69 | (eq? #f (foo? 123)))) | |
f764e6d1 | 70 | |
d9e36897 | 71 | (with-test-prefix "getter" |
f764e6d1 | 72 | |
d9e36897 MW |
73 | (pass-if "foo-x" |
74 | (= 1 (foo-x f))) | |
75 | (pass-if "foo-y" | |
76 | (= 2 (foo-y f))) | |
f764e6d1 | 77 | |
d9e36897 MW |
78 | (pass-if-exception "foo-x on number" exception:wrong-type-arg |
79 | (foo-x 999)) | |
80 | (pass-if-exception "foo-y on number" exception:wrong-type-arg | |
81 | (foo-y 999)) | |
8ab3d8a0 KR |
82 | |
83 | ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced | |
d9e36897 MW |
84 | (pass-if-exception "foo-x on bar" exception:wrong-type-arg |
85 | (foo-x b)) | |
86 | (pass-if-exception "foo-y on bar" exception:wrong-type-arg | |
87 | (foo-y b))) | |
8ab3d8a0 | 88 | |
d9e36897 | 89 | (with-test-prefix "setter" |
8ab3d8a0 | 90 | |
d9e36897 MW |
91 | (pass-if "set-foo-y!" |
92 | (set-foo-y! f #t) | |
93 | (eq? #t (foo-y f))) | |
8ab3d8a0 | 94 | |
d9e36897 MW |
95 | (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg |
96 | (set-foo-y! 999 #t)) | |
8ab3d8a0 KR |
97 | |
98 | ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced | |
d9e36897 MW |
99 | (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg |
100 | (set-foo-y! b 99))) | |
101 | ||
102 | (with-test-prefix "functional setters" | |
103 | ||
104 | (pass-if "set-field" | |
105 | (let ((s (make-foo (make-bar 1 2)))) | |
3d01c19a | 106 | (and (equal? (set-field s (foo-x bar-j) 3) |
d9e36897 | 107 | (make-foo (make-bar 1 3))) |
3d01c19a | 108 | (equal? (set-field s (foo-z) 'bar) |
d9e36897 MW |
109 | (let ((s2 (make-foo (make-bar 1 2)))) |
110 | (set-foo-z! s2 'bar) | |
111 | s2)) | |
112 | (equal? s (make-foo (make-bar 1 2)))))) | |
113 | ||
114 | (pass-if-exception "set-field on wrong struct type" exception:wrong-type-arg | |
115 | (let ((s (make-bar (make-foo 5) 2))) | |
3d01c19a | 116 | (set-field s (foo-x bar-j) 3))) |
d9e36897 MW |
117 | |
118 | (pass-if-exception "set-field on number" exception:wrong-type-arg | |
3d01c19a | 119 | (set-field 4 (foo-x bar-j) 3)) |
d9e36897 | 120 | |
ce650853 MW |
121 | (pass-if-equal "set-field with unknown first getter" |
122 | '(syntax-error set-fields "unknown getter" | |
3d01c19a | 123 | (set-field s (blah) 3) |
ce650853 | 124 | blah) |
d9e36897 MW |
125 | (catch 'syntax-error |
126 | (lambda () | |
127 | (compile '(let ((s (make-bar (make-foo 5) 2))) | |
3d01c19a | 128 | (set-field s (blah) 3)) |
d9e36897 MW |
129 | #:env (current-module)) |
130 | #f) | |
131 | (lambda (key whom what src form subform) | |
ce650853 | 132 | (list key whom what form subform)))) |
d9e36897 | 133 | |
ce650853 MW |
134 | (pass-if-equal "set-field with unknown second getter" |
135 | '(syntax-error set-fields "unknown getter" | |
3d01c19a | 136 | (set-field s (bar-j blah) 3) |
ce650853 | 137 | blah) |
d9e36897 MW |
138 | (catch 'syntax-error |
139 | (lambda () | |
140 | (compile '(let ((s (make-bar (make-foo 5) 2))) | |
3d01c19a | 141 | (set-field s (bar-j blah) 3)) |
d9e36897 MW |
142 | #:env (current-module)) |
143 | #f) | |
144 | (lambda (key whom what src form subform) | |
ce650853 | 145 | (list key whom what form subform)))) |
d9e36897 MW |
146 | |
147 | (pass-if "set-fields" | |
148 | (let ((s (make-foo (make-bar 1 2)))) | |
3d01c19a | 149 | (and (equal? (set-field s (foo-x bar-j) 3) |
d9e36897 MW |
150 | (make-foo (make-bar 1 3))) |
151 | (equal? (set-fields s | |
152 | ((foo-x bar-j) 3) | |
153 | ((foo-z) 'bar)) | |
154 | (let ((s2 (make-foo (make-bar 1 3)))) | |
155 | (set-foo-z! s2 'bar) | |
156 | s2)) | |
157 | (equal? s (make-foo (make-bar 1 2)))))) | |
158 | ||
159 | (pass-if-exception "set-fields on wrong struct type" exception:wrong-type-arg | |
160 | (let ((s (make-bar (make-foo 5) 2))) | |
161 | (set-fields 4 | |
162 | ((foo-x bar-j) 3) | |
163 | ((foo-y) 'bar)))) | |
164 | ||
165 | (pass-if-exception "set-fields on number" exception:wrong-type-arg | |
166 | (set-fields 4 | |
167 | ((foo-x bar-j) 3) | |
168 | ((foo-z) 'bar))) | |
169 | ||
ce650853 MW |
170 | (pass-if-equal "set-fields with unknown first getter" |
171 | '(syntax-error set-fields "unknown getter" | |
172 | (set-fields s ((bar-i foo-x) 1) ((blah) 3)) | |
173 | blah) | |
d9e36897 MW |
174 | (catch 'syntax-error |
175 | (lambda () | |
176 | (compile '(let ((s (make-bar (make-foo 5) 2))) | |
177 | (set-fields s ((bar-i foo-x) 1) ((blah) 3))) | |
178 | #:env (current-module)) | |
179 | #f) | |
180 | (lambda (key whom what src form subform) | |
ce650853 | 181 | (list key whom what form subform)))) |
d9e36897 | 182 | |
ce650853 MW |
183 | (pass-if-equal "set-fields with unknown second getter" |
184 | '(syntax-error set-fields "unknown getter" | |
185 | (set-fields s ((bar-i foo-x) 1) ((blah) 3)) | |
186 | blah) | |
d9e36897 MW |
187 | (catch 'syntax-error |
188 | (lambda () | |
189 | (compile '(let ((s (make-bar (make-foo 5) 2))) | |
190 | (set-fields s ((bar-i foo-x) 1) ((blah) 3))) | |
191 | #:env (current-module)) | |
192 | #f) | |
193 | (lambda (key whom what src form subform) | |
ce650853 MW |
194 | (list key whom what form subform)))) |
195 | ||
196 | (pass-if-equal "set-fields with duplicate field path" | |
197 | '(syntax-error set-fields "duplicate field path" | |
198 | (set-fields s | |
199 | ((bar-i foo-x) 1) | |
200 | ((bar-i foo-z) 2) | |
201 | ((bar-i foo-x) 3)) | |
202 | (bar-i foo-x)) | |
d9e36897 MW |
203 | (catch 'syntax-error |
204 | (lambda () | |
205 | (compile '(let ((s (make-bar (make-foo 5) 2))) | |
206 | (set-fields s | |
207 | ((bar-i foo-x) 1) | |
208 | ((bar-i foo-z) 2) | |
209 | ((bar-i foo-x) 3))) | |
210 | #:env (current-module)) | |
211 | #f) | |
212 | (lambda (key whom what src form subform) | |
ce650853 MW |
213 | (list key whom what form subform)))) |
214 | ||
215 | (pass-if-equal "set-fields with one path as a prefix of another" | |
216 | '(syntax-error set-fields | |
217 | "one field path is a prefix of another" | |
218 | (set-fields s | |
219 | ((bar-i foo-x) 1) | |
220 | ((bar-i foo-z) 2) | |
221 | ((bar-i) 3)) | |
222 | (bar-i)) | |
d9e36897 MW |
223 | (catch 'syntax-error |
224 | (lambda () | |
225 | (compile '(let ((s (make-bar (make-foo 5) 2))) | |
226 | (set-fields s | |
227 | ((bar-i foo-x) 1) | |
228 | ((bar-i foo-z) 2) | |
229 | ((bar-i) 3))) | |
230 | #:env (current-module)) | |
231 | #f) | |
232 | (lambda (key whom what src form subform) | |
ce650853 | 233 | (list key whom what form subform))))) |
531c9f1d | 234 | |
b075a6d7 LC |
235 | (with-test-prefix "side-effecting arguments" |
236 | ||
237 | (pass-if "predicate" | |
238 | (let ((x 0)) | |
239 | (and (foo? (begin (set! x (+ x 1)) f)) | |
240 | (= x 1))))) | |
241 | ||
531c9f1d | 242 | (with-test-prefix "non-toplevel" |
b075a6d7 | 243 | |
531c9f1d AR |
244 | (define-record-type :frotz (make-frotz a b) frotz? |
245 | (a frotz-a) (b frotz-b set-frotz-b!)) | |
246 | ||
247 | (pass-if "construction" | |
248 | (let ((frotz (make-frotz 1 2))) | |
249 | (and (= (frotz-a frotz) 1) | |
d9e36897 MW |
250 | (= (frotz-b frotz) 2)))) |
251 | ||
252 | (with-test-prefix "functional setters" | |
253 | (let () | |
254 | (define-record-type foo (make-foo x) foo? | |
255 | (x foo-x) | |
256 | (y foo-y set-foo-y!) | |
257 | (z foo-z set-foo-z!)) | |
258 | ||
259 | (define-record-type :bar (make-bar i j) bar? | |
260 | (i bar-i) | |
261 | (j bar-j set-bar-j!)) | |
262 | ||
263 | (pass-if "set-field" | |
264 | (let ((s (make-foo (make-bar 1 2)))) | |
3d01c19a | 265 | (and (equal? (set-field s (foo-x bar-j) 3) |
d9e36897 | 266 | (make-foo (make-bar 1 3))) |
3d01c19a | 267 | (equal? (set-field s (foo-z) 'bar) |
d9e36897 MW |
268 | (let ((s2 (make-foo (make-bar 1 2)))) |
269 | (set-foo-z! s2 'bar) | |
270 | s2)) | |
271 | (equal? s (make-foo (make-bar 1 2))))))) | |
272 | ||
3d01c19a | 273 | (pass-if "set-fieldss " |
d9e36897 MW |
274 | |
275 | (let ((s (make-foo (make-bar 1 2)))) | |
3d01c19a | 276 | (and (equal? (set-field s (foo-x bar-j) 3) |
d9e36897 MW |
277 | (make-foo (make-bar 1 3))) |
278 | (equal? (set-fields s | |
279 | ((foo-x bar-j) 3) | |
280 | ((foo-z) 'bar)) | |
281 | (let ((s2 (make-foo (make-bar 1 3)))) | |
282 | (set-foo-z! s2 'bar) | |
283 | s2)) | |
284 | (equal? s (make-foo (make-bar 1 2)))))))) | |
285 | ||
286 | \f | |
287 | (define-immutable-record-type :baz | |
288 | (make-baz x y z) | |
289 | baz? | |
290 | (x baz-x set-baz-x) | |
291 | (y baz-y set-baz-y) | |
292 | (z baz-z set-baz-z)) | |
293 | ||
294 | (define-immutable-record-type :address | |
295 | (make-address street city country) | |
296 | address? | |
297 | (street address-street) | |
298 | (city address-city) | |
299 | (country address-country)) | |
300 | ||
301 | (define-immutable-record-type :person | |
302 | (make-person age email address) | |
303 | person? | |
304 | (age person-age) | |
305 | (email person-email) | |
306 | (address person-address)) | |
307 | ||
308 | (with-test-prefix "define-immutable-record-type" | |
309 | ||
310 | (pass-if "get" | |
311 | (let ((b (make-baz 1 2 3))) | |
312 | (and (= (baz-x b) 1) | |
313 | (= (baz-y b) 2) | |
314 | (= (baz-z b) 3)))) | |
315 | ||
316 | (pass-if "get non-inlined" | |
317 | (let ((b (make-baz 1 2 3))) | |
318 | (equal? (map (cute apply <> (list b)) | |
319 | (list baz-x baz-y baz-z)) | |
320 | '(1 2 3)))) | |
321 | ||
322 | (pass-if "set" | |
323 | (let* ((b0 (make-baz 1 2 3)) | |
324 | (b1 (set-baz-x b0 11)) | |
325 | (b2 (set-baz-y b1 22)) | |
326 | (b3 (set-baz-z b2 33))) | |
327 | (and (= (baz-x b0) 1) | |
328 | (= (baz-x b1) 11) (= (baz-x b2) 11) (= (baz-x b3) 11) | |
329 | (= (baz-y b0) 2) (= (baz-y b1) 2) | |
330 | (= (baz-y b2) 22) (= (baz-y b3) 22) | |
331 | (= (baz-z b0) 3) (= (baz-z b1) 3) (= (baz-z b2) 3) | |
332 | (= (baz-z b3) 33)))) | |
333 | ||
334 | (pass-if "set non-inlined" | |
335 | (let ((set (compose (cut set-baz-x <> 1) | |
336 | (cut set-baz-y <> 2) | |
337 | (cut set-baz-z <> 3)))) | |
338 | (equal? (set (make-baz 0 0 0)) (make-baz 1 2 3)))) | |
339 | ||
340 | (pass-if "set-field" | |
341 | (let ((p (make-person 30 "foo@example.com" | |
342 | (make-address "Foo" "Paris" "France")))) | |
3d01c19a | 343 | (and (equal? (set-field p (person-address address-street) "Bar") |
d9e36897 MW |
344 | (make-person 30 "foo@example.com" |
345 | (make-address "Bar" "Paris" "France"))) | |
3d01c19a | 346 | (equal? (set-field p (person-email) "bar@example.com") |
d9e36897 MW |
347 | (make-person 30 "bar@example.com" |
348 | (make-address "Foo" "Paris" "France"))) | |
349 | (equal? p (make-person 30 "foo@example.com" | |
350 | (make-address "Foo" "Paris" "France")))))) | |
351 | ||
352 | (pass-if "set-fields" | |
353 | (let ((p (make-person 30 "foo@example.com" | |
354 | (make-address "Foo" "Paris" "France")))) | |
355 | (and (equal? (set-fields p | |
356 | ((person-email) "bar@example.com") | |
357 | ((person-address address-country) "Catalonia") | |
358 | ((person-address address-city) "Barcelona")) | |
359 | (make-person 30 "bar@example.com" | |
360 | (make-address "Foo" "Barcelona" "Catalonia"))) | |
361 | (equal? (set-fields p | |
362 | ((person-email) "bar@example.com") | |
363 | ((person-age) 20)) | |
364 | (make-person 20 "bar@example.com" | |
365 | (make-address "Foo" "Paris" "France"))) | |
366 | (equal? p (make-person 30 "foo@example.com" | |
367 | (make-address "Foo" "Paris" "France")))))) | |
368 | ||
369 | (with-test-prefix "non-toplevel" | |
370 | ||
371 | (pass-if "get" | |
372 | (let () | |
373 | (define-immutable-record-type bar | |
374 | (make-bar x y z) | |
375 | bar? | |
376 | (x bar-x) | |
377 | (y bar-y) | |
378 | (z bar-z set-bar-z)) | |
379 | ||
380 | (let ((b (make-bar 1 2 3))) | |
381 | (and (= (bar-x b) 1) | |
382 | (= (bar-y b) 2) | |
383 | (= (bar-z b) 3))))) | |
384 | ||
385 | (pass-if "get non-inlined" | |
386 | (let () | |
387 | (define-immutable-record-type bar | |
388 | (make-bar x y z) | |
389 | bar? | |
390 | (x bar-x) | |
391 | (y bar-y) | |
392 | (z bar-z set-bar-z)) | |
393 | ||
394 | (let ((b (make-bar 1 2 3))) | |
395 | (equal? (map (cute apply <> (list b)) | |
396 | (list bar-x bar-y bar-z)) | |
397 | '(1 2 3))))) | |
398 | ||
399 | (pass-if "set" | |
400 | (let () | |
401 | (define-immutable-record-type bar | |
402 | (make-bar x y z) | |
403 | bar? | |
404 | (x bar-x set-bar-x) | |
405 | (y bar-y set-bar-y) | |
406 | (z bar-z set-bar-z)) | |
407 | ||
408 | (let* ((b0 (make-bar 1 2 3)) | |
409 | (b1 (set-bar-x b0 11)) | |
410 | (b2 (set-bar-y b1 22)) | |
411 | (b3 (set-bar-z b2 33))) | |
412 | (and (= (bar-x b0) 1) | |
413 | (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11) | |
414 | (= (bar-y b0) 2) (= (bar-y b1) 2) | |
415 | (= (bar-y b2) 22) (= (bar-y b3) 22) | |
416 | (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3) | |
417 | (= (bar-z b3) 33))))) | |
418 | ||
419 | (pass-if "set non-inlined" | |
420 | (let () | |
421 | (define-immutable-record-type bar | |
422 | (make-bar x y z) | |
423 | bar? | |
424 | (x bar-x set-bar-x) | |
425 | (y bar-y set-bar-y) | |
426 | (z bar-z set-bar-z)) | |
427 | ||
428 | (let ((set (compose (cut set-bar-x <> 1) | |
429 | (cut set-bar-y <> 2) | |
430 | (cut set-bar-z <> 3)))) | |
431 | (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3))))) | |
432 | ||
433 | (pass-if "set-field" | |
434 | (let () | |
435 | (define-immutable-record-type address | |
436 | (make-address street city country) | |
437 | address? | |
438 | (street address-street) | |
439 | (city address-city) | |
440 | (country address-country)) | |
441 | ||
442 | (define-immutable-record-type :person | |
443 | (make-person age email address) | |
444 | person? | |
445 | (age person-age) | |
446 | (email person-email) | |
447 | (address person-address)) | |
448 | ||
449 | (let ((p (make-person 30 "foo@example.com" | |
450 | (make-address "Foo" "Paris" "France")))) | |
3d01c19a | 451 | (and (equal? (set-field p (person-address address-street) "Bar") |
d9e36897 MW |
452 | (make-person 30 "foo@example.com" |
453 | (make-address "Bar" "Paris" "France"))) | |
3d01c19a | 454 | (equal? (set-field p (person-email) "bar@example.com") |
d9e36897 MW |
455 | (make-person 30 "bar@example.com" |
456 | (make-address "Foo" "Paris" "France"))) | |
457 | (equal? p (make-person 30 "foo@example.com" | |
458 | (make-address "Foo" "Paris" "France"))))))) | |
459 | ||
460 | (pass-if "set-fields" | |
461 | (let () | |
462 | (define-immutable-record-type address | |
463 | (make-address street city country) | |
464 | address? | |
465 | (street address-street) | |
466 | (city address-city) | |
467 | (country address-country)) | |
468 | ||
469 | (define-immutable-record-type :person | |
470 | (make-person age email address) | |
471 | person? | |
472 | (age person-age) | |
473 | (email person-email) | |
474 | (address person-address)) | |
475 | ||
476 | (let ((p (make-person 30 "foo@example.com" | |
477 | (make-address "Foo" "Paris" "France")))) | |
478 | (and (equal? (set-fields p | |
479 | ((person-email) "bar@example.com") | |
480 | ((person-address address-country) "Catalonia") | |
481 | ((person-address address-city) "Barcelona")) | |
482 | (make-person 30 "bar@example.com" | |
483 | (make-address "Foo" "Barcelona" "Catalonia"))) | |
484 | (equal? (set-fields p | |
485 | ((person-email) "bar@example.com") | |
486 | ((person-age) 20)) | |
487 | (make-person 20 "bar@example.com" | |
488 | (make-address "Foo" "Paris" "France"))) | |
489 | (equal? p (make-person 30 "foo@example.com" | |
490 | (make-address "Foo" "Paris" "France"))))))) | |
491 | ||
ce650853 MW |
492 | (pass-if-equal "set-fields with unknown first getter" |
493 | '(syntax-error set-fields "unknown getter" | |
494 | (set-fields s ((bar-i foo-x) 1) ((blah) 3)) | |
495 | blah) | |
dfba1025 MW |
496 | (catch 'syntax-error |
497 | (lambda () | |
498 | (compile '(let () | |
499 | (define-immutable-record-type foo | |
500 | (make-foo x) | |
501 | foo? | |
502 | (x foo-x) | |
503 | (y foo-y set-foo-y) | |
504 | (z foo-z set-foo-z)) | |
505 | ||
506 | (define-immutable-record-type :bar | |
507 | (make-bar i j) | |
508 | bar? | |
509 | (i bar-i) | |
510 | (j bar-j set-bar-j)) | |
511 | ||
512 | (let ((s (make-bar (make-foo 5) 2))) | |
513 | (set-fields s ((bar-i foo-x) 1) ((blah) 3)))) | |
514 | #:env (current-module)) | |
515 | #f) | |
516 | (lambda (key whom what src form subform) | |
517 | (list key whom what form subform)))) | |
ce650853 MW |
518 | |
519 | (pass-if-equal "set-fields with unknown second getter" | |
520 | '(syntax-error set-fields "unknown getter" | |
521 | (set-fields s ((bar-i foo-x) 1) ((blah) 3)) | |
522 | blah) | |
dfba1025 MW |
523 | (catch 'syntax-error |
524 | (lambda () | |
525 | (compile '(let () | |
526 | (define-immutable-record-type foo | |
527 | (make-foo x) | |
528 | foo? | |
529 | (x foo-x) | |
530 | (y foo-y set-foo-y) | |
531 | (z foo-z set-foo-z)) | |
532 | ||
533 | (define-immutable-record-type :bar | |
534 | (make-bar i j) | |
535 | bar? | |
536 | (i bar-i) | |
537 | (j bar-j set-bar-j)) | |
538 | ||
539 | (let ((s (make-bar (make-foo 5) 2))) | |
540 | (set-fields s ((bar-i foo-x) 1) ((blah) 3)))) | |
541 | #:env (current-module)) | |
542 | #f) | |
543 | (lambda (key whom what src form subform) | |
544 | (list key whom what form subform)))) | |
ce650853 MW |
545 | |
546 | (pass-if-equal "set-fields with duplicate field path" | |
547 | '(syntax-error set-fields "duplicate field path" | |
548 | (set-fields s | |
549 | ((bar-i foo-x) 1) | |
550 | ((bar-i foo-z) 2) | |
551 | ((bar-i foo-x) 3)) | |
552 | (bar-i foo-x)) | |
dfba1025 MW |
553 | (catch 'syntax-error |
554 | (lambda () | |
555 | (compile '(let () | |
556 | (define-immutable-record-type foo | |
557 | (make-foo x) | |
558 | foo? | |
559 | (x foo-x) | |
560 | (y foo-y set-foo-y) | |
561 | (z foo-z set-foo-z)) | |
562 | ||
563 | (define-immutable-record-type :bar | |
564 | (make-bar i j) | |
565 | bar? | |
566 | (i bar-i) | |
567 | (j bar-j set-bar-j)) | |
568 | ||
569 | (let ((s (make-bar (make-foo 5) 2))) | |
ce650853 MW |
570 | (set-fields s |
571 | ((bar-i foo-x) 1) | |
572 | ((bar-i foo-z) 2) | |
dfba1025 MW |
573 | ((bar-i foo-x) 3)))) |
574 | #:env (current-module)) | |
575 | #f) | |
576 | (lambda (key whom what src form subform) | |
577 | (list key whom what form subform)))) | |
ce650853 MW |
578 | |
579 | (pass-if-equal "set-fields with one path as a prefix of another" | |
580 | '(syntax-error set-fields | |
581 | "one field path is a prefix of another" | |
d9e36897 MW |
582 | (set-fields s |
583 | ((bar-i foo-x) 1) | |
584 | ((bar-i foo-z) 2) | |
ce650853 MW |
585 | ((bar-i) 3)) |
586 | (bar-i)) | |
dfba1025 MW |
587 | (catch 'syntax-error |
588 | (lambda () | |
589 | (compile '(let () | |
590 | (define-immutable-record-type foo | |
591 | (make-foo x) | |
592 | foo? | |
593 | (x foo-x) | |
594 | (y foo-y set-foo-y) | |
595 | (z foo-z set-foo-z)) | |
596 | ||
597 | (define-immutable-record-type :bar | |
598 | (make-bar i j) | |
599 | bar? | |
600 | (i bar-i) | |
601 | (j bar-j set-bar-j)) | |
602 | ||
603 | (let ((s (make-bar (make-foo 5) 2))) | |
ce650853 MW |
604 | (set-fields s |
605 | ((bar-i foo-x) 1) | |
606 | ((bar-i foo-z) 2) | |
dfba1025 MW |
607 | ((bar-i) 3)))) |
608 | #:env (current-module)) | |
92fac8c0 MW |
609 | #f) |
610 | (lambda (key whom what src form subform) | |
611 | (list key whom what form subform)))) | |
612 | ||
613 | (pass-if-equal "incompatible field paths" | |
614 | '(syntax-error set-fields | |
615 | "\ | |
616 | field paths (bar-i bar-j) and (bar-i foo-x) require one object \ | |
b5949983 | 617 | to belong to two different record types (bar and foo)" |
92fac8c0 MW |
618 | (set-fields s |
619 | ((bar-i foo-x) 1) | |
620 | ((bar-i bar-j) 2) | |
621 | ((bar-j) 3)) | |
622 | #f) | |
623 | (catch 'syntax-error | |
624 | (lambda () | |
625 | (compile '(let () | |
626 | (define-immutable-record-type foo | |
627 | (make-foo x) | |
628 | foo? | |
629 | (x foo-x) | |
630 | (y foo-y set-foo-y) | |
631 | (z foo-z set-foo-z)) | |
632 | ||
b5949983 | 633 | (define-immutable-record-type bar |
92fac8c0 MW |
634 | (make-bar i j) |
635 | bar? | |
636 | (i bar-i) | |
637 | (j bar-j set-bar-j)) | |
638 | ||
639 | (let ((s (make-bar (make-foo 5) 2))) | |
640 | (set-fields s | |
641 | ((bar-i foo-x) 1) | |
642 | ((bar-i bar-j) 2) | |
643 | ((bar-j) 3)))) | |
644 | #:env (current-module)) | |
dfba1025 MW |
645 | #f) |
646 | (lambda (key whom what src form subform) | |
647 | (list key whom what form subform)))))) | |
5ef102cc | 648 | |
f31a0762 MW |
649 | \f |
650 | (with-test-prefix "record type definition error reporting" | |
651 | ||
652 | (pass-if-equal "invalid type name" | |
653 | '(syntax-error define-immutable-record-type | |
654 | "expected type name" | |
655 | (define-immutable-record-type | |
656 | (foobar x y) | |
657 | foobar? | |
658 | (x foobar-x) | |
659 | (y foobar-y)) | |
660 | (foobar x y)) | |
661 | (catch 'syntax-error | |
662 | (lambda () | |
663 | (compile '(define-immutable-record-type | |
664 | (foobar x y) | |
665 | foobar? | |
666 | (x foobar-x) | |
667 | (y foobar-y)) | |
668 | #:env (current-module)) | |
669 | #f) | |
670 | (lambda (key whom what src form subform) | |
671 | (list key whom what form subform)))) | |
672 | ||
673 | (pass-if-equal "invalid constructor spec" | |
674 | '(syntax-error define-immutable-record-type | |
675 | "invalid constructor spec" | |
676 | (define-immutable-record-type :foobar | |
677 | (make-foobar x y 3) | |
678 | foobar? | |
679 | (x foobar-x) | |
680 | (y foobar-y)) | |
681 | (make-foobar x y 3)) | |
682 | (catch 'syntax-error | |
683 | (lambda () | |
684 | (compile '(define-immutable-record-type :foobar | |
685 | (make-foobar x y 3) | |
686 | foobar? | |
687 | (x foobar-x) | |
688 | (y foobar-y)) | |
689 | #:env (current-module)) | |
690 | #f) | |
691 | (lambda (key whom what src form subform) | |
692 | (list key whom what form subform)))) | |
693 | ||
694 | (pass-if-equal "invalid predicate name" | |
695 | '(syntax-error define-immutable-record-type | |
696 | "expected predicate name" | |
697 | (define-immutable-record-type :foobar | |
698 | (foobar x y) | |
699 | (x foobar-x) | |
700 | (y foobar-y)) | |
701 | (x foobar-x)) | |
702 | (catch 'syntax-error | |
703 | (lambda () | |
704 | (compile '(define-immutable-record-type :foobar | |
705 | (foobar x y) | |
706 | (x foobar-x) | |
707 | (y foobar-y)) | |
708 | #:env (current-module)) | |
709 | #f) | |
710 | (lambda (key whom what src form subform) | |
711 | (list key whom what form subform)))) | |
712 | ||
713 | (pass-if-equal "invalid field spec" | |
714 | '(syntax-error define-record-type | |
715 | "invalid field spec" | |
716 | (define-record-type :foobar | |
717 | (make-foobar x y) | |
718 | foobar? | |
719 | (x) | |
720 | (y foobar-y)) | |
721 | (x)) | |
722 | (catch 'syntax-error | |
723 | (lambda () | |
724 | (compile '(define-record-type :foobar | |
725 | (make-foobar x y) | |
726 | foobar? | |
727 | (x) | |
728 | (y foobar-y)) | |
729 | #:env (current-module)) | |
730 | #f) | |
731 | (lambda (key whom what src form subform) | |
732 | (list key whom what form subform)))) | |
733 | ||
734 | (pass-if-equal "unknown field in constructor spec" | |
735 | '(syntax-error define-record-type | |
736 | "unknown field in constructor spec" | |
737 | (define-record-type :foobar | |
738 | (make-foobar x z) | |
739 | foobar? | |
740 | (x foobar-x) | |
741 | (y foobar-y)) | |
742 | z) | |
743 | (catch 'syntax-error | |
744 | (lambda () | |
745 | (compile '(define-record-type :foobar | |
746 | (make-foobar x z) | |
747 | foobar? | |
748 | (x foobar-x) | |
749 | (y foobar-y)) | |
750 | #:env (current-module)) | |
751 | #f) | |
752 | (lambda (key whom what src form subform) | |
753 | (list key whom what form subform))))) | |
754 | ||
5ef102cc LC |
755 | (with-test-prefix "record compatibility" |
756 | ||
757 | (pass-if "record?" | |
758 | (record? (make-foo 1))) | |
759 | ||
760 | (pass-if "record-constructor" | |
761 | (equal? ((record-constructor :foo) 1) | |
762 | (make-foo 1)))) | |
d9e36897 MW |
763 | |
764 | ;;; Local Variables: | |
765 | ;;; mode: scheme | |
766 | ;;; eval: (put 'set-fields 'scheme-indent-function 1) | |
767 | ;;; End: |