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))) |
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" |
(with-test-prefix "defining classes" |
127 |
|
|
210 |
(current-module)) |
(current-module)) |
211 |
(eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))) |
(eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))) |
212 |
|
|
213 |
|
(with-test-prefix "equal?" |
214 |
|
(pass-if "equal" |
215 |
|
(eval '(begin |
216 |
|
(define-class <c> () |
217 |
|
(x #:accessor x #:init-keyword #:x) |
218 |
|
(y #:accessor y #:init-keyword #:y)) |
219 |
|
(define-method (equal? (a <c>) (b <c>)) |
220 |
|
(equal? (y a) (y b))) |
221 |
|
(define o1 (make <c> #:x '(1) #:y '(3))) |
222 |
|
(define o2 (make <c> #:x '(2) #:y '(3))) |
223 |
|
(define o3 (make <c> #:x '(2) #:y '(4))) |
224 |
|
(equal? o1 o2)) |
225 |
|
(current-module))) |
226 |
|
(pass-if "not equal" |
227 |
|
(eval '(not (equal? o2 o3)) |
228 |
|
(current-module)))) |
229 |
|
|
230 |
(use-modules (oop goops active-slot)) |
(use-modules (oop goops active-slot)) |
231 |
|
|
232 |
(with-test-prefix "active-slot" |
(with-test-prefix "active-slot" |