Commit | Line | Data |
---|---|---|
4ed29c73 MV |
1 | ;;;; goops.test --- test suite for GOOPS -*- scheme -*- |
2 | ;;;; | |
510d7877 | 3 | ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 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. | |
150 | (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>))) | |
510d7877 LC |
151 | |
152 | ||
9f045403 DH |
153 | (with-test-prefix "defining classes" |
154 | ||
155 | (with-test-prefix "define-class" | |
156 | ||
157 | (pass-if "creating a new binding" | |
62ed3710 DH |
158 | (if (eval '(defined? '<foo-0>) (current-module)) |
159 | (throw 'unresolved)) | |
160 | (eval '(define-class <foo-0> ()) (current-module)) | |
161 | (eval '(is-a? <foo-0> <class>) (current-module))) | |
9f045403 DH |
162 | |
163 | (pass-if "overwriting a binding to a non-class" | |
164 | (eval '(define <foo> #f) (current-module)) | |
165 | (eval '(define-class <foo> ()) (current-module)) | |
47cd67db MD |
166 | (eval '(is-a? <foo> <class>) (current-module))) |
167 | ||
168 | (expect-fail "bad init-thunk" | |
169 | (catch #t | |
170 | (lambda () | |
171 | (eval '(define-class <foo> () | |
172 | (x #:init-thunk (lambda (x) 1))) | |
173 | (current-module)) | |
174 | #t) | |
175 | (lambda args | |
176 | #f))) | |
cac39600 LC |
177 | |
178 | (pass-if "interaction with `struct-ref'" | |
179 | (eval '(define-class <class-struct> () | |
180 | (foo #:init-keyword #:foo) | |
181 | (bar #:init-keyword #:bar)) | |
182 | (current-module)) | |
183 | (eval '(let ((x (make <class-struct> | |
184 | #:foo 'hello | |
185 | #:bar 'world))) | |
186 | (and (struct? x) | |
187 | (eq? (struct-ref x 0) 'hello) | |
188 | (eq? (struct-ref x 1) 'world))) | |
189 | (current-module))) | |
190 | ||
191 | (pass-if "interaction with `struct-set!'" | |
192 | (eval '(define-class <class-struct-2> () | |
193 | (foo) (bar)) | |
194 | (current-module)) | |
195 | (eval '(let ((x (make <class-struct-2>))) | |
196 | (struct-set! x 0 'hello) | |
197 | (struct-set! x 1 'world) | |
198 | (and (struct? x) | |
199 | (eq? (struct-ref x 0) 'hello) | |
200 | (eq? (struct-ref x 1) 'world))) | |
5192c9e8 AW |
201 | (current-module))) |
202 | ||
203 | (pass-if "with accessors" | |
204 | (eval '(define-class <qux> () | |
205 | (x #:accessor x #:init-value 123) | |
206 | (z #:accessor z #:init-value 789)) | |
207 | (current-module)) | |
208 | (eval '(equal? (x (make <qux>)) 123) (current-module))))) | |
209 | ||
33e04d54 DH |
210 | |
211 | (with-test-prefix "defining generics" | |
212 | ||
213 | (with-test-prefix "define-generic" | |
214 | ||
215 | (pass-if "creating a new top-level binding" | |
62ed3710 DH |
216 | (if (eval '(defined? 'foo-0) (current-module)) |
217 | (throw 'unresolved)) | |
218 | (eval '(define-generic foo-0) (current-module)) | |
219 | (eval '(and (is-a? foo-0 <generic>) | |
220 | (null? (generic-function-methods foo-0))) | |
33e04d54 DH |
221 | (current-module))) |
222 | ||
223 | (pass-if "overwriting a top-level binding to a non-generic" | |
224 | (eval '(define (foo) #f) (current-module)) | |
225 | (eval '(define-generic foo) (current-module)) | |
226 | (eval '(and (is-a? foo <generic>) | |
227 | (= 1 (length (generic-function-methods foo)))) | |
228 | (current-module))) | |
229 | ||
230 | (pass-if "overwriting a top-level binding to a generic" | |
231 | (eval '(define (foo) #f) (current-module)) | |
232 | (eval '(define-generic foo) (current-module)) | |
233 | (eval '(define-generic foo) (current-module)) | |
234 | (eval '(and (is-a? foo <generic>) | |
235 | (null? (generic-function-methods foo))) | |
236 | (current-module))))) | |
237 | ||
b1f57ea4 LC |
238 | (with-test-prefix "defining methods" |
239 | ||
240 | (pass-if "define-method" | |
241 | (let ((m (current-module))) | |
242 | (eval '(define-method (my-plus (s1 <string>) (s2 <string>)) | |
243 | (string-append s1 s2)) | |
244 | m) | |
245 | (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>)) | |
246 | (+ i1 i2)) | |
247 | m) | |
248 | (eval '(and (is-a? my-plus <generic>) | |
249 | (= (length (generic-function-methods my-plus)) | |
250 | 2)) | |
251 | m))) | |
252 | ||
253 | (pass-if "method-more-specific?" | |
254 | (eval '(let* ((m+ (generic-function-methods my-plus)) | |
255 | (m1 (car m+)) | |
256 | (m2 (cadr m+)) | |
257 | (arg-types (list <string> <string>))) | |
258 | (if (memq <string> (method-specializers m1)) | |
259 | (method-more-specific? m1 m2 arg-types) | |
260 | (method-more-specific? m2 m1 arg-types))) | |
261 | (current-module))) | |
262 | ||
263 | (pass-if-exception "method-more-specific? (failure)" | |
264 | exception:wrong-type-arg | |
265 | (eval '(let* ((m+ (generic-function-methods my-plus)) | |
266 | (m1 (car m+)) | |
267 | (m2 (cadr m+))) | |
268 | (method-more-specific? m1 m2 '())) | |
269 | (current-module)))) | |
270 | ||
4bcc952d AW |
271 | (with-test-prefix "the method cache" |
272 | (pass-if "defining a method with a rest arg" | |
273 | (let ((m (current-module))) | |
274 | (eval '(define-method (foo bar . baz) | |
275 | (cons bar baz)) | |
276 | m) | |
277 | (eval '(foo 1) | |
278 | m) | |
279 | (eval '(foo 1 2) | |
280 | m) | |
281 | (eval '(equal? (foo 1 2) '(1 2)) | |
282 | m)))) | |
283 | ||
33e04d54 DH |
284 | (with-test-prefix "defining accessors" |
285 | ||
286 | (with-test-prefix "define-accessor" | |
287 | ||
288 | (pass-if "creating a new top-level binding" | |
62ed3710 DH |
289 | (if (eval '(defined? 'foo-1) (current-module)) |
290 | (throw 'unresolved)) | |
291 | (eval '(define-accessor foo-1) (current-module)) | |
292 | (eval '(and (is-a? foo-1 <generic-with-setter>) | |
293 | (null? (generic-function-methods foo-1))) | |
33e04d54 DH |
294 | (current-module))) |
295 | ||
296 | (pass-if "overwriting a top-level binding to a non-accessor" | |
297 | (eval '(define (foo) #f) (current-module)) | |
298 | (eval '(define-accessor foo) (current-module)) | |
299 | (eval '(and (is-a? foo <generic-with-setter>) | |
300 | (= 1 (length (generic-function-methods foo)))) | |
301 | (current-module))) | |
302 | ||
303 | (pass-if "overwriting a top-level binding to an accessor" | |
304 | (eval '(define (foo) #f) (current-module)) | |
305 | (eval '(define-accessor foo) (current-module)) | |
306 | (eval '(define-accessor foo) (current-module)) | |
307 | (eval '(and (is-a? foo <generic-with-setter>) | |
308 | (null? (generic-function-methods foo))) | |
309 | (current-module))))) | |
58241edc MD |
310 | |
311 | (with-test-prefix "object update" | |
312 | (pass-if "defining class" | |
313 | (eval '(define-class <foo> () | |
314 | (x #:accessor x #:init-value 123) | |
315 | (z #:accessor z #:init-value 789)) | |
316 | (current-module)) | |
317 | (eval '(is-a? <foo> <class>) (current-module))) | |
318 | (pass-if "making instance" | |
319 | (eval '(define foo (make <foo>)) (current-module)) | |
320 | (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module))) | |
321 | (pass-if "redefining class" | |
322 | (eval '(define-class <foo> () | |
323 | (x #:accessor x #:init-value 123) | |
324 | (y #:accessor y #:init-value 456) | |
325 | (z #:accessor z #:init-value 789)) | |
326 | (current-module)) | |
82d8d6d9 LC |
327 | (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))) |
328 | ||
329 | (pass-if "changing class" | |
330 | (let* ((c1 (class () (the-slot #:init-keyword #:value))) | |
331 | (c2 (class () (the-slot #:init-keyword #:value) | |
332 | (the-other-slot #:init-value 888))) | |
333 | (o1 (make c1 #:value 777))) | |
334 | (and (is-a? o1 c1) | |
335 | (not (is-a? o1 c2)) | |
336 | (equal? (slot-ref o1 'the-slot) 777) | |
337 | (let ((o2 (change-class o1 c2))) | |
338 | (and (eq? o1 o2) | |
339 | (is-a? o2 c2) | |
340 | (not (is-a? o2 c1)) | |
341 | (equal? (slot-ref o2 'the-slot) 777)))))) | |
342 | ||
343 | (pass-if "`hell' in `goops.c' grows as expected" | |
344 | ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c' | |
345 | ;; fix (i.e., Guile 1.8.5 and earlier). The root of the problem was | |
346 | ;; that `go_to_hell ()' would not reallocate enough room for the `hell' | |
347 | ;; array, leading to out-of-bounds accesses. | |
348 | ||
349 | (let* ((parent-class (class () | |
350 | #:name '<class-that-will-be-redefined>)) | |
351 | (classes | |
352 | (unfold (lambda (i) (>= i 20)) | |
353 | (lambda (i) | |
354 | (make-class (list parent-class) | |
355 | '((the-slot #:init-value #:value) | |
356 | (the-other-slot)) | |
357 | #:name (string->symbol | |
358 | (string-append "<foo-to-redefine-" | |
359 | (number->string i) | |
360 | ">")))) | |
361 | (lambda (i) | |
362 | (+ 1 i)) | |
363 | 0)) | |
364 | (objects | |
365 | (map (lambda (class) | |
366 | (make class #:value 777)) | |
367 | classes))) | |
368 | ||
369 | (define-method (change-class (foo parent-class) | |
370 | (new <class>)) | |
371 | ;; Called by `scm_change_object_class ()', via `purgatory ()'. | |
372 | (if (null? classes) | |
373 | (next-method) | |
374 | (let ((class (car classes)) | |
375 | (object (car objects))) | |
376 | (set! classes (cdr classes)) | |
377 | (set! objects (cdr objects)) | |
378 | ||
379 | ;; Redefine the class so that its instances are eventually | |
380 | ;; passed to `scm_change_object_class ()'. This leads to | |
381 | ;; nested `scm_change_object_class ()' calls, which increases | |
382 | ;; the size of HELL and increments N_HELL. | |
383 | (class-redefinition class | |
384 | (make-class '() (class-slots class) | |
385 | #:name (class-name class))) | |
386 | ||
387 | ;; Use `slot-ref' to trigger the `scm_change_object_class ()' | |
388 | ;; and `go_to_hell ()' calls. | |
389 | (slot-ref object 'the-slot) | |
390 | ||
391 | (next-method)))) | |
392 | ||
393 | ||
394 | ;; Initiate the whole `change-class' chain. | |
395 | (let* ((class (car classes)) | |
396 | (object (change-class (car objects) class))) | |
397 | (is-a? object class))))) | |
58241edc | 398 | |
47cd67db MD |
399 | (with-test-prefix "object comparison" |
400 | (pass-if "default method" | |
57b1d518 MD |
401 | (eval '(begin |
402 | (define-class <c> () | |
403 | (x #:accessor x #:init-keyword #:x) | |
404 | (y #:accessor y #:init-keyword #:y)) | |
47cd67db MD |
405 | (define o1 (make <c> #:x '(1) #:y '(2))) |
406 | (define o2 (make <c> #:x '(1) #:y '(3))) | |
407 | (define o3 (make <c> #:x '(4) #:y '(3))) | |
408 | (define o4 (make <c> #:x '(4) #:y '(3))) | |
409 | (not (eqv? o1 o2))) | |
410 | (current-module))) | |
411 | (pass-if "eqv?" | |
412 | (eval '(begin | |
413 | (define-method (eqv? (a <c>) (b <c>)) | |
414 | (equal? (x a) (x b))) | |
415 | (eqv? o1 o2)) | |
416 | (current-module))) | |
417 | (pass-if "not eqv?" | |
418 | (eval '(not (eqv? o2 o3)) | |
419 | (current-module))) | |
420 | (pass-if "transfer eqv? => equal?" | |
421 | (eval '(equal? o1 o2) | |
422 | (current-module))) | |
423 | (pass-if "equal?" | |
424 | (eval '(begin | |
57b1d518 MD |
425 | (define-method (equal? (a <c>) (b <c>)) |
426 | (equal? (y a) (y b))) | |
47cd67db | 427 | (equal? o2 o3)) |
57b1d518 | 428 | (current-module))) |
47cd67db MD |
429 | (pass-if "not equal?" |
430 | (eval '(not (equal? o1 o2)) | |
431 | (current-module))) | |
432 | (pass-if "=" | |
433 | (eval '(begin | |
434 | (define-method (= (a <c>) (b <c>)) | |
435 | (and (equal? (x a) (x b)) | |
436 | (equal? (y a) (y b)))) | |
437 | (= o3 o4)) | |
438 | (current-module))) | |
439 | (pass-if "not =" | |
440 | (eval '(not (= o1 o2)) | |
441 | (current-module))) | |
442 | ) | |
57b1d518 | 443 | |
58241edc MD |
444 | (use-modules (oop goops active-slot)) |
445 | ||
446 | (with-test-prefix "active-slot" | |
447 | (pass-if "defining class with active slot" | |
448 | (eval '(begin | |
449 | (define z '()) | |
450 | (define-class <bar> () | |
451 | (x #:accessor x | |
452 | #:init-value 1 | |
453 | #:allocation #:active | |
454 | #:before-slot-ref | |
455 | (lambda (o) | |
456 | (set! z (cons 'before-ref z)) | |
457 | #t) | |
458 | #:after-slot-ref | |
459 | (lambda (o) | |
460 | (set! z (cons 'after-ref z))) | |
461 | #:before-slot-set! | |
462 | (lambda (o v) | |
463 | (set! z (cons* v 'before-set! z))) | |
464 | #:after-slot-set! | |
465 | (lambda (o v) | |
466 | (set! z (cons* v (x o) 'after-set! z)))) | |
467 | #:metaclass <active-class>) | |
468 | (define bar (make <bar>)) | |
469 | (x bar) | |
470 | (set! (x bar) 2) | |
471 | (equal? (reverse z) | |
472 | '(before-ref before-set! 1 before-ref after-ref | |
473 | after-set! 1 1 before-ref after-ref | |
474 | before-set! 2 before-ref after-ref after-set! 2 2))) | |
475 | (current-module)))) | |
476 | ||
47cd67db MD |
477 | (use-modules (oop goops composite-slot)) |
478 | ||
479 | (with-test-prefix "composite-slot" | |
480 | (pass-if "creating instance with propagated slot" | |
481 | (eval '(begin | |
482 | (define-class <a> () | |
483 | (x #:accessor x #:init-keyword #:x) | |
484 | (y #:accessor y #:init-keyword #:y)) | |
485 | (define-class <c> () | |
486 | (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2)) | |
487 | (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4)) | |
488 | (x #:accessor x | |
489 | #:allocation #:propagated | |
490 | #:propagate-to '(o1 (o2 y))) | |
491 | #:metaclass <composite-class>) | |
492 | (define o (make <c>)) | |
493 | (is-a? o <c>)) | |
494 | (current-module))) | |
495 | (pass-if "reading propagated slot" | |
496 | (eval '(= (x o) 1) (current-module))) | |
497 | (pass-if "writing propagated slot" | |
498 | (eval '(begin | |
499 | (set! (x o) 5) | |
500 | (and (= (x (o1 o)) 5) | |
501 | (= (y (o1 o)) 2) | |
502 | (= (x (o2 o)) 3) | |
503 | (= (y (o2 o)) 5))) | |
504 | (current-module)))) | |
2aecf4cf AW |
505 | |
506 | (with-test-prefix "no-applicable-method" | |
507 | (pass-if-exception "calling generic, no methods" | |
508 | exception:no-applicable-method | |
509 | (eval '(begin | |
510 | (define-class <qux> ()) | |
511 | (define-generic quxy) | |
512 | (quxy 1)) | |
513 | (current-module))) | |
514 | (pass-if "calling generic, one method, applicable" | |
515 | (eval '(begin | |
516 | (define-method (quxy (q <qux>)) | |
517 | #t) | |
518 | (define q (make <qux>)) | |
519 | (quxy q)) | |
520 | (current-module))) | |
521 | (pass-if-exception "calling generic, one method, not applicable" | |
522 | exception:no-applicable-method | |
523 | (eval '(quxy 1) | |
524 | (current-module)))) |