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 |
167 |
(eval '(and (is-a? foo <generic-with-setter>) |
(eval '(and (is-a? foo <generic-with-setter>) |
168 |
(null? (generic-function-methods foo))) |
(null? (generic-function-methods foo))) |
169 |
(current-module))))) |
(current-module))))) |
170 |
|
|
171 |
|
(with-test-prefix "object update" |
172 |
|
(pass-if "defining class" |
173 |
|
(eval '(define-class <foo> () |
174 |
|
(x #:accessor x #:init-value 123) |
175 |
|
(z #:accessor z #:init-value 789)) |
176 |
|
(current-module)) |
177 |
|
(eval '(is-a? <foo> <class>) (current-module))) |
178 |
|
(pass-if "making instance" |
179 |
|
(eval '(define foo (make <foo>)) (current-module)) |
180 |
|
(eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module))) |
181 |
|
(pass-if "redefining class" |
182 |
|
(eval '(define-class <foo> () |
183 |
|
(x #:accessor x #:init-value 123) |
184 |
|
(y #:accessor y #:init-value 456) |
185 |
|
(z #:accessor z #:init-value 789)) |
186 |
|
(current-module)) |
187 |
|
(eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))) |
188 |
|
|
189 |
|
(use-modules (oop goops active-slot)) |
190 |
|
|
191 |
|
(with-test-prefix "active-slot" |
192 |
|
(pass-if "defining class with active slot" |
193 |
|
(eval '(begin |
194 |
|
(define z '()) |
195 |
|
(define-class <bar> () |
196 |
|
(x #:accessor x |
197 |
|
#:init-value 1 |
198 |
|
#:allocation #:active |
199 |
|
#:before-slot-ref |
200 |
|
(lambda (o) |
201 |
|
(set! z (cons 'before-ref z)) |
202 |
|
#t) |
203 |
|
#:after-slot-ref |
204 |
|
(lambda (o) |
205 |
|
(set! z (cons 'after-ref z))) |
206 |
|
#:before-slot-set! |
207 |
|
(lambda (o v) |
208 |
|
(set! z (cons* v 'before-set! z))) |
209 |
|
#:after-slot-set! |
210 |
|
(lambda (o v) |
211 |
|
(set! z (cons* v (x o) 'after-set! z)))) |
212 |
|
#:metaclass <active-class>) |
213 |
|
(define bar (make <bar>)) |
214 |
|
(x bar) |
215 |
|
(set! (x bar) 2) |
216 |
|
(equal? (reverse z) |
217 |
|
'(before-ref before-set! 1 before-ref after-ref |
218 |
|
after-set! 1 1 before-ref after-ref |
219 |
|
before-set! 2 before-ref after-ref after-set! 2 2))) |
220 |
|
(current-module)))) |
221 |
|
|