/[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.2 by dirk, Sat Jun 30 20:03:14 2001 UTC revision 1.2.2.1 by mdj, Thu Apr 17 17:50:57 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 97  Line 97 
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))))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.2.2.1

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