/[guile]/guile/guile-core/test-suite/tests/goops.test
ViewVC logotype

Diff of /guile/guile-core/test-suite/tests/goops.test

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by dirk, Sat Jul 13 09:44:39 2002 UTC revision 1.5 by mdj, Tue Apr 15 01:17:36 2003 UTC
# Line 1  Line 1 
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
# Line 167  Line 167 
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    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26