1 |
;;;; goops.test --- test suite for GOOPS -*- scheme -*- |
;;;; goops.test --- test suite for GOOPS -*- scheme -*- |
2 |
;;;; |
;;;; |
3 |
;;;; Copyright (C) 2001 Free Software Foundation, Inc. |
;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc. |
4 |
;;;; |
;;;; |
5 |
;;;; This program is free software; you can redistribute it and/or modify |
;;;; 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 |
;;;; it under the terms of the GNU General Public License as published by |
97 |
(eq? (class-name <class>) '<class>)) |
(eq? (class-name <class>) '<class>)) |
98 |
|
|
99 |
(pass-if "direct superclass" |
(pass-if "direct superclass" |
100 |
(equal? (class-direct-supers <class>) (list <object>))))) |
(equal? (class-direct-supers <class>) (list <object>)))) |
101 |
|
|
102 |
|
(with-test-prefix "class-precedence-list" |
103 |
|
(for-each (lambda (class) |
104 |
|
(run-test (if (slot-bound? class 'name) |
105 |
|
(class-name class) |
106 |
|
(with-output-to-string |
107 |
|
(lambda () |
108 |
|
(display class)))) |
109 |
|
#t |
110 |
|
(lambda () |
111 |
|
(catch #t |
112 |
|
(lambda () |
113 |
|
(equal? (class-precedence-list class) |
114 |
|
(compute-cpl class))) |
115 |
|
(lambda args #t))))) |
116 |
|
(let ((table (make-hash-table 31))) |
117 |
|
(let rec ((class <top>)) |
118 |
|
(hash-create-handle! table class #f) |
119 |
|
(for-each rec (class-direct-subclasses class))) |
120 |
|
(hash-fold (lambda (class ignore classes) |
121 |
|
(cons class classes)) |
122 |
|
'() |
123 |
|
table)))) |
124 |
|
) |
125 |
|
|
126 |
|
(with-test-prefix "defining classes" |
127 |
|
|
128 |
|
(with-test-prefix "define-class" |
129 |
|
|
130 |
|
(pass-if "creating a new binding" |
131 |
|
(eval '(define <foo> #f) (current-module)) |
132 |
|
(eval '(undefine <foo>) (current-module)) |
133 |
|
(eval '(define-class <foo> ()) (current-module)) |
134 |
|
(eval '(is-a? <foo> <class>) (current-module))) |
135 |
|
|
136 |
|
(pass-if "overwriting a binding to a non-class" |
137 |
|
(eval '(define <foo> #f) (current-module)) |
138 |
|
(eval '(define-class <foo> ()) (current-module)) |
139 |
|
(eval '(is-a? <foo> <class>) (current-module))) |
140 |
|
|
141 |
|
(expect-fail "bad init-thunk" |
142 |
|
(catch #t |
143 |
|
(lambda () |
144 |
|
(eval '(define-class <foo> () |
145 |
|
(x #:init-thunk (lambda (x) 1))) |
146 |
|
(current-module)) |
147 |
|
#t) |
148 |
|
(lambda args |
149 |
|
#f))) |
150 |
|
)) |
151 |
|
|
152 |
|
(with-test-prefix "defining generics" |
153 |
|
|
154 |
|
(with-test-prefix "define-generic" |
155 |
|
|
156 |
|
(pass-if "creating a new top-level binding" |
157 |
|
(eval '(define foo #f) (current-module)) |
158 |
|
(eval '(undefine foo) (current-module)) |
159 |
|
(eval '(define-generic foo) (current-module)) |
160 |
|
(eval '(and (is-a? foo <generic>) |
161 |
|
(null? (generic-function-methods foo))) |
162 |
|
(current-module))) |
163 |
|
|
164 |
|
(pass-if "overwriting a top-level binding to a non-generic" |
165 |
|
(eval '(define (foo) #f) (current-module)) |
166 |
|
(eval '(define-generic foo) (current-module)) |
167 |
|
(eval '(and (is-a? foo <generic>) |
168 |
|
(= 1 (length (generic-function-methods foo)))) |
169 |
|
(current-module))) |
170 |
|
|
171 |
|
(pass-if "overwriting a top-level binding to a generic" |
172 |
|
(eval '(define (foo) #f) (current-module)) |
173 |
|
(eval '(define-generic foo) (current-module)) |
174 |
|
(eval '(define-generic foo) (current-module)) |
175 |
|
(eval '(and (is-a? foo <generic>) |
176 |
|
(null? (generic-function-methods foo))) |
177 |
|
(current-module))))) |
178 |
|
|
179 |
|
(with-test-prefix "defining accessors" |
180 |
|
|
181 |
|
(with-test-prefix "define-accessor" |
182 |
|
|
183 |
|
(pass-if "creating a new top-level binding" |
184 |
|
(eval '(define foo #f) (current-module)) |
185 |
|
(eval '(undefine foo) (current-module)) |
186 |
|
(eval '(define-accessor foo) (current-module)) |
187 |
|
(eval '(and (is-a? foo <generic-with-setter>) |
188 |
|
(null? (generic-function-methods foo))) |
189 |
|
(current-module))) |
190 |
|
|
191 |
|
(pass-if "overwriting a top-level binding to a non-accessor" |
192 |
|
(eval '(define (foo) #f) (current-module)) |
193 |
|
(eval '(define-accessor foo) (current-module)) |
194 |
|
(eval '(and (is-a? foo <generic-with-setter>) |
195 |
|
(= 1 (length (generic-function-methods foo)))) |
196 |
|
(current-module))) |
197 |
|
|
198 |
|
(pass-if "overwriting a top-level binding to an accessor" |
199 |
|
(eval '(define (foo) #f) (current-module)) |
200 |
|
(eval '(define-accessor foo) (current-module)) |
201 |
|
(eval '(define-accessor foo) (current-module)) |
202 |
|
(eval '(and (is-a? foo <generic-with-setter>) |
203 |
|
(null? (generic-function-methods foo))) |
204 |
|
(current-module))))) |
205 |
|
|
206 |
|
(with-test-prefix "object update" |
207 |
|
(pass-if "defining class" |
208 |
|
(eval '(define-class <foo> () |
209 |
|
(x #:accessor x #:init-value 123) |
210 |
|
(z #:accessor z #:init-value 789)) |
211 |
|
(current-module)) |
212 |
|
(eval '(is-a? <foo> <class>) (current-module))) |
213 |
|
(pass-if "making instance" |
214 |
|
(eval '(define foo (make <foo>)) (current-module)) |
215 |
|
(eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module))) |
216 |
|
(pass-if "redefining class" |
217 |
|
(eval '(define-class <foo> () |
218 |
|
(x #:accessor x #:init-value 123) |
219 |
|
(y #:accessor y #:init-value 456) |
220 |
|
(z #:accessor z #:init-value 789)) |
221 |
|
(current-module)) |
222 |
|
(eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))) |
223 |
|
|
224 |
|
(with-test-prefix "equal?" |
225 |
|
(pass-if "equal" |
226 |
|
(eval '(begin |
227 |
|
(define-class <c> () |
228 |
|
(x #:accessor x #:init-keyword #:x) |
229 |
|
(y #:accessor y #:init-keyword #:y)) |
230 |
|
(define-method (equal? (a <c>) (b <c>)) |
231 |
|
(equal? (y a) (y b))) |
232 |
|
(define o1 (make <c> #:x '(1) #:y '(3))) |
233 |
|
(define o2 (make <c> #:x '(2) #:y '(3))) |
234 |
|
(define o3 (make <c> #:x '(2) #:y '(4))) |
235 |
|
(equal? o1 o2)) |
236 |
|
(current-module))) |
237 |
|
(pass-if "not equal" |
238 |
|
(eval '(not (equal? o2 o3)) |
239 |
|
(current-module)))) |
240 |
|
|
241 |
|
(use-modules (oop goops active-slot)) |
242 |
|
|
243 |
|
(with-test-prefix "active-slot" |
244 |
|
(pass-if "defining class with active slot" |
245 |
|
(eval '(begin |
246 |
|
(define z '()) |
247 |
|
(define-class <bar> () |
248 |
|
(x #:accessor x |
249 |
|
#:init-value 1 |
250 |
|
#:allocation #:active |
251 |
|
#:before-slot-ref |
252 |
|
(lambda (o) |
253 |
|
(set! z (cons 'before-ref z)) |
254 |
|
#t) |
255 |
|
#:after-slot-ref |
256 |
|
(lambda (o) |
257 |
|
(set! z (cons 'after-ref z))) |
258 |
|
#:before-slot-set! |
259 |
|
(lambda (o v) |
260 |
|
(set! z (cons* v 'before-set! z))) |
261 |
|
#:after-slot-set! |
262 |
|
(lambda (o v) |
263 |
|
(set! z (cons* v (x o) 'after-set! z)))) |
264 |
|
#:metaclass <active-class>) |
265 |
|
(define bar (make <bar>)) |
266 |
|
(x bar) |
267 |
|
(set! (x bar) 2) |
268 |
|
(equal? (reverse z) |
269 |
|
'(before-ref before-set! 1 before-ref after-ref |
270 |
|
after-set! 1 1 before-ref after-ref |
271 |
|
before-set! 2 before-ref after-ref after-set! 2 2))) |
272 |
|
(current-module)))) |
273 |
|
|
274 |
|
(use-modules (oop goops composite-slot)) |
275 |
|
|
276 |
|
(with-test-prefix "composite-slot" |
277 |
|
(pass-if "creating instance with propagated slot" |
278 |
|
(eval '(begin |
279 |
|
(define-class <a> () |
280 |
|
(x #:accessor x #:init-keyword #:x) |
281 |
|
(y #:accessor y #:init-keyword #:y)) |
282 |
|
(define-class <c> () |
283 |
|
(o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2)) |
284 |
|
(o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4)) |
285 |
|
(x #:accessor x |
286 |
|
#:allocation #:propagated |
287 |
|
#:propagate-to '(o1 (o2 y))) |
288 |
|
#:metaclass <composite-class>) |
289 |
|
(define o (make <c>)) |
290 |
|
(is-a? o <c>)) |
291 |
|
(current-module))) |
292 |
|
(pass-if "reading propagated slot" |
293 |
|
(eval '(= (x o) 1) (current-module))) |
294 |
|
(pass-if "writing propagated slot" |
295 |
|
(eval '(begin |
296 |
|
(set! (x o) 5) |
297 |
|
(and (= (x (o1 o)) 5) |
298 |
|
(= (y (o1 o)) 2) |
299 |
|
(= (x (o2 o)) 3) |
300 |
|
(= (y (o2 o)) 5))) |
301 |
|
(current-module)))) |