1 ;;;; goops.test --- test suite for GOOPS -*- scheme -*-
3 ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 2, or (at your option)
8 ;;;; any later version.
10 ;;;; This program 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
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18 ;;;; Boston, MA 02110-1301 USA
20 (define-module (test-suite test-goops)
21 #:use-module (test-suite lib)
22 #:autoload (srfi srfi-1) (unfold))
24 (pass-if "GOOPS loads"
26 (begin (resolve-module '(oop goops))
29 (use-modules (oop goops))
31 ;;; more tests here...
33 (with-test-prefix "basic classes"
35 (with-test-prefix "<top>"
41 (eq? (class-of <top>) <class>))
43 (pass-if "is a class?"
44 (is-a? <top> <class>))
47 (eq? (class-name <top>) '<top>))
49 (pass-if "direct superclasses"
50 (equal? (class-direct-supers <top>) '()))
52 (pass-if "superclasses"
53 (equal? (class-precedence-list <top>) (list <top>)))
55 (pass-if "direct slots"
56 (equal? (class-direct-slots <top>) '()))
59 (equal? (class-slots <top>) '())))
61 (with-test-prefix "<object>"
67 (eq? (class-of <object>) <class>))
69 (pass-if "is a class?"
70 (is-a? <object> <class>))
73 (eq? (class-name <object>) '<object>))
75 (pass-if "direct superclasses"
76 (equal? (class-direct-supers <object>) (list <top>)))
78 (pass-if "superclasses"
79 (equal? (class-precedence-list <object>) (list <object> <top>)))
81 (pass-if "direct slots"
82 (equal? (class-direct-slots <object>) '()))
85 (equal? (class-slots <object>) '())))
87 (with-test-prefix "<class>"
93 (eq? (class-of <class>) <class>))
95 (pass-if "is a class?"
96 (is-a? <class> <class>))
99 (eq? (class-name <class>) '<class>))
101 (pass-if "direct superclass"
102 (equal? (class-direct-supers <class>) (list <object>))))
104 (with-test-prefix "class-precedence-list"
105 (for-each (lambda (class)
106 (run-test (if (slot-bound? class 'name)
108 (with-output-to-string
115 (equal? (class-precedence-list class)
116 (compute-cpl class)))
118 (let ((table (make-hash-table)))
119 (let rec ((class <top>))
120 (hash-create-handle! table class #f)
121 (for-each rec (class-direct-subclasses class)))
122 (hash-fold (lambda (class ignore classes)
123 (cons class classes))
128 (with-test-prefix "classes for built-in types"
131 (eq? (class-of fluid-ref) <procedure>))
134 (eq? (class-of hashq-ref) <procedure>))
137 (eq? (class-of car) <procedure>))
140 (eq? (class-of "foo") <string>))
143 (is-a? (%make-void-port "w") <port>))
145 (pass-if "struct vtable"
146 ;; Previously, `class-of' would fail for nameless structs, i.e., structs
147 ;; for which `struct-vtable-name' is #f.
148 (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
151 (with-test-prefix "defining classes"
153 (with-test-prefix "define-class"
155 (pass-if "creating a new binding"
156 (if (eval '(defined? '<foo-0>) (current-module))
158 (eval '(define-class <foo-0> ()) (current-module))
159 (eval '(is-a? <foo-0> <class>) (current-module)))
161 (pass-if "overwriting a binding to a non-class"
162 (eval '(define <foo> #f) (current-module))
163 (eval '(define-class <foo> ()) (current-module))
164 (eval '(is-a? <foo> <class>) (current-module)))
166 (expect-fail "bad init-thunk"
169 (eval '(define-class <foo> ()
170 (x #:init-thunk (lambda (x) 1)))
176 (pass-if "interaction with `struct-ref'"
177 (eval '(define-class <class-struct> ()
178 (foo #:init-keyword #:foo)
179 (bar #:init-keyword #:bar))
181 (eval '(let ((x (make <class-struct>
185 (eq? (struct-ref x 0) 'hello)
186 (eq? (struct-ref x 1) 'world)))
189 (pass-if "interaction with `struct-set!'"
190 (eval '(define-class <class-struct-2> ()
193 (eval '(let ((x (make <class-struct-2>)))
194 (struct-set! x 0 'hello)
195 (struct-set! x 1 'world)
197 (eq? (struct-ref x 0) 'hello)
198 (eq? (struct-ref x 1) 'world)))
201 (with-test-prefix "defining generics"
203 (with-test-prefix "define-generic"
205 (pass-if "creating a new top-level binding"
206 (if (eval '(defined? 'foo-0) (current-module))
208 (eval '(define-generic foo-0) (current-module))
209 (eval '(and (is-a? foo-0 <generic>)
210 (null? (generic-function-methods foo-0)))
213 (pass-if "overwriting a top-level binding to a non-generic"
214 (eval '(define (foo) #f) (current-module))
215 (eval '(define-generic foo) (current-module))
216 (eval '(and (is-a? foo <generic>)
217 (= 1 (length (generic-function-methods foo))))
220 (pass-if "overwriting a top-level binding to a generic"
221 (eval '(define (foo) #f) (current-module))
222 (eval '(define-generic foo) (current-module))
223 (eval '(define-generic foo) (current-module))
224 (eval '(and (is-a? foo <generic>)
225 (null? (generic-function-methods foo)))
228 (with-test-prefix "defining methods"
230 (pass-if "define-method"
231 (let ((m (current-module)))
232 (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
233 (string-append s1 s2))
235 (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
238 (eval '(and (is-a? my-plus <generic>)
239 (= (length (generic-function-methods my-plus))
243 (pass-if "method-more-specific?"
244 (eval '(let* ((m+ (generic-function-methods my-plus))
247 (arg-types (list <string> <string>)))
248 (if (memq <string> (method-specializers m1))
249 (method-more-specific? m1 m2 arg-types)
250 (method-more-specific? m2 m1 arg-types)))
253 (pass-if-exception "method-more-specific? (failure)"
254 exception:wrong-type-arg
255 (eval '(let* ((m+ (generic-function-methods my-plus))
258 (method-more-specific? m1 m2 '()))
261 (with-test-prefix "defining accessors"
263 (with-test-prefix "define-accessor"
265 (pass-if "creating a new top-level binding"
266 (if (eval '(defined? 'foo-1) (current-module))
268 (eval '(define-accessor foo-1) (current-module))
269 (eval '(and (is-a? foo-1 <generic-with-setter>)
270 (null? (generic-function-methods foo-1)))
273 (pass-if "overwriting a top-level binding to a non-accessor"
274 (eval '(define (foo) #f) (current-module))
275 (eval '(define-accessor foo) (current-module))
276 (eval '(and (is-a? foo <generic-with-setter>)
277 (= 1 (length (generic-function-methods foo))))
280 (pass-if "overwriting a top-level binding to an accessor"
281 (eval '(define (foo) #f) (current-module))
282 (eval '(define-accessor foo) (current-module))
283 (eval '(define-accessor foo) (current-module))
284 (eval '(and (is-a? foo <generic-with-setter>)
285 (null? (generic-function-methods foo)))
288 (with-test-prefix "object update"
289 (pass-if "defining class"
290 (eval '(define-class <foo> ()
291 (x #:accessor x #:init-value 123)
292 (z #:accessor z #:init-value 789))
294 (eval '(is-a? <foo> <class>) (current-module)))
295 (pass-if "making instance"
296 (eval '(define foo (make <foo>)) (current-module))
297 (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
298 (pass-if "redefining class"
299 (eval '(define-class <foo> ()
300 (x #:accessor x #:init-value 123)
301 (y #:accessor y #:init-value 456)
302 (z #:accessor z #:init-value 789))
304 (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
306 (pass-if "changing class"
307 (let* ((c1 (class () (the-slot #:init-keyword #:value)))
308 (c2 (class () (the-slot #:init-keyword #:value)
309 (the-other-slot #:init-value 888)))
310 (o1 (make c1 #:value 777)))
313 (equal? (slot-ref o1 'the-slot) 777)
314 (let ((o2 (change-class o1 c2)))
318 (equal? (slot-ref o2 'the-slot) 777))))))
320 (pass-if "`hell' in `goops.c' grows as expected"
321 ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
322 ;; fix (i.e., Guile 1.8.5 and earlier). The root of the problem was
323 ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
324 ;; array, leading to out-of-bounds accesses.
326 (let* ((parent-class (class ()
327 #:name '<class-that-will-be-redefined>))
329 (unfold (lambda (i) (>= i 20))
331 (make-class (list parent-class)
332 '((the-slot #:init-value #:value)
334 #:name (string->symbol
335 (string-append "<foo-to-redefine-"
343 (make class #:value 777))
346 (define-method (change-class (foo parent-class)
348 ;; Called by `scm_change_object_class ()', via `purgatory ()'.
351 (let ((class (car classes))
352 (object (car objects)))
353 (set! classes (cdr classes))
354 (set! objects (cdr objects))
356 ;; Redefine the class so that its instances are eventually
357 ;; passed to `scm_change_object_class ()'. This leads to
358 ;; nested `scm_change_object_class ()' calls, which increases
359 ;; the size of HELL and increments N_HELL.
360 (class-redefinition class
361 (make-class '() (class-slots class)
362 #:name (class-name class)))
364 ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
365 ;; and `go_to_hell ()' calls.
366 (slot-ref object 'the-slot)
371 ;; Initiate the whole `change-class' chain.
372 (let* ((class (car classes))
373 (object (change-class (car objects) class)))
374 (is-a? object class)))))
376 (with-test-prefix "object comparison"
377 (pass-if "default method"
380 (x #:accessor x #:init-keyword #:x)
381 (y #:accessor y #:init-keyword #:y))
382 (define o1 (make <c> #:x '(1) #:y '(2)))
383 (define o2 (make <c> #:x '(1) #:y '(3)))
384 (define o3 (make <c> #:x '(4) #:y '(3)))
385 (define o4 (make <c> #:x '(4) #:y '(3)))
390 (define-method (eqv? (a <c>) (b <c>))
391 (equal? (x a) (x b)))
395 (eval '(not (eqv? o2 o3))
397 (pass-if "transfer eqv? => equal?"
398 (eval '(equal? o1 o2)
402 (define-method (equal? (a <c>) (b <c>))
403 (equal? (y a) (y b)))
406 (pass-if "not equal?"
407 (eval '(not (equal? o1 o2))
411 (define-method (= (a <c>) (b <c>))
412 (and (equal? (x a) (x b))
413 (equal? (y a) (y b))))
417 (eval '(not (= o1 o2))
421 (use-modules (oop goops active-slot))
423 (with-test-prefix "active-slot"
424 (pass-if "defining class with active slot"
427 (define-class <bar> ()
430 #:allocation #:active
433 (set! z (cons 'before-ref z))
437 (set! z (cons 'after-ref z)))
440 (set! z (cons* v 'before-set! z)))
443 (set! z (cons* v (x o) 'after-set! z))))
444 #:metaclass <active-class>)
445 (define bar (make <bar>))
449 '(before-ref before-set! 1 before-ref after-ref
450 after-set! 1 1 before-ref after-ref
451 before-set! 2 before-ref after-ref after-set! 2 2)))
454 (use-modules (oop goops composite-slot))
456 (with-test-prefix "composite-slot"
457 (pass-if "creating instance with propagated slot"
460 (x #:accessor x #:init-keyword #:x)
461 (y #:accessor y #:init-keyword #:y))
463 (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
464 (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
466 #:allocation #:propagated
467 #:propagate-to '(o1 (o2 y)))
468 #:metaclass <composite-class>)
469 (define o (make <c>))
472 (pass-if "reading propagated slot"
473 (eval '(= (x o) 1) (current-module)))
474 (pass-if "writing propagated slot"
477 (and (= (x (o1 o)) 5)