Commit | Line | Data |
---|---|---|
4ed29c73 MV |
1 | ;;;; goops.test --- test suite for GOOPS -*- scheme -*- |
2 | ;;;; | |
5b763233 | 3 | ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015 Free Software Foundation, Inc. |
4ed29c73 | 4 | ;;;; |
53befeb7 NJ |
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 3 of the License, or (at your option) any later version. | |
4ed29c73 | 9 | ;;;; |
53befeb7 | 10 | ;;;; This library is distributed in the hope that it will be useful, |
4ed29c73 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
4ed29c73 | 14 | ;;;; |
53befeb7 NJ |
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 | |
4ed29c73 | 18 | |
62ed3710 | 19 | (define-module (test-suite test-goops) |
82d8d6d9 LC |
20 | #:use-module (test-suite lib) |
21 | #:autoload (srfi srfi-1) (unfold)) | |
4ed29c73 | 22 | |
2aecf4cf AW |
23 | (define exception:no-applicable-method |
24 | '(goops-error . "^No applicable method")) | |
25 | ||
4ed29c73 MV |
26 | (pass-if "GOOPS loads" |
27 | (false-if-exception | |
28 | (begin (resolve-module '(oop goops)) | |
29 | #t))) | |
30 | ||
31 | (use-modules (oop goops)) | |
32 | ||
33 | ;;; more tests here... | |
bdd2c6f4 DH |
34 | |
35 | (with-test-prefix "basic classes" | |
36 | ||
37 | (with-test-prefix "<top>" | |
38 | ||
39 | (pass-if "instance?" | |
40 | (instance? <top>)) | |
41 | ||
42 | (pass-if "class-of" | |
43 | (eq? (class-of <top>) <class>)) | |
44 | ||
45 | (pass-if "is a class?" | |
46 | (is-a? <top> <class>)) | |
47 | ||
48 | (pass-if "class-name" | |
49 | (eq? (class-name <top>) '<top>)) | |
50 | ||
51 | (pass-if "direct superclasses" | |
52 | (equal? (class-direct-supers <top>) '())) | |
53 | ||
54 | (pass-if "superclasses" | |
55 | (equal? (class-precedence-list <top>) (list <top>))) | |
56 | ||
57 | (pass-if "direct slots" | |
58 | (equal? (class-direct-slots <top>) '())) | |
59 | ||
60 | (pass-if "slots" | |
61 | (equal? (class-slots <top>) '()))) | |
62 | ||
63 | (with-test-prefix "<object>" | |
64 | ||
65 | (pass-if "instance?" | |
66 | (instance? <object>)) | |
67 | ||
68 | (pass-if "class-of" | |
69 | (eq? (class-of <object>) <class>)) | |
70 | ||
71 | (pass-if "is a class?" | |
72 | (is-a? <object> <class>)) | |
73 | ||
74 | (pass-if "class-name" | |
75 | (eq? (class-name <object>) '<object>)) | |
76 | ||
77 | (pass-if "direct superclasses" | |
78 | (equal? (class-direct-supers <object>) (list <top>))) | |
79 | ||
80 | (pass-if "superclasses" | |
81 | (equal? (class-precedence-list <object>) (list <object> <top>))) | |
82 | ||
83 | (pass-if "direct slots" | |
84 | (equal? (class-direct-slots <object>) '())) | |
85 | ||
86 | (pass-if "slots" | |
87 | (equal? (class-slots <object>) '()))) | |
88 | ||
89 | (with-test-prefix "<class>" | |
90 | ||
91 | (pass-if "instance?" | |
92 | (instance? <class>)) | |
93 | ||
94 | (pass-if "class-of" | |
95 | (eq? (class-of <class>) <class>)) | |
96 | ||
97 | (pass-if "is a class?" | |
98 | (is-a? <class> <class>)) | |
99 | ||
100 | (pass-if "class-name" | |
101 | (eq? (class-name <class>) '<class>)) | |
102 | ||
103 | (pass-if "direct superclass" | |
57b1d518 MD |
104 | (equal? (class-direct-supers <class>) (list <object>)))) |
105 | ||
106 | (with-test-prefix "class-precedence-list" | |
107 | (for-each (lambda (class) | |
108 | (run-test (if (slot-bound? class 'name) | |
109 | (class-name class) | |
110 | (with-output-to-string | |
111 | (lambda () | |
112 | (display class)))) | |
113 | #t | |
114 | (lambda () | |
115 | (catch #t | |
116 | (lambda () | |
117 | (equal? (class-precedence-list class) | |
118 | (compute-cpl class))) | |
119 | (lambda args #t))))) | |
120 | (let ((table (make-hash-table))) | |
121 | (let rec ((class <top>)) | |
122 | (hash-create-handle! table class #f) | |
123 | (for-each rec (class-direct-subclasses class))) | |
124 | (hash-fold (lambda (class ignore classes) | |
125 | (cons class classes)) | |
126 | '() | |
127 | table)))) | |
128 | ) | |
9f045403 | 129 | |
510d7877 LC |
130 | (with-test-prefix "classes for built-in types" |
131 | ||
132 | (pass-if "subr" | |
133 | (eq? (class-of fluid-ref) <procedure>)) | |
134 | ||
135 | (pass-if "gsubr" | |
136 | (eq? (class-of hashq-ref) <procedure>)) | |
137 | ||
138 | (pass-if "car" | |
139 | (eq? (class-of car) <procedure>)) | |
140 | ||
141 | (pass-if "string" | |
142 | (eq? (class-of "foo") <string>)) | |
143 | ||
144 | (pass-if "port" | |
288bbc44 LC |
145 | (is-a? (%make-void-port "w") <port>)) |
146 | ||
147 | (pass-if "struct vtable" | |
148 | ;; Previously, `class-of' would fail for nameless structs, i.e., structs | |
149 | ;; for which `struct-vtable-name' is #f. | |
07e6d2d4 AW |
150 | (is-a? (class-of (make-vtable |
151 | (string-append standard-vtable-fields "prprpr"))) | |
152 | <class>))) | |
510d7877 LC |
153 | |
154 | ||
9f045403 DH |
155 | (with-test-prefix "defining classes" |
156 | ||
157 | (with-test-prefix "define-class" | |
158 | ||
159 | (pass-if "creating a new binding" | |
62ed3710 DH |
160 | (if (eval '(defined? '<foo-0>) (current-module)) |
161 | (throw 'unresolved)) | |
162 | (eval '(define-class <foo-0> ()) (current-module)) | |
163 | (eval '(is-a? <foo-0> <class>) (current-module))) | |
9f045403 DH |
164 | |
165 | (pass-if "overwriting a binding to a non-class" | |
166 | (eval '(define <foo> #f) (current-module)) | |
167 | (eval '(define-class <foo> ()) (current-module)) | |
47cd67db MD |
168 | (eval '(is-a? <foo> <class>) (current-module))) |
169 | ||
170 | (expect-fail "bad init-thunk" | |
5f161164 | 171 | (begin |
5f161164 AW |
172 | (catch #t |
173 | (lambda () | |
174 | (eval '(define-class <foo> () | |
175 | (x #:init-thunk (lambda (x) 1))) | |
176 | (current-module)) | |
177 | #t) | |
178 | (lambda args | |
179 | #f)))) | |
cac39600 LC |
180 | |
181 | (pass-if "interaction with `struct-ref'" | |
182 | (eval '(define-class <class-struct> () | |
183 | (foo #:init-keyword #:foo) | |
184 | (bar #:init-keyword #:bar)) | |
185 | (current-module)) | |
186 | (eval '(let ((x (make <class-struct> | |
187 | #:foo 'hello | |
188 | #:bar 'world))) | |
189 | (and (struct? x) | |
190 | (eq? (struct-ref x 0) 'hello) | |
191 | (eq? (struct-ref x 1) 'world))) | |
192 | (current-module))) | |
193 | ||
194 | (pass-if "interaction with `struct-set!'" | |
195 | (eval '(define-class <class-struct-2> () | |
196 | (foo) (bar)) | |
197 | (current-module)) | |
198 | (eval '(let ((x (make <class-struct-2>))) | |
199 | (struct-set! x 0 'hello) | |
200 | (struct-set! x 1 'world) | |
201 | (and (struct? x) | |
202 | (eq? (struct-ref x 0) 'hello) | |
203 | (eq? (struct-ref x 1) 'world))) | |
5192c9e8 AW |
204 | (current-module))) |
205 | ||
206 | (pass-if "with accessors" | |
207 | (eval '(define-class <qux> () | |
208 | (x #:accessor x #:init-value 123) | |
209 | (z #:accessor z #:init-value 789)) | |
210 | (current-module)) | |
13d807b7 AW |
211 | (eval '(equal? (x (make <qux>)) 123) (current-module))) |
212 | ||
213 | (pass-if-exception "cannot redefine fields of <class>" | |
214 | '(misc-error . "cannot be redefined") | |
215 | (eval '(begin | |
216 | (define-class <test-class> (<class>) | |
217 | name) | |
218 | (make <test-class>)) | |
219 | (current-module))))) | |
33e04d54 DH |
220 | |
221 | (with-test-prefix "defining generics" | |
222 | ||
223 | (with-test-prefix "define-generic" | |
224 | ||
225 | (pass-if "creating a new top-level binding" | |
62ed3710 DH |
226 | (if (eval '(defined? 'foo-0) (current-module)) |
227 | (throw 'unresolved)) | |
228 | (eval '(define-generic foo-0) (current-module)) | |
229 | (eval '(and (is-a? foo-0 <generic>) | |
230 | (null? (generic-function-methods foo-0))) | |
33e04d54 DH |
231 | (current-module))) |
232 | ||
233 | (pass-if "overwriting a top-level binding to a non-generic" | |
234 | (eval '(define (foo) #f) (current-module)) | |
235 | (eval '(define-generic foo) (current-module)) | |
236 | (eval '(and (is-a? foo <generic>) | |
237 | (= 1 (length (generic-function-methods foo)))) | |
238 | (current-module))) | |
239 | ||
240 | (pass-if "overwriting a top-level binding to a generic" | |
241 | (eval '(define (foo) #f) (current-module)) | |
242 | (eval '(define-generic foo) (current-module)) | |
243 | (eval '(define-generic foo) (current-module)) | |
244 | (eval '(and (is-a? foo <generic>) | |
245 | (null? (generic-function-methods foo))) | |
534491d0 AW |
246 | (current-module))) |
247 | ||
248 | (pass-if-exception "getters do not have setters" | |
249 | exception:wrong-type-arg | |
250 | (eval '(setter foo) (current-module))))) | |
33e04d54 | 251 | |
b1f57ea4 LC |
252 | (with-test-prefix "defining methods" |
253 | ||
254 | (pass-if "define-method" | |
255 | (let ((m (current-module))) | |
256 | (eval '(define-method (my-plus (s1 <string>) (s2 <string>)) | |
257 | (string-append s1 s2)) | |
258 | m) | |
259 | (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>)) | |
260 | (+ i1 i2)) | |
261 | m) | |
262 | (eval '(and (is-a? my-plus <generic>) | |
263 | (= (length (generic-function-methods my-plus)) | |
264 | 2)) | |
265 | m))) | |
266 | ||
267 | (pass-if "method-more-specific?" | |
268 | (eval '(let* ((m+ (generic-function-methods my-plus)) | |
269 | (m1 (car m+)) | |
270 | (m2 (cadr m+)) | |
271 | (arg-types (list <string> <string>))) | |
272 | (if (memq <string> (method-specializers m1)) | |
273 | (method-more-specific? m1 m2 arg-types) | |
274 | (method-more-specific? m2 m1 arg-types))) | |
275 | (current-module))) | |
276 | ||
277 | (pass-if-exception "method-more-specific? (failure)" | |
278 | exception:wrong-type-arg | |
279 | (eval '(let* ((m+ (generic-function-methods my-plus)) | |
280 | (m1 (car m+)) | |
281 | (m2 (cadr m+))) | |
282 | (method-more-specific? m1 m2 '())) | |
283 | (current-module)))) | |
284 | ||
4bcc952d AW |
285 | (with-test-prefix "the method cache" |
286 | (pass-if "defining a method with a rest arg" | |
287 | (let ((m (current-module))) | |
288 | (eval '(define-method (foo bar . baz) | |
289 | (cons bar baz)) | |
290 | m) | |
291 | (eval '(foo 1) | |
292 | m) | |
293 | (eval '(foo 1 2) | |
294 | m) | |
295 | (eval '(equal? (foo 1 2) '(1 2)) | |
296 | m)))) | |
297 | ||
33e04d54 DH |
298 | (with-test-prefix "defining accessors" |
299 | ||
300 | (with-test-prefix "define-accessor" | |
301 | ||
302 | (pass-if "creating a new top-level binding" | |
62ed3710 DH |
303 | (if (eval '(defined? 'foo-1) (current-module)) |
304 | (throw 'unresolved)) | |
305 | (eval '(define-accessor foo-1) (current-module)) | |
306 | (eval '(and (is-a? foo-1 <generic-with-setter>) | |
307 | (null? (generic-function-methods foo-1))) | |
33e04d54 DH |
308 | (current-module))) |
309 | ||
534491d0 AW |
310 | (pass-if "accessors have setters" |
311 | (procedure? (eval '(setter foo-1) (current-module)))) | |
312 | ||
33e04d54 DH |
313 | (pass-if "overwriting a top-level binding to a non-accessor" |
314 | (eval '(define (foo) #f) (current-module)) | |
315 | (eval '(define-accessor foo) (current-module)) | |
316 | (eval '(and (is-a? foo <generic-with-setter>) | |
317 | (= 1 (length (generic-function-methods foo)))) | |
318 | (current-module))) | |
319 | ||
320 | (pass-if "overwriting a top-level binding to an accessor" | |
321 | (eval '(define (foo) #f) (current-module)) | |
322 | (eval '(define-accessor foo) (current-module)) | |
323 | (eval '(define-accessor foo) (current-module)) | |
324 | (eval '(and (is-a? foo <generic-with-setter>) | |
325 | (null? (generic-function-methods foo))) | |
326 | (current-module))))) | |
58241edc MD |
327 | |
328 | (with-test-prefix "object update" | |
329 | (pass-if "defining class" | |
330 | (eval '(define-class <foo> () | |
331 | (x #:accessor x #:init-value 123) | |
332 | (z #:accessor z #:init-value 789)) | |
333 | (current-module)) | |
334 | (eval '(is-a? <foo> <class>) (current-module))) | |
335 | (pass-if "making instance" | |
336 | (eval '(define foo (make <foo>)) (current-module)) | |
337 | (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module))) | |
338 | (pass-if "redefining class" | |
339 | (eval '(define-class <foo> () | |
340 | (x #:accessor x #:init-value 123) | |
341 | (y #:accessor y #:init-value 456) | |
342 | (z #:accessor z #:init-value 789)) | |
343 | (current-module)) | |
82d8d6d9 LC |
344 | (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))) |
345 | ||
346 | (pass-if "changing class" | |
347 | (let* ((c1 (class () (the-slot #:init-keyword #:value))) | |
348 | (c2 (class () (the-slot #:init-keyword #:value) | |
349 | (the-other-slot #:init-value 888))) | |
350 | (o1 (make c1 #:value 777))) | |
351 | (and (is-a? o1 c1) | |
352 | (not (is-a? o1 c2)) | |
353 | (equal? (slot-ref o1 'the-slot) 777) | |
354 | (let ((o2 (change-class o1 c2))) | |
355 | (and (eq? o1 o2) | |
356 | (is-a? o2 c2) | |
357 | (not (is-a? o2 c1)) | |
358 | (equal? (slot-ref o2 'the-slot) 777)))))) | |
359 | ||
360 | (pass-if "`hell' in `goops.c' grows as expected" | |
361 | ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c' | |
362 | ;; fix (i.e., Guile 1.8.5 and earlier). The root of the problem was | |
363 | ;; that `go_to_hell ()' would not reallocate enough room for the `hell' | |
364 | ;; array, leading to out-of-bounds accesses. | |
365 | ||
366 | (let* ((parent-class (class () | |
367 | #:name '<class-that-will-be-redefined>)) | |
368 | (classes | |
369 | (unfold (lambda (i) (>= i 20)) | |
370 | (lambda (i) | |
371 | (make-class (list parent-class) | |
372 | '((the-slot #:init-value #:value) | |
373 | (the-other-slot)) | |
374 | #:name (string->symbol | |
375 | (string-append "<foo-to-redefine-" | |
376 | (number->string i) | |
377 | ">")))) | |
378 | (lambda (i) | |
379 | (+ 1 i)) | |
380 | 0)) | |
381 | (objects | |
382 | (map (lambda (class) | |
383 | (make class #:value 777)) | |
384 | classes))) | |
385 | ||
386 | (define-method (change-class (foo parent-class) | |
387 | (new <class>)) | |
388 | ;; Called by `scm_change_object_class ()', via `purgatory ()'. | |
389 | (if (null? classes) | |
390 | (next-method) | |
391 | (let ((class (car classes)) | |
392 | (object (car objects))) | |
393 | (set! classes (cdr classes)) | |
394 | (set! objects (cdr objects)) | |
395 | ||
396 | ;; Redefine the class so that its instances are eventually | |
397 | ;; passed to `scm_change_object_class ()'. This leads to | |
398 | ;; nested `scm_change_object_class ()' calls, which increases | |
399 | ;; the size of HELL and increments N_HELL. | |
400 | (class-redefinition class | |
401 | (make-class '() (class-slots class) | |
402 | #:name (class-name class))) | |
403 | ||
404 | ;; Use `slot-ref' to trigger the `scm_change_object_class ()' | |
405 | ;; and `go_to_hell ()' calls. | |
406 | (slot-ref object 'the-slot) | |
407 | ||
408 | (next-method)))) | |
409 | ||
410 | ||
411 | ;; Initiate the whole `change-class' chain. | |
412 | (let* ((class (car classes)) | |
413 | (object (change-class (car objects) class))) | |
414 | (is-a? object class))))) | |
58241edc | 415 | |
47cd67db MD |
416 | (with-test-prefix "object comparison" |
417 | (pass-if "default method" | |
57b1d518 MD |
418 | (eval '(begin |
419 | (define-class <c> () | |
420 | (x #:accessor x #:init-keyword #:x) | |
421 | (y #:accessor y #:init-keyword #:y)) | |
47cd67db MD |
422 | (define o1 (make <c> #:x '(1) #:y '(2))) |
423 | (define o2 (make <c> #:x '(1) #:y '(3))) | |
424 | (define o3 (make <c> #:x '(4) #:y '(3))) | |
425 | (define o4 (make <c> #:x '(4) #:y '(3))) | |
426 | (not (eqv? o1 o2))) | |
427 | (current-module))) | |
47cd67db MD |
428 | (pass-if "equal?" |
429 | (eval '(begin | |
57b1d518 MD |
430 | (define-method (equal? (a <c>) (b <c>)) |
431 | (equal? (y a) (y b))) | |
47cd67db | 432 | (equal? o2 o3)) |
57b1d518 | 433 | (current-module))) |
47cd67db MD |
434 | (pass-if "not equal?" |
435 | (eval '(not (equal? o1 o2)) | |
436 | (current-module))) | |
437 | (pass-if "=" | |
438 | (eval '(begin | |
439 | (define-method (= (a <c>) (b <c>)) | |
440 | (and (equal? (x a) (x b)) | |
441 | (equal? (y a) (y b)))) | |
442 | (= o3 o4)) | |
443 | (current-module))) | |
444 | (pass-if "not =" | |
445 | (eval '(not (= o1 o2)) | |
446 | (current-module))) | |
447 | ) | |
57b1d518 | 448 | |
58241edc MD |
449 | (use-modules (oop goops active-slot)) |
450 | ||
451 | (with-test-prefix "active-slot" | |
452 | (pass-if "defining class with active slot" | |
453 | (eval '(begin | |
454 | (define z '()) | |
455 | (define-class <bar> () | |
456 | (x #:accessor x | |
457 | #:init-value 1 | |
458 | #:allocation #:active | |
459 | #:before-slot-ref | |
460 | (lambda (o) | |
461 | (set! z (cons 'before-ref z)) | |
462 | #t) | |
463 | #:after-slot-ref | |
464 | (lambda (o) | |
465 | (set! z (cons 'after-ref z))) | |
466 | #:before-slot-set! | |
467 | (lambda (o v) | |
468 | (set! z (cons* v 'before-set! z))) | |
469 | #:after-slot-set! | |
470 | (lambda (o v) | |
471 | (set! z (cons* v (x o) 'after-set! z)))) | |
472 | #:metaclass <active-class>) | |
473 | (define bar (make <bar>)) | |
474 | (x bar) | |
475 | (set! (x bar) 2) | |
476 | (equal? (reverse z) | |
48ad85fb AW |
477 | '(before-set! 1 before-ref after-ref |
478 | after-set! 1 1 before-ref after-ref | |
479 | before-set! 2 before-ref after-ref after-set! 2 2))) | |
58241edc MD |
480 | (current-module)))) |
481 | ||
47cd67db MD |
482 | (use-modules (oop goops composite-slot)) |
483 | ||
484 | (with-test-prefix "composite-slot" | |
485 | (pass-if "creating instance with propagated slot" | |
486 | (eval '(begin | |
487 | (define-class <a> () | |
488 | (x #:accessor x #:init-keyword #:x) | |
489 | (y #:accessor y #:init-keyword #:y)) | |
490 | (define-class <c> () | |
491 | (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2)) | |
492 | (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4)) | |
493 | (x #:accessor x | |
494 | #:allocation #:propagated | |
495 | #:propagate-to '(o1 (o2 y))) | |
496 | #:metaclass <composite-class>) | |
497 | (define o (make <c>)) | |
498 | (is-a? o <c>)) | |
499 | (current-module))) | |
500 | (pass-if "reading propagated slot" | |
501 | (eval '(= (x o) 1) (current-module))) | |
502 | (pass-if "writing propagated slot" | |
503 | (eval '(begin | |
504 | (set! (x o) 5) | |
505 | (and (= (x (o1 o)) 5) | |
506 | (= (y (o1 o)) 2) | |
507 | (= (x (o2 o)) 3) | |
508 | (= (y (o2 o)) 5))) | |
509 | (current-module)))) | |
2aecf4cf AW |
510 | |
511 | (with-test-prefix "no-applicable-method" | |
512 | (pass-if-exception "calling generic, no methods" | |
513 | exception:no-applicable-method | |
514 | (eval '(begin | |
515 | (define-class <qux> ()) | |
516 | (define-generic quxy) | |
517 | (quxy 1)) | |
518 | (current-module))) | |
519 | (pass-if "calling generic, one method, applicable" | |
520 | (eval '(begin | |
521 | (define-method (quxy (q <qux>)) | |
522 | #t) | |
523 | (define q (make <qux>)) | |
524 | (quxy q)) | |
525 | (current-module))) | |
526 | (pass-if-exception "calling generic, one method, not applicable" | |
527 | exception:no-applicable-method | |
528 | (eval '(quxy 1) | |
529 | (current-module)))) | |
48ad85fb AW |
530 | |
531 | (with-test-prefix "foreign slots" | |
532 | (define-class <foreign-test> () | |
533 | (a #:init-keyword #:a #:class <foreign-slot> | |
534 | #:accessor test-a) | |
535 | (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot> | |
536 | #:accessor test-b)) | |
537 | ||
538 | (pass-if-equal "constructing, no initargs" | |
539 | '(0 3) | |
540 | (let ((x (make <foreign-test>))) | |
541 | (list (slot-ref x 'a) | |
542 | (slot-ref x 'b)))) | |
543 | ||
544 | (pass-if-equal "constructing, initargs" | |
545 | '(1 2) | |
546 | (let ((x (make <foreign-test> #:a 1 #:b 2))) | |
547 | (list (slot-ref x 'a) | |
548 | (slot-ref x 'b)))) | |
549 | ||
550 | (pass-if-equal "getters" | |
551 | '(0 3) | |
552 | (let ((x (make <foreign-test>))) | |
553 | (list (test-a x) (test-b x)))) | |
554 | ||
555 | (pass-if-equal "setters" | |
556 | '(10 20) | |
557 | (let ((x (make <foreign-test>))) | |
558 | (set! (test-a x) 10) | |
559 | (set! (test-b x) 20) | |
560 | (list (test-a x) (test-b x)))) | |
561 | ||
562 | (pass-if-exception "out of range" | |
563 | exception:out-of-range | |
564 | (make <foreign-test> #:a (ash 1 64)))) | |
5b763233 AW |
565 | |
566 | (with-test-prefix "#:each-subclass" | |
567 | (let* ((<subclass-allocation-test> | |
568 | (class () | |
569 | (test #:init-value '() #:allocation #:each-subclass) | |
570 | #:name '<subclass-allocation-test>)) | |
571 | (a (make <subclass-allocation-test>))) | |
572 | (pass-if-equal '() (slot-ref a 'test)) | |
573 | (let ((b (make <subclass-allocation-test>))) | |
574 | (pass-if-equal '() (slot-ref b 'test)) | |
575 | (slot-set! a 'test 100) | |
576 | (pass-if-equal 100 (slot-ref a 'test)) | |
577 | (pass-if-equal 100 (slot-ref b 'test)) | |
578 | ||
579 | ;; #:init-value of the class shouldn't reinitialize slot when | |
580 | ;; instances are allocated. | |
581 | (make <subclass-allocation-test>) | |
582 | ||
583 | (pass-if-equal 100 (slot-ref a 'test)) | |
584 | (pass-if-equal 100 (slot-ref b 'test)) | |
585 | ||
586 | (let ((<test-subclass> | |
587 | (class (<subclass-allocation-test>)))) | |
588 | (pass-if-equal 100 (slot-ref a 'test)) | |
589 | (pass-if-equal 100 (slot-ref b 'test)) | |
590 | (let ((c (make <test-subclass>))) | |
591 | (pass-if-equal 100 (slot-ref a 'test)) | |
592 | (pass-if-equal 100 (slot-ref b 'test)) | |
593 | (pass-if-equal '() (slot-ref c 'test)) | |
594 | (slot-set! c 'test 200) | |
595 | (pass-if-equal 200 (slot-ref c 'test)) | |
596 | ||
597 | (make <test-subclass>) | |
598 | ||
599 | (pass-if-equal 100 (slot-ref a 'test)) | |
600 | (pass-if-equal 100 (slot-ref b 'test)) | |
601 | (pass-if-equal 200 (slot-ref c 'test))))))) | |
583a23bf AW |
602 | |
603 | (with-test-prefix "accessor slots" | |
604 | (let* ((a-accessor (make-accessor 'a)) | |
605 | (b-accessor (make-accessor 'b)) | |
606 | (<a> (class () | |
607 | (a #:init-keyword #:a #:accessor a-accessor) | |
608 | #:name '<a>)) | |
609 | (<b> (class () | |
610 | (b #:init-keyword #:b #:accessor b-accessor) | |
611 | #:name '<b>)) | |
612 | (<ab> (class (<a> <b>) #:name '<ab>)) | |
613 | (<ba> (class (<b> <a>) #:name '<ba>)) | |
614 | (<cab> (class (<ab>) | |
615 | (a #:init-keyword #:a) | |
616 | #:name '<cab>)) | |
617 | (<cba> (class (<ba>) | |
618 | (a #:init-keyword #:a) | |
619 | #:name '<cba>)) | |
620 | (a (make <a> #:a 'a)) | |
621 | (b (make <b> #:b 'b)) | |
622 | (ab (make <ab> #:a 'a #:b 'b)) | |
623 | (ba (make <ba> #:a 'a #:b 'b)) | |
624 | (cab (make <cab> #:a 'a #:b 'b)) | |
625 | (cba (make <cba> #:a 'a #:b 'b))) | |
626 | (pass-if-equal "a accessor on a" 'a (a-accessor a)) | |
627 | (pass-if-equal "a accessor on ab" 'a (a-accessor ab)) | |
628 | (pass-if-equal "a accessor on ba" 'a (a-accessor ba)) | |
649ec8d8 AW |
629 | (pass-if-exception "a accessor on cab" exception:no-applicable-method |
630 | (a-accessor cab)) | |
631 | (pass-if-exception "a accessor on cba" exception:no-applicable-method | |
632 | (a-accessor cba)) | |
583a23bf AW |
633 | (pass-if-equal "b accessor on a" 'b (b-accessor b)) |
634 | (pass-if-equal "b accessor on ab" 'b (b-accessor ab)) | |
635 | (pass-if-equal "b accessor on ba" 'b (b-accessor ba)) | |
636 | (pass-if-equal "b accessor on cab" 'b (b-accessor cab)) | |
637 | (pass-if-equal "b accessor on cba" 'b (b-accessor cba)))) |