/[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.6 by mdj, Thu Apr 17 15:25:15 2003 UTC revision 1.7 by mdj, Thu Apr 17 19:23:52 2003 UTC
# Line 136  Line 136 
136      (pass-if "overwriting a binding to a non-class"      (pass-if "overwriting a binding to a non-class"
137        (eval '(define <foo> #f) (current-module))        (eval '(define <foo> #f) (current-module))
138        (eval '(define-class <foo> ()) (current-module))        (eval '(define-class <foo> ()) (current-module))
139        (eval '(is-a? <foo> <class>) (current-module)))))        (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"  (with-test-prefix "defining generics"
153    
# Line 210  Line 221 
221            (current-module))            (current-module))
222      (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))      (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
223    
224  (with-test-prefix "equal?"  (with-test-prefix "object comparison"
225    (pass-if "equal"    (pass-if "default method"
226             (eval '(begin             (eval '(begin
227                      (define-class <c> ()                      (define-class <c> ()
228                        (x #:accessor x #:init-keyword #:x)                        (x #:accessor x #:init-keyword #:x)
229                        (y #:accessor y #:init-keyword #:y))                        (y #:accessor y #:init-keyword #:y))
230                        (define o1 (make <c> #:x '(1) #:y '(2)))
231                        (define o2 (make <c> #:x '(1) #:y '(3)))
232                        (define o3 (make <c> #:x '(4) #:y '(3)))
233                        (define o4 (make <c> #:x '(4) #:y '(3)))
234                        (not (eqv? o1 o2)))
235                     (current-module)))
236      (pass-if "eqv?"
237               (eval '(begin
238                        (define-method (eqv? (a <c>) (b <c>))
239                          (equal? (x a) (x b)))
240                        (eqv? o1 o2))
241                     (current-module)))
242      (pass-if "not eqv?"
243               (eval '(not (eqv? o2 o3))
244                     (current-module)))
245      (pass-if "transfer eqv? => equal?"
246               (eval '(equal? o1 o2)
247                     (current-module)))
248      (pass-if "equal?"
249               (eval '(begin
250                      (define-method (equal? (a <c>) (b <c>))                      (define-method (equal? (a <c>) (b <c>))
251                        (equal? (y a) (y b)))                        (equal? (y a) (y b)))
252                      (define o1 (make <c> #:x '(1) #:y '(3)))                      (equal? o2 o3))
                     (define o2 (make <c> #:x '(2) #:y '(3)))  
                     (define o3 (make <c> #:x '(2) #:y '(4)))  
                     (equal? o1 o2))  
253                   (current-module)))                   (current-module)))
254    (pass-if "not equal"    (pass-if "not equal?"
255             (eval '(not (equal? o2 o3))             (eval '(not (equal? o1 o2))
256                   (current-module))))                   (current-module)))
257      (pass-if "="
258               (eval '(begin
259                        (define-method (= (a <c>) (b <c>))
260                          (and (equal? (x a) (x b))
261                               (equal? (y a) (y b))))
262                        (= o3 o4))
263                     (current-module)))
264      (pass-if "not ="
265               (eval '(not (= o1 o2))
266                     (current-module)))
267      )
268    
269  (use-modules (oop goops active-slot))  (use-modules (oop goops active-slot))
270    
# Line 260  Line 299 
299                         before-set! 2 before-ref after-ref after-set! 2 2)))                         before-set! 2 before-ref after-ref after-set! 2 2)))
300            (current-module))))            (current-module))))
301    
302    (use-modules (oop goops composite-slot))
303    
304    (with-test-prefix "composite-slot"
305      (pass-if "creating instance with propagated slot"
306        (eval '(begin
307                 (define-class <a> ()
308                   (x #:accessor x #:init-keyword #:x)
309                   (y #:accessor y #:init-keyword #:y))
310                 (define-class <c> ()
311                   (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
312                   (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
313                   (x #:accessor x
314                      #:allocation #:propagated
315                      #:propagate-to '(o1 (o2 y)))
316                   #:metaclass <composite-class>)
317                 (define o (make <c>))
318                 (is-a? o <c>))
319              (current-module)))
320      (pass-if "reading propagated slot"
321               (eval '(= (x o) 1) (current-module)))
322      (pass-if "writing propagated slot"
323               (eval '(begin
324                        (set! (x o) 5)
325                        (and (= (x (o1 o)) 5)
326                             (= (y (o1 o)) 2)
327                             (= (x (o2 o)) 3)
328                             (= (y (o2 o)) 5)))
329                     (current-module))))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

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