1;;; oop
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16(mat oop
17  (begin
18    (import (oop))
19    (define-syntax seq-list
20      (lambda (x)
21        (import (only scheme list))
22        (syntax-case x ()
23          [(_ e ...)
24           (with-syntax ([(t ...) (generate-temporaries #'(e ...))])
25             #'(let* ([t e] ...) (list t ...)))])))
26    (define true? (lambda (x) (eq? x #t)))
27    #t)
28  (begin
29    (define-class (<a> a1) (<root>)
30      (ivars [x1 a1])
31      (methods
32        [m1 (q) (list self x1 q)]
33        [m2 () x1]))
34     #t)
35  (error? ; incorrect argument count
36    (make-<a>))
37  (error? ; incorrect argument count
38    (make-<a> 1 2))
39  (begin
40    (define i1 (make-<a> 3))
41    #t)
42  (equal? (cdr (m1 i1 4)) '(3 4))
43  (eq? (car (m1 i1 4)) i1)
44  (error? ; incorrect argument count
45    (m1 i1))
46  (error? ; incorrect argument count
47    (m1 i1 4 5))
48  (error? ; m1 not applicable to 17
49    (m1 17 4))
50  (error? ; not bound
51    (<a>-x1 i1))
52  (error? ; not bound
53    (<a>-x1-set! i1 17))
54
55  ; no longer an error to duplicate x1
56  (begin
57    (define x1 'outer-x1)
58    (define x3 'outer-x3)
59    (define-class (<b> b1 b2) (<a> (+ b1 b2))
60      (ivars [x1 b1] [x2 b2])
61      (methods
62        [m1 (q) (vector self x1 q)]
63        [m3 (s t) (list s t x1 x2)]
64        [m4 () x3]))
65    (define i2 (make-<b> 10 4))
66    #t
67  )
68  (equal? (m2 i2) 14)
69  (equal? (m3 i2 'kurds 'weigh) '(kurds weigh 10 4))
70  (eq? (m4 i2) 'outer-x3)
71
72  (begin
73    (define-class (<b> b1 b2) (<a> (+ b1 b2))
74      (ivars [x2 b1] [x3 b2])
75      (methods
76        [m1 (q) (vector self x2 q)]
77        [m4 () x1]
78        [m3 (s t) (list s t x1 x2 x3)]))
79    (define i2 (make-<b> 4 5))
80    #t)
81  (eq? (m4 i2) 'outer-x1)
82  (eq? (vector-ref (m1 i2 6) 0) i2)
83  (equal? (vector-ref (m1 i2 6) 1) 4)
84  (equal? (vector-ref (m1 i2 6) 2) 6)
85
86  (begin
87    (define-class (<c> x) (<root>)
88      (ivars [x x])
89      (methods [c1 (a) (make-<c> a)]))
90    #t)
91  ((lambda (x) (<c>? x)) (c1 (make-<c> 4) 5))
92
93  (eq?
94    (let ()
95      (define-class (<c> x) (<root>)
96        (ivars [x x])
97        (methods
98          [c1 (a) (make-<c> a)]
99          [c2 () x]))
100      (c2 (c1 (make-<c> 44) 87)))
101    87)
102
103  (begin
104    (define-class (foo x) (<root>)
105      (ivars [x x])
106      (methods
107        [hit () x]
108        [hit (y) (set! x (+ x y))]))
109    #t)
110
111  (equal?
112    (let ([a (make-foo 1)])
113      (let ((b (hit a)))
114        (hit a 17)
115        (list b (hit a))))
116    '(1 18))
117
118  (error? ; invalid arity for hit
119    (define-class (bar) (foo 1) (methods [hit (y z) (list y z)])))
120
121  ; test variable arity methods
122
123  (equal?
124    (let ()
125      (define-class (foo) (<root>) (methods [test (a . b) (list 'test a b)]))
126      (test (make-foo) 1 2 3 4 5))
127    '(test 1 (2 3 4 5)))
128
129  (equal?
130    (let ()
131      (define-class (foo) (<root>) (methods [test (a . b) (list 'test a b)]))
132      (define-class (bar) (foo) (methods [test (x . y) (list 'bar x y (super 'p 'd 'q 'r 's 't 'u))]))
133      (test (make-bar) 1 2 3 4 5 6 7))
134    '(bar 1 (2 3 4 5 6 7) (test p (d q r s t u))))
135
136  (equal?
137    (let ()
138      (define-class (foo x) (<root>)
139        (ivars [x x])
140        (methods
141          [ping () x]
142          [ping (v) (set! x v)]))
143      (define-class (bar x) (foo x)
144        (methods
145          [ping () super]                             ; return super method
146          [ping (v) (super (+ (super) v))]))
147      (let ([x (make-foo 1)] [y (make-bar 10)])
148        (let ([before-x (ping x)] [before-y ((ping y))])
149          (ping x 100)
150          (ping y 100)
151          (let ([after-x (ping x)] [after-y ((ping y))])
152            ((ping y) 76)
153            (list before-x before-y after-x after-y ((ping y)))))))
154    '(1 10 100 110 76))
155
156  (equal?
157    (let ()
158      (define-class (foo) (<root>) (methods [chow x (cons 'foo x)]))
159      (define-class (bar) (foo) (methods [chow x (apply super 'bar x)]))
160      (list (chow (make-foo) 1 2 3)
161            (chow (make-bar) 4 5 6)))
162    '((foo 1 2 3) (foo bar 4 5 6)))
163
164  ; Verify that first-class super knows all arities of corresponding method.
165  (equal?
166    (let ()
167      (define-class (foo) (<root>)
168        (methods
169          [chow (mein) (list 'foo 'chow-1 mein)]
170          [chow (a b) (list 'foo 'chow-2 a b)]))
171      (define-class (bar) (foo) (methods [chow (a b) super]))
172      (let ([sup (chow (make-bar) 'ignore1 'ignore2)])
173        (list (sup 'mane) (sup "ay" "bee"))))
174    '((foo chow-1 mane) (foo chow-2 "ay" "bee")))
175
176  ; Verify that we don't override method unless its generic is visible,
177  ; i.e., we get a new method of the same name
178  (equal?
179    (let ()
180      (module (foo (alpha bar))
181        (define-class (foo) (<root>) (methods [bar () 'foobar]))
182        (define-syntax alpha (identifier-syntax bar)))
183      (define-class (baz) (foo) (methods [bar () 'bazbar]))
184      (let ([x (make-baz)]) (list (alpha x) (bar x))))
185    '(foobar bazbar))
186
187  ; Verify that we can't send super unless method's generic is visible.
188  (error? ; no inherited bar method (super)
189    (let ()
190      (module (foo (alpha bar))
191        (define-class (foo) (<root>) (methods [bar () 'foobar]))
192        (define-syntax alpha (identifier-syntax bar)))
193      (define-class (baz) (foo) (methods [bar () (super)]))
194      (make-baz)))
195
196  ; Verify that we can't define a generic for a method with the same name
197  ; as an interface method, i.e., supply an implementation of an
198  ; interface-inherited method with the wrong arity
199  (begin
200    (define-interface bonk [whack (a mole)])
201    #t)
202  (error? ; invalid arity for whack
203    (define-class (pewter) (<root>) (implements bonk)
204      (methods
205        [whack (e) "method w/ same name as interface method, but diff arity"]
206        [whack (o no) "method matches interface method"])))
207
208  ; more elaborate verification that we can't define a generic for a method
209  ; with the same name as an interface method, i.e., supply an implementation
210  ; of an interface-inherited method with the wrong arity
211  (begin
212    (define-interface bark [ham ()] [spam (y)])
213    #t)
214  (error? ; invalid arity for whack (or spam)
215    (define-class (platinum) (<root>) (implements bark bonk)
216      (methods
217        [ham () "and cheese"]
218        [spam () "spam"]
219        [spam (y) "spam"]
220        [xspam (x) "xspam"]
221        [whack (e) "method w/ same name as interface method, but diff arity"]
222        [whack (o no) "method matches interface method"])))
223  (error? ; invalid arity for whack (or spam)
224    (define-class (platinum) (<root>) (implements bonk bark)
225      (methods
226        [ham () "and cheese"]
227        [spam () "spam"]
228        [spam (y) "spam"]
229        [xspam (x) "xspam"]
230        [whack (e) "method w/ same name as interface method, but diff arity"]
231        [whack (o no) "method matches interface method"])))
232  (error? ; invalid arity for spam (or whack)
233    (define-class (platinum) (<root>) (implements bark bonk)
234      (methods
235        [whack (e) "method w/ same name as interface method, but diff arity"]
236        [whack (o no) "method matches interface method"]
237        [ham () "and cheese"]
238        [spam () "spam"]
239        [spam (y) "spam"]
240        [xspam (x) "xspam"])))
241  (error? ; invalid arity for spam (or whack)
242    (define-class (platinum) (<root>) (implements bonk bark)
243      (methods
244        [whack (e) "method w/ same name as interface method, but diff arity"]
245        [whack (o no) "method matches interface method"]
246        [ham () "and cheese"]
247        [spam () "spam"]
248        [spam (y) "spam"]
249        [xspam (x) "xspam"])))
250
251
252  (begin
253    (define-interface i1 [fish (fry)])
254    (define-interface i2 [rats (around)])
255    #t)
256
257  (error? ; fish not applicable to 3
258    (fish 3 4))
259  (error? ; rats not applicable to 3
260    (rats 3 4))
261  (error? ; fish not applicable to #<frob>
262    (let ()
263      (define-record frob ())
264      (record-writer (type-descriptor frob)
265        (lambda (x p wr)
266          (display "#<frob>" p)))
267      (fish (make-frob) 4)))
268
269  (error? ; no implementation of interface method rats
270    (define-class (<d> x) (<root>) (implements i1 i2)
271      (ivars [x (* x x)])
272      (methods
273        [fish (fry) (list fry x)]
274        [run (around) (cons around x)]
275        [x! (v) (set! x (* v v))])))
276
277  (equal?
278    (let ()
279      (define-class (<d> x) (<root>) (implements i1 i2)
280        (ivars [x (* x x)])
281        (methods
282          [fish (fry) (list fry x)]
283          [rats (around) (cons around x)]
284          [x? () x]
285          [x! (v) (set! x (* v v))]))
286      (define d (make-<d> 3))
287      (x! d 7)
288      (list (x? d) (fish d "hi") (rats d "ih")))
289    '(49 ("hi" 49) ("ih" . 49)))
290
291  (begin
292    (define-class (<e>) (<root>)
293      (methods
294        [m1 () (define-class (<f>) (<e>) (methods [m2 () 14])) (* (m2 (make-<f>)) 2)]))
295    #t)
296  (eqv? (m1 (make-<e>)) 28)
297
298  (equal?
299    (let ()
300      (define (m2 x) "undefined")
301      (module (c1 make-c1 m1 c1-friends)
302        (module all (c1 make-c1 m1 m2)
303          (define-class (c1) (<root>)
304            (methods
305              [m1 () "public"]
306              [m2 () "protected"])))
307        (module c1-friends (m2) (import all))
308        (import all))
309      (module (make-c2 m3)
310        (import c1-friends)
311        (define-class (c2) (c1)
312          (methods [m3 () (m2 self)])))
313      (module (make-c3 m4)
314        (import c1-friends)
315        (define-class (c3) (<root>)
316          (methods [m4 (x) (m2 x)])))
317      (let ([x (make-c2)] [y (make-c3)])
318        (list (m1 x) (m2 x) (m3 x) (m4 y x))))
319    '("public" "undefined" "protected" "protected"))
320
321  (equal?
322    (let ()
323      (define (m2 x) "undefined")
324      (module (c1 make-c1 m1 c2 make-c2 m3 make-c3 m4)
325        (define-class (c1) (<root>)
326          (methods
327            [m1 () "public"]
328            [m2 () "protected"]))
329        (define-class (c2) (c1)
330          (methods [m3 () (m2 self)]))
331        (define-class (c3) (<root>)
332          (methods [m4 (x) (m2 x)])))
333      (let ([x (make-c2)] [y (make-c3)])
334        (list (m1 x) (m2 x) (m3 x) (m4 y x))))
335    '("public" "undefined" "protected" "protected"))
336
337  (true?
338    (let ([f (lambda ()
339               (define-class (frap) (<root>))
340               (cons make-frap frap?))])
341      ((cdr (f)) ((car (f))))))
342
343  (true?
344    (let ([f (lambda ()
345               (define-class (frap) (<root>) (methods [m () 5]))
346               (cons make-frap frap?))])
347      (not ((cdr (f)) ((car (f)))))))
348
349  (true?
350    (let ([f (lambda ()
351               (define-class (frap) (<root>))
352               (cons make-frap frap?))]
353          [g (lambda ()
354               (define-class (frap) (<root>))
355               (cons make-frap frap?))])
356      (and (not ((cdr (f)) ((car (g)))))
357           (not ((cdr (g)) ((car (f))))))))
358
359  (true?
360    (let ([f (lambda ()
361               (define-class (#{frap |.O7*%gC?Sxs~2\\%|}) (<root>))
362               (cons make-frap frap?))]
363          [g (lambda ()
364               (define-class (#{frap |.O7*%gC?Sxs~2\\%|}) (<root>))
365               (cons make-frap frap?))])
366      (and ((cdr (f)) ((car (g))))
367           ((cdr (g)) ((car (f)))))))
368
369  (true?
370    (let ([f (lambda ()
371               (define-class (#{frap |.TfvA+Ml1*u&?\\%|}) (<root>) (ivars [x 0]))
372               (cons make-frap frap?))]
373          [g (lambda ()
374               (define-class (#{frap |.TfvA+Ml1*u&?\\%|}) (<root>) (ivars [x 0]))
375               (cons make-frap frap?))])
376      (and ((cdr (f)) ((car (g))))
377           ((cdr (g)) ((car (f)))))))
378
379  (error? ; incompatible record type
380    (let ([f (lambda ()
381               (define-class (#{frap |.Uo3>P+Wu9o=u\\%|}) (<root>) (ivars [x 0]))
382               (cons make-frap frap?))]
383          [g (lambda ()
384               (define-class (#{frap |.Uo3>P+Wu9o=u\\%|}) (<root>) (ivars [y 0]))
385               (cons make-frap frap?))])
386      (and ((cdr (f)) ((car (g))))
387           ((cdr (g)) ((car (f)))))))
388
389  (error? ; cannot specify gensym class-name with methods or interfaces
390    (let ([f (lambda ()
391               (define-class (frap) (<root>) (methods [m1 () 5]))
392               (cons make-frap frap?))]
393          [g (lambda ()
394               (define-class (#{frap |.R@iB9FE~OXVz\\%|}) (<root>) (methods [m1 () 5]))
395               (cons make-frap frap?))])
396      (and ((cdr (f)) ((car (g))))
397           ((cdr (g)) ((car (f)))))))
398
399  (equal?
400    (let ()
401      (define-class (<frozwell> x) (<root>)
402        (constructor frozwell-make)
403        (predicate is-frozwell?))
404        (let ([frzwl (frozwell-make 3)])
405          (list (is-frozwell? frzwl)
406                (is-frozwell? 17))))
407    '(#t #f))
408
409  (begin
410    (define-class (<frozwell> x) (<root>)
411      (constructor frozwell-make)
412      (predicate is-frozwell?))
413    #t)
414  (equal?
415    (let ([frzwl (frozwell-make 3)])
416      (list (is-frozwell? frzwl)
417            (is-frozwell? 17)))
418    '(#t #f))
419
420  (begin
421    (library (L1)
422      (export <frozwell> frozwell-make is-frozwell?)
423      (import (chezscheme) (oop))
424      (define-class (<frozwell> x) (<root>)
425        (constructor frozwell-make)
426        (predicate is-frozwell?)))
427    #t)
428
429  (equal?
430    (let ()
431      (import (L1))
432      (let ([frzwl (frozwell-make 3)])
433        (list (is-frozwell? frzwl)
434              (is-frozwell? 17))))
435    '(#t #f))
436
437  (error? ; invalid syntax <frozwell>
438    (let ()
439      (import (L1))
440      <frozwell>))
441
442  (error? ; extra ivars clause
443    (define-class (foo) (<root>)
444      (ivars [x 0])
445      (ivars [y 1])
446      (methods [show () (values x y)])))
447
448  (error? ; extra methods clause
449    (define-class (foo) (<root>)
450      (ivars [x 0] [y 1])
451      (methods [show () (values x y)])
452      (methods [get-x () x])))
453
454  (begin
455    (define-interface istud [cram (z)])
456    (define-class (fritz q) (<root>)
457      (methods [fritz-x+ (y) (+ x y)] [cram (n) (set! x (+ x n))])
458      (predicate ?fritzy)
459      (ivars [x (* q q)])
460      (constructor fritzit)
461      (implements istud))
462    #t)
463  (equal?
464    (let ([w (fritzit 10)])
465      (cram w 50)
466      (list (?fritzy w)
467            (?fritzy 'fritzy)
468            (fritz-x+ w 7)))
469    '(#t #f 157))
470
471
472  (error? ; invalid assignment of immutable ivar x
473    (define-class (blast x) (<root>) (ivars [immutable x x] [mutable y x])
474      (init (set! x (* x x)))))
475
476  (error? ; invalid assignment of immutable ivar x
477    (define-class (blast x) (<root>) (ivars [immutable x x] [mutable y x])
478      (methods
479        [m (v) (set! x v)])))
480
481  (error? ; blast-x-set! not bound
482    (let ()
483      (define-class (blast x) (<root>) (ivars [public immutable x x] [public mutable y x]))
484      (define b (make-blast 17))
485      (blast-x-set! b (* (blast-x b) (blast-x b)))
486      (blast-x b)))
487
488  (equal?
489    (let ()
490      (define-class (blast x) (<root>) (ivars [public immutable x x] [public mutable y x])
491        (init (set! y (* y y))))
492      (define b (make-blast 9))
493      (list (blast-x b) (blast-y b)))
494    '(9 81))
495
496  (equal?
497    (let ()
498      (define-class (blast x) (<root>)
499        (ivars [public immutable x x] [public mutable y x])
500        (methods
501          [m (v) (set! y v)]))
502      (define b (make-blast 9))
503      (m b 35)
504      (list (blast-x b) (blast-y b)))
505    '(9 35))
506
507  (equal?
508    (let ()
509      (define-class (blast x) (<root>)
510        (ivars [public immutable x x] [public mutable y x]))
511      (define b (make-blast 17))
512      (blast-y-set! b (* (blast-x b) (blast-x b)))
513      (list (blast-x b) (blast-y b)))
514    '(17 289))
515
516  (begin
517    (define-class (<q> a1) (<root>)
518      (ivars [public mupu1 (+ a1 1)]
519             [public mutable mupu2 (+ a1 2)]
520             [public immutable impu3 (+ a1 3)]
521
522             [private mupr4 (+ a1 4)]
523             [private mutable mupr5 (+ a1 5)]
524             [private immutable impr6 (+ a1 6)]
525
526             [private mupr7 (+ a1 7)]
527             [private mutable mupr8 (+ a1 8)]
528             [private immutable impr9 (+ a1 9)]))
529    (define i1 (make-<q> 10))
530    #t)
531  (equal?
532    (list (<q>-mupu1 i1) (<q>-mupu2 i1) (<q>-impu3 i1))
533    '(11 12 13))
534  (equal?
535    (begin
536      (<q>-mupu1-set! i1 'a)
537      (<q>-mupu2-set! i1 'b)
538      (list (<q>-mupu1 i1) (<q>-mupu2 i1) (<q>-impu3 i1)))
539    '(a b 13))
540  (error? ; not bound
541    <q>-mupr4)
542  (error? ; not bound
543    <q>-mupr5)
544  (error? ; not bound
545    <q>-impr6)
546  (error? ; not bound
547    <q>-mupr7)
548  (error? ; not bound
549    <q>-mupr8)
550  (error? ; not bound
551    <q>-impr9)
552  (error? ; not bound
553    <q>-impu3-set!)
554  (error? ; not bound
555    <q>-mupr4-set!)
556  (error? ; not bound
557    <q>-mupr5-set!)
558  (error? ; not bound
559    <q>-impr6-set!)
560  (error? ; not bound
561    <q>-mupr7-set!)
562  (error? ; not bound
563    <q>-mupr8-set!)
564  (error? ; not bound
565    <q>-impr9-set!)
566
567  (begin
568    (define-class (<r> a1) (<q> (+ a1 10))
569      (ivars [public mupu1 (+ a1 1)]
570             [mutable public mupu2 (+ a1 2)]
571             [immutable public impu3 (+ a1 3)]))
572    (define i2 (make-<r> 10))
573    #t)
574  (equal?
575    (list (<q>-mupu1 i2) (<q>-mupu2 i2) (<q>-impu3 i2)
576          (<r>-mupu1 i2) (<r>-mupu2 i2) (<r>-impu3 i2))
577    '(21 22 23 11 12 13))
578  (equal?
579    (begin
580      (<q>-mupu1-set! i2 "hi")
581      (<q>-mupu2-set! i2 "there")
582      (<r>-mupu1-set! i2 "ye")
583      (<r>-mupu2-set! i2 "matey")
584      (list (<q>-mupu1 i2) (<q>-mupu2 i2) (<q>-impu3 i2)
585            (<r>-mupu1 i2) (<r>-mupu2 i2) (<r>-impu3 i2)))
586    '("hi" "there" 23 "ye" "matey" 13))
587  (error? ; not bound
588    <r>-impu3-set!)
589  (error? ; not applicable
590    (<r>-mupu1 i1))
591  (error? ; not applicable
592    (<r>-mupu1-set! i1 55))
593
594  (begin
595    (define-class (<s> a1) (<r> (+ a1 10))
596      (ivars [public mupu1 (+ a1 1)]
597             [public mutable mupu2 (+ a1 2)]
598             [public immutable impu3 (+ a1 3)])
599      (prefix "s$"))
600    (define i3 (make-<s> 10))
601    #t)
602  (equal?
603    (list (<q>-mupu1 i3) (<q>-mupu2 i3) (<q>-impu3 i3)
604          (<r>-mupu1 i3) (<r>-mupu2 i3) (<r>-impu3 i3)
605          (s$mupu1 i3) (s$mupu2 i3) (s$impu3 i3))
606    '(31 32 33 21 22 23 11 12 13))
607  (equal?
608    (begin
609      (<q>-mupu1-set! i3 'hi)
610      (<q>-mupu2-set! i3 'there)
611      (<r>-mupu1-set! i3 'ye)
612      (<r>-mupu2-set! i3 'matey)
613      (s$mupu1-set! i3 'scaliwag)
614      (s$mupu2-set! i3 'pirate)
615      (list (<q>-mupu1 i3) (<q>-mupu2 i3) (<q>-impu3 i3)
616            (<r>-mupu1 i3) (<r>-mupu2 i3) (<r>-impu3 i3)
617            (s$mupu1 i3) (s$mupu2 i3) (s$impu3 i3)))
618    '(hi there 33 ye matey 23 scaliwag pirate 13))
619  (error? ; not bound
620    <s>-impu1)
621  (error? ; not bound
622    s$impu3-set!)
623  (error? ; not applicable
624    (s$mupu1 i1))
625  (error? ; not applicable
626    (s$mupu1-set! i1 55))
627  (error? ; not applicable
628    (s$mupu1 i2))
629  (error? ; not applicable
630    (s$mupu1-set! i2 55))
631
632  ;;; tests from Michael Lenaghan of frogware, Inc.
633
634  (begin
635    ;; simple init expression
636    (define-class (<test-1> x y) (<root>)
637      (ivars [x x] [y y] [z (* x y)])
638      (methods [method-1 () z]))
639
640    ;; simple init expressions that depend
641    ;; on previously computed values
642    (define-class (<test-2> x y) (<root>)
643      (ivars [x x] [y y] [z1 (* x y)] [z2 (* 2 z1)])
644      (methods [method-2 () z2]))
645
646    ;; simple init proc
647    (define-class (<test-3> x y) (<root>)
648      (ivars [x x] [y y] [z 0])
649      (init
650       (set! z (* x y)))
651      (methods [method-3 () z]))
652
653    ;; class and base class initialization can have
654    ;; different arity
655    (define-class (<test-4> x) (<test-1> x x))
656
657    ;; class and base class initialization can have
658    ;; different arity and base class can use expressions
659    (define-class (<test-5> x) (<test-1> x (* 2 x)))
660    #t)
661
662  (eqv?
663    (let ([test (make-<test-1> 5 10)])
664      (method-1 test))
665    50)
666
667  (eqv?
668    (let ([test (make-<test-2> 5 10)])
669      (method-2 test))
670    100)
671
672  (eqv?
673    (let ([test (make-<test-3> 5 10)])
674      (method-3 test))
675    50)
676
677  (eqv?
678    (let ([test (make-<test-4> 5)])
679      (method-1 test))
680    25)
681
682  (eqv?
683    (let ([test (make-<test-5> 5)])
684      (method-1 test))
685    50)
686
687  (begin
688    ;; base class
689    (define-class (<test-1> init-1) (<root>)
690      (ivars [fld-1 init-1])
691      (methods
692        [whoami () self]
693        [method-1 () fld-1]
694        [method-2 (x) (set! fld-1 x)]))
695
696    ;; sub-class
697    (define-class (<test-2> init-1 init-2) (<test-1> init-1)
698      (ivars [fld-2 init-2])
699      (methods
700        [method-3 () fld-2]
701        [method-4 (x) (set! fld-2 x)]))
702
703    ;; Note: The class <test-3> can't use the method names
704    ;; "method-3" and "method-4" because they're used by
705    ;; <test-2>. Chez OOP produces a "generic function"
706    ;; for each method, and it looks like those functions
707    ;; all have to belong to one line of the class inheritence
708    ;; tree.
709
710    ;; sub-class w/ overload
711    (define-class (<test-3> init-1 init-2) (<test-1> init-1)
712      (ivars [fld-2 init-2])
713      (methods
714        [method-1 () (method-3a self)]
715        [method-2 (x) (method-4a self x)]
716        [method-3a () fld-2]
717        [method-4a (x) (set! fld-2 x)]))
718
719    ;; sub-class w/ overload & fields
720    ;; if this is uncommented, uncomment <test-4> test below
721    #;
722      (define-class (<test-4> init-1) (<test-1> init-1)
723      (methods
724        [method-3b ()
725                   ;; this provides access to super-class fields
726                   (open-instance <test-1> "" self)
727                   fld-1]
728        [method-4b (x)
729                   ;; this provides access to super-class fields
730                   (open-instance <test-1> "" self)
731                   (set! fld-1 x)]))
732
733    ;; sub-class w/ overload & super
734    (define-class (<test-5> init-1) (<test-1> init-1)
735      (methods
736        [method-1 () (string->symbol
737                       (string-append (symbol->string (super)) "!!!"))]
738        [method-2 (x) (super
739                        (string->symbol
740                          (string-append (symbol->string x) "!!!")))]))
741
742    ;; sub-class w/ variable arity
743    (define-class (<test-6> init-1) (<test-1> init-1)
744      (methods
745        [method-5 () (method-1 self)]
746        [method-5 (x) (method-2 self x)]))
747    #t)
748
749  (equal?
750    (let ((test (make-<test-1> 'hello)))
751      (seq-list
752        (eq? test (whoami test))
753        (method-1 test)
754        (method-2 test 'goodbye)
755        (method-1 test)))
756    `(#t hello ,(void) goodbye))
757
758  (equal?
759    (let ((test (make-<test-2> 'hello 'hello-again)))
760      (seq-list
761        (method-1 test)
762        (method-2 test 'goodbye)
763        (method-1 test)
764        (method-3 test)
765        (method-4 test 'goodbye-again)
766        (method-3 test)))
767    `(hello ,(void) goodbye hello-again ,(void) goodbye-again))
768
769  (equal?
770    (let ((test (make-<test-3> 'hello 'hello-again)))
771      (seq-list
772        (method-1 test)
773        (method-2 test 'goodbye-again)
774        (method-1 test)
775        (method-3a test)
776        (method-4a test 'hello-again)
777        (method-3a test)))
778    `(hello-again ,(void) goodbye-again goodbye-again ,(void) hello-again))
779
780  #;
781  (equal?
782    (let ((test (make-<test-4> 'hello)))
783      (seq-list
784        (method-1 test)
785        (method-2 test 'goodbye)
786        (method-1 test)
787
788        (method-3b test)
789        (method-4b test 'hello)
790        (method-3b test)))
791    `(hello ,(void) goodbye goodbye ,(void) hello))
792
793  (equal?
794    (let ((test (make-<test-5> 'hello)))
795      (seq-list
796        (method-1 test)
797        (method-2 test 'goodbye)
798        (method-1 test)))
799    `(hello!!! ,(void) goodbye!!!!!!))
800
801  (equal?
802    (let ((test (make-<test-6> 'hello)))
803      (seq-list
804        (method-5 test)
805        (method-5 test 'goodbye)
806        (method-5 test)))
807    `(hello ,(void) goodbye))
808
809  (begin
810    ;; use class exported from module
811    (module test-1 (<test-1> make-<test-1> method-1)
812      (define-class (<test-1> x) (<root>)
813        (ivars [x x])
814        (methods [method-1 () x])))
815    #t)
816
817  (eqv? (let () (import test-1) (method-1 (make-<test-1> 3))) 3)
818  (eqv?
819    (let ()
820      (import test-1)
821      (define-class (<frob> x) (<test-1> x))
822      (method-1 (make-<test-1> 3)))
823    3)
824
825  (begin
826    ;; use sub-class exported from module
827    (module test-2 (<test-2> make-<test-2> method-1)
828      (import test-1)
829      (define-class (<test-2> x) (<test-1> x)))
830    #t)
831
832  (eqv? (let () (import test-2) (method-1 (make-<test-2> 3))) 3)
833
834  (begin
835    ;; use sub-class w/ overload exported from module
836    (module test-3 (make-<test-3> method-1)
837      (import test-2)
838      (define-class (<test-3> x) (<test-2> x)
839        (ivars [x x])
840        (methods [method-1 () (* x x)])))
841    #t)
842
843  (eqv?
844    (let ()
845      (import test-1)
846      (let ([test (make-<test-1> 10)])
847        (method-1 test)))
848    10)
849
850  (eqv?
851    (let ()
852      (import test-2)
853      (let ([test (make-<test-2> 10)])
854        (method-1 test)))
855    10)
856
857  (eqv?
858    (let ()
859      (import test-3)
860      (let ([test (make-<test-3> 10)])
861        (method-1 test)))
862    100)
863
864  (begin
865    ;; base interface
866    (define-interface <<interface-1>>
867      [imethod-1 ()]
868      [imethod-2 (x)])
869
870    ;; sub-interface
871    (define-interface <<interface-2>> <<interface-1>>
872      [imethod-3 ()]
873      [imethod-4 (x)])
874
875    ;; base interface
876    (define-interface <<interface-3>>
877      [imethod-5 ()]
878      [imethod-6 (x)])
879
880    ;; base class w/ base interface
881    (define-class (<itest-1> init-1) (<root>)
882      (implements <<interface-1>>)
883      (ivars [fld-1 init-1])
884      (methods
885        [method-1 () 'method-1]
886        [imethod-1 () fld-1]
887        [imethod-2 (x) (set! fld-1 x)]))
888
889    ;; sub-class w/ sub-interface
890    (define-class (<itest-2> init-1 init-2) (<itest-1> init-1)
891      (implements <<interface-2>>)
892      (ivars [fld-2 init-2])
893      (methods
894        [method-2 () 'method-2]
895        [imethod-3 () fld-2]
896        [imethod-4 (x) (set! fld-2 x)]))
897
898    ;; sub-class w/ new method
899    (define-class (<itest-3> init-1 init-2) (<itest-2> init-1 init-2)
900      (ivars [fld-3 (+ init-1 init-2)])
901      (methods
902        [method-3 () fld-3]))
903
904    ;; base class w/ interfaces & new method
905    (define-class (<itest-4> init-1) (<root>)
906      (implements <<interface-1>> <<interface-3>>)
907      (ivars [fld-1 init-1])
908      (methods
909        [imethod-1 () (* 2 fld-1)]
910        [imethod-2 (x) (set! fld-1 x)]
911        [imethod-5 () (* 4 fld-1)]
912        [imethod-6 (x) (set! fld-1 x)]
913        [method-4 () fld-1]
914        [method-4! (x) (set! fld-1 x)]))
915    #t)
916
917  (equal?
918    (let ((itest (make-<itest-1> 'hello)))
919      (seq-list
920        (method-1 itest)
921        (imethod-1 itest)
922        (imethod-2 itest 'goodbye)
923        (imethod-1 itest)))
924    `(method-1 hello ,(void) goodbye))
925
926  (eqv?
927    (let ((itest (make-<itest-2> 'hello 'hello-again)))
928      (method-2 itest))
929    'method-2)
930
931  (equal?
932    (let ((itest (make-<itest-2> 'hello 'hello-again)))
933      (seq-list
934        (imethod-1 itest)
935        (imethod-2 itest 'goodbye)
936        (imethod-1 itest)
937
938        (imethod-3 itest)
939        (imethod-4 itest 'goodbye-again)
940        (imethod-3 itest)))
941    `(hello ,(void) goodbye hello-again ,(void) goodbye-again))
942
943  (eqv?
944    (let ((itest (make-<itest-3> 5 10)))
945      (method-3 itest))
946    15)
947
948  (equal?
949    (let ((itest (make-<itest-4> 10)))
950      (seq-list
951        (imethod-1 itest)
952        (imethod-5 itest)
953        (method-4 itest)
954        (method-4! itest 20)
955        (imethod-1 itest)
956        (imethod-5 itest)
957        (method-4 itest)))
958    `(20 40 10 ,(void) 40 80 20))
959
960  (begin
961    ;; export interface from module
962    (module test-1 (<<interface-1>> imethod-1 imethod-2)
963      (define-interface <<interface-1>>
964        [imethod-1 ()]
965        [imethod-2 (v)]))
966
967    ;; export sub-interface from module
968    (module test-2 (<<interface-2>> imethod-3 imethod-4)
969      (import test-1)
970      (define-interface <<interface-2>> <<interface-1>>
971        [imethod-3 ()]
972        [imethod-4 (v)]))
973
974    ;; use class w/ interface exported from module
975    (module test-3 (<itest-3> make-<itest-3> imethod-1 imethod-2)
976      (import test-1)
977      (define-class (<itest-3> x) (<root>)
978        (implements <<interface-1>>)
979        (ivars [x x])
980        (methods
981          [imethod-1 () x]
982          [imethod-2 (v) (set! x v)])))
983
984    ;; use sub-class w/ interface exported from module
985    (module test-4 (<itest-4> make-<itest-4> imethod-1 imethod-2 imethod-3 imethod-4)
986      (import test-2)
987      (import test-3)
988      (define-class (<itest-4> x) (<itest-3> x)
989        (implements <<interface-2>>)
990        (methods
991          [imethod-3 () (* 2 (imethod-1 self))]
992          [imethod-4 (v) (imethod-2 self (* 2 v))])))
993
994    ;; use sub-class w/ overload of interface methods exported from module
995    (module test-5 (make-<itest-5> imethod-1 imethod-2 imethod-3 imethod-4)
996      (import test-4)
997      (define-class (<itest-5> x) (<itest-4> x)
998        (methods
999          [imethod-1 () (* 2 (super))]
1000          [imethod-3 () (* 2 (super))])))
1001
1002    ;; use sub-class w/ new methods exported from module
1003    (module test-6 (make-<itest-6> method-1)
1004      (import test-4)
1005      (define-class (<itest-6> x) (<itest-4> x)
1006        (ivars [x x])
1007        (methods
1008          [method-1 () (* x x)])))
1009    #t)
1010
1011  (equal?
1012    (let ()
1013      (import test-3)
1014      (let ([test (make-<itest-3> 10)])
1015        (seq-list
1016          (imethod-1 test)
1017          (imethod-2 test 20)
1018          (imethod-1 test))))
1019    `(10 ,(void) 20))
1020
1021  (equal?
1022    (let ()
1023      (import test-4)
1024      (let ([test (make-<itest-4> 10)])
1025        (seq-list
1026          (imethod-1 test)
1027          (imethod-2 test 20)
1028          (imethod-1 test)
1029          (imethod-3 test)
1030          (imethod-4 test 20)
1031          (imethod-3 test))))
1032    `(10 ,(void) 20 40 ,(void) 80))
1033
1034  (equal?
1035    (let ()
1036      (import test-5)
1037      (let ([test (make-<itest-5> 10)])
1038        (seq-list
1039          (imethod-1 test)
1040          (imethod-2 test 20)
1041          (imethod-1 test)
1042          (imethod-3 test)
1043          (imethod-4 test 20)
1044          (imethod-3 test))))
1045    `(20 ,(void) 40 160 ,(void) 320))
1046
1047  (eqv?
1048    (let ()
1049      (import test-6)
1050      (let ([test (make-<itest-6> 10)])
1051        (method-1 test)))
1052    100)
1053
1054  ;;; end of tests from Michael Lenaghan of frogware, Inc.
1055
1056  ;;; letrec-classes tests from seminar
1057
1058  (begin
1059    (define-syntax letrec-classes
1060      (syntax-rules ()
1061        [(_ ([class-name (class-formal ...) (base-name base-arg ...)
1062               ([ivar ivar-init] ...)
1063               [method-name (method-formal ...) method-b1 method-b2 ...] ...]
1064             ...)
1065            b1 b2 ...)
1066         (let ()
1067           (define-class (class-name class-formal ...) (base-name base-arg ...)
1068             (ivars [ivar ivar-init] ...)
1069             (methods [method-name (method-formal ...) method-b1 method-b2 ...] ...))
1070           ...
1071           b1 b2 ...)]))
1072    #t)
1073
1074  (error? ; wrong number of base-class arguments
1075    (letrec-classes ([<a> (x) (<root>) ()])
1076      (letrec-classes ([<b> () (<a>) ()])
1077        (make-<b>))))
1078
1079  (error? ; no inherited foo method for (super)
1080    (letrec-classes ([<a> () (<root>) () [foo () (super)]])
1081      (foo (make-<a>))))
1082
1083  (eq?
1084    (let ()
1085      (letrec-classes ([<c> (x) (<root>)
1086                        ([x x])
1087                        [c1 (a) (make-<c> a)]
1088                        [c2 () x]])
1089        (c2 (c1 (make-<c> 44) 87))))
1090    87)
1091
1092  (eq?
1093    (letrec-classes ((A () (<root>) ()))
1094      (letrec-classes
1095        ((<root> () (A) ()
1096          (foo (<root>) 77)))
1097        (foo (make-<root>) 88)))
1098    77)
1099
1100  ; Ronald Garcia
1101
1102  ; Here are some INVALID test cases that I use to exercise what errors my
1103  ; compiler will catch.  A few might not fail given the proper compiler
1104  ; extension (i.e. do classes and variables share the same namespace...)
1105
1106  (error? ; duplicate definition repeat, repeat?, and make-repeate
1107    (letrec-classes ([Repeat () (<root>) ()]
1108                     [Repeat () (<root>) ()])
1109      0))
1110
1111  (error? ; duplicate ivar i
1112    (letrec-classes ([Vars () (<root>) ((i 1) (i 1))])
1113      0))
1114
1115  (error? ; unrecognized base class aaaaa
1116    (letrec-classes ([Empty () (aaaaa) ()])
1117      (let ([mt (make-Empty)])
1118        0)))
1119
1120  ;;; Chez Scheme allows this:
1121  (eqv?
1122    (letrec-classes ([One () (<root>) ()]
1123                     [Two  () (One) ()])
1124      0)
1125    0)
1126
1127  (error? ; unrecognized base class aaaaa
1128    (letrec-classes ([One () (<root>) ()])
1129      (letrec-classes ([Two  () (aaaaa) ()])
1130      0)))
1131
1132  (error? ; duplicate same-arity method definition
1133    (letrec-classes ([Vars () (<root>) ()
1134                           (M1 () 0)
1135                           (M1 () 1)])
1136      0))
1137
1138  (error? ; incorrect base argument count
1139    (letrec-classes ([Class () (<root> unbound) ()])
1140      0))
1141
1142  (error? ; unbound is not bound
1143    (letrec-classes ([c1 (x) (<root>) ()])
1144      (letrec-classes ([c2 () (c1 unbound) ()])
1145        (make-c2))))
1146
1147  (error? ; unbound is not bound
1148    (letrec-classes ([c () (<root>) ((i unbound))])
1149      (make-c)))
1150
1151  (error? ; j is unbound
1152    (letrec-classes ([c () (<root>) ((i j) (j 0))])
1153      (make-c)
1154      0))
1155
1156  (eqv?
1157    (letrec-classes ([c () (<root>) ((i 1) (j (+ i 2))) (m () j)])
1158      (m (make-c)))
1159    3)
1160
1161  (error? ; unbound is not bound
1162    (letrec-classes ([c (i j) (<root>) ()])
1163      (make-c 1 unbound)))
1164
1165  (error? ; unbound is not bound
1166    (letrec-classes ([c (i j) (<root>) ()])
1167      (c? unbound)))
1168
1169  (error? ; unbound is not bound
1170    (letrec-classes ([Class () (<root>) () (M1 (i) unbound)])
1171      (M1 (make-Class) 6)))
1172
1173  (error? ; duplicate definition of M1
1174    (letrec-classes ([One () (<root>) () (M1 () 0)]
1175                     [Two () (<root>) () (M1 () 0)])
1176      0))
1177
1178  (eqv?
1179    (letrec-classes ([Pop () (<root>) () (M1 () 0)])
1180      (letrec-classes ([One () (Pop) () (M1 () 1)]
1181                       [Two () (<root>) () (M1 () 2)])
1182        (M1 (make-Two))))
1183    2)
1184
1185  (error? ; duplicate definition of M2
1186    (letrec-classes ([Pop () (<root>)  () (M1 () 0)])
1187      (letrec-classes ([One () (Pop) () (M1 () 1) (M2 () 2)]
1188                       [Two () (Pop) () (M2 () 2)])
1189          0)))
1190
1191  (equal?
1192    (letrec-classes ([Pop () (<root>)  () (M1 () 0)])
1193      (letrec-classes ([One () (Pop) () (M1 () 1)]
1194                       [Two () (Pop) () (M2 () 2)])
1195        (let ([M2* M2])
1196          (letrec-classes ([Three () (One) () (M1 () 3) (M2 () 4)])
1197            (list (M1 (make-Pop))
1198                  (M1 (make-One))
1199                  (M1 (make-Two))
1200                  (M2* (make-Two))
1201                  (M1 (make-Three))
1202                  (M2 (make-Three)))))))
1203    '(0 1 0 2 3 4))
1204
1205  (error? ; variable ingnacious is unbound
1206    (letrec-classes ([Pop () (<root>) ([ingnacious 1])])
1207      (letrec-classes ([One () (<root>) () (M1 () ingnacious)])
1208        (M1 (make-One)))))
1209
1210  (equal?
1211    (letrec-classes ([Pop () (<root>) ([i 1]) [get () i]])
1212      (letrec-classes ([One () (Pop) ([i 2]) [get () (list (super) i)]])
1213        (get (make-One))))
1214    '(1 2))
1215
1216  (error? ; invalid syntax class
1217    (let ([Class #f])
1218      (letrec-classes ([Class () (<root>) ()])
1219        (let ([Class Class])
1220          0))))
1221
1222  (eqv?
1223    (letrec-classes ([Class () (<root>) ()])
1224      (let ([Class #f]
1225            [foo (make-Class)])
1226        (Class? foo)))
1227    #t)
1228
1229  ; Here are some pretty trivial (i.e. relatively easy to follow by hand) test cases.
1230  ; They cover some pretty basic functionality (specifying classes without making them, etc.)
1231
1232  (eq?
1233  ;; simplest example...
1234  (letrec-classes ([Empty () (<root>)
1235                          ()])
1236    0)
1237  0)
1238
1239  (eq?
1240  ;; It's okay for ivars in separate classes to have the same name.
1241  (letrec-classes ([One () (<root>) ((var 0))]
1242                   [Two  () (<root>) ((var 0))])
1243    0)
1244  0)
1245
1246  (eq?
1247  ;; naive inheritence example
1248  (letrec-classes ([One () (<root>) ()])
1249    (letrec-classes ([Two  () (One) ()])
1250    0))
1251  0)
1252
1253  (eq?
1254  ;; Actually make a class
1255  (letrec-classes ([Empty () (<root>)
1256                          ()])
1257    (let ([mt (make-Empty)])
1258      0))
1259  0)
1260
1261  (eq?
1262  ;; simple example of using class formals in base-init
1263  (letrec-classes ([One (i) (<root>) ()])
1264    (letrec-classes ([Two (j) (One j) ()])
1265    0))
1266  0)
1267
1268  (eq?
1269  ;; simple example of using class formal in ivar-init.
1270  (letrec-classes ([Class (i) (<root>)
1271                          ((var i))])
1272    0)
1273  0)
1274
1275  (eq?
1276  ;; ivar-init's can see the previous ivar.
1277  (letrec-classes ([Class () (<root>)
1278                          ((var1 0)
1279                           (var2 var1))])
1280    0)
1281  0)
1282
1283
1284  (eq?
1285  ;; parameters to methods are visible in methods
1286  (letrec-classes ([Class () (<root>) ()
1287                          (M1 (i) i)])
1288    0)
1289  0)
1290
1291  (eq?
1292  ;; "self" is implicitly added to method environments.
1293  (letrec-classes ([Class () (<root>) ()
1294                          (M1 () self)])
1295    0)
1296  0)
1297
1298  (eq?
1299  ;; inheritance hierarchy can share methods
1300  (letrec-classes ([Pop () (<root>) ()
1301                        (M1 () 0)])
1302    (letrec-classes ([One () (Pop) ()
1303                          (M1 () 1)]
1304                     [Two () (Pop) ()
1305                          (M1 () 2)])
1306      0))
1307  0)
1308
1309  (eq?
1310  ;; more windy inheritance hierarchy
1311  (letrec-classes ([Pop () (<root>) () (M1 () 0)])
1312    (letrec-classes ([One () (Pop) () (M1 () 1)]
1313                     [Two () (Pop) () (M2 () 2)])
1314      (letrec-classes ([Three () (One) ()
1315                              (M1 () 1)
1316                              (M3 () 2)]
1317                       [Four () (Two) ()
1318                              (M2 () 1)
1319                              (M4 () 2)])
1320        0)))
1321  0)
1322
1323  (eq?
1324  ;; Skip a generation before overloading...
1325  (letrec-classes ([Pop () (<root>) () (M1 () 0)])
1326    (letrec-classes ([One () (Pop) ()])
1327      (letrec-classes ([Three () (One) ()
1328                              (M1 () 1)
1329                              (M3 () 2)])
1330        0)))
1331  0)
1332
1333  (eq?
1334  ;; classes in the same block can see each other.
1335  (letrec-classes ([One () (<root>) () (M1 () (make-Two))]
1336                   [Two () (<root>) ()])
1337    0)
1338  0)
1339
1340  (eq?
1341  ;; classes in the same block can call each other's methods.
1342  (letrec-classes ([One () (<root>) () (M1 (obj) (M2 obj))]
1343                   [Two () (<root>) () (M2 () 3)])
1344    0)
1345  0)
1346
1347  (eq?
1348  ;; class methods in the same block can be seen in base inits
1349  (letrec-classes ([Pop (i j) (<root>) ()])
1350    (letrec-classes ([One () (<root>) () (M1 (obj) (M2 obj))]
1351                     [Two () (Pop (M1 (make-One)) 5) () (M2 () 3)])
1352      0))
1353  0)
1354
1355  (eq?
1356  ;; subclass methods can see superclass instance vars
1357  (letrec-classes ([Pop () (<root>) ([i 1])])
1358    (letrec-classes ([One () (Pop) () (M1 () i)])
1359      0))
1360  0)
1361
1362
1363  (eq?
1364  ;; class names should become unique
1365  (letrec-classes ([Class () (<root>) ()])
1366    (letrec-classes ([Class () (<root>) ()])
1367      0))
1368  0)
1369
1370  (eq?
1371  ;; class names should not clash with variables either
1372  (let ([Class #f])
1373    (letrec-classes ([Class () (<root>) ()])
1374      (letrec-classes ([Class () (<root>) ()])
1375        0)))
1376  0)
1377
1378
1379  (eq?
1380  ;; Variables bound outside letrec-classes should be visible
1381  (let ([bound-var #f])
1382    (letrec-classes ([Super (i) (<root>) ()])
1383      (letrec-classes ([Class () (Super bound-var) ([i bound-var])
1384                            (M1 () bound-var)])
1385        0)))
1386  0)
1387
1388  (eq?
1389  ;; Number has one instance variable that holds a number and one method
1390  ;; that returns the number.
1391  (letrec-classes ([Number (num^) (<root>)
1392                           ((num num^))
1393                           (Val () num)])
1394    (let ([nb1 (make-Number 1)]
1395          [nb2 (make-Number 2)])
1396      (+ (Val nb1) (Val nb2))))
1397  ;; result: 3
1398  3)
1399
1400  (eq?
1401  ;; test out method binding
1402  (letrec-classes ([Pop () (<root>) () (MP1 () 0) (MP2 (i) 0)])
1403    (letrec-classes ([One () (Pop) () (M1 () 1)])
1404      (letrec-classes ([Two () (One) () (M2 (i j) 2) (MP1 () 2)])
1405        (letrec-classes ([Three () (Two) () (MP2 (i) 3) (M3 () 3)])
1406          0))))
1407  0)
1408
1409  ; Mark Meiss
1410
1411  (eq?
1412  (let ([object (letrec-classes
1413                  ([duo (n) (<root>)
1414                     ([n n])
1415                     (plus  () (+ n 2))
1416                     (times () (* n 2))
1417                     (expt  () (* n n))
1418                     (export ()
1419                       (let ([vec (make-vector 4)])
1420                         (vector-set! vec 0 self)
1421                         (vector-set! vec 1 plus)
1422                         (vector-set! vec 2 times)
1423                         (vector-set! vec 3 expt)
1424                         vec))])
1425                  (export (make-duo 6)))])
1426    (* ((vector-ref object 1) (vector-ref object 0))
1427       (+ ((vector-ref object 2) (vector-ref object 0))
1428          ((vector-ref object 3) (vector-ref object 0)))))
1429
1430  ; should evaluate to 384
1431  384)
1432
1433  ;------------------------------------------------------------------------
1434
1435  (eq?
1436  (letrec ([class-maker (lambda (n)
1437                          (if (zero? n)
1438                              (letrec-classes
1439                                ([zero () (<root>)
1440                                   ()
1441                                   (get-n () 0)])
1442                                (cons (make-zero) get-n))
1443                              (letrec-classes
1444                                ([succ () (<root>)
1445                                   ()
1446                                   (get-n () (let ([prev (class-maker (sub1 n))])
1447                                               (add1 ((cdr prev) (car prev)))))])
1448                                (cons (make-succ) get-n))))]
1449           [fib (lambda (n)
1450                  (if (< ((cdr n) (car n)) 2)
1451                      ((cdr n) (car n))
1452                      (+ (fib (class-maker (sub1 ((cdr n) (car n)))))
1453                         (fib (class-maker (sub1 (sub1 ((cdr n) (car n)))))))))])
1454    (fib (class-maker 7)))
1455
1456  ; should evaluate to 13
1457  13)
1458
1459  ;------------------------------------------------------------------------
1460
1461  (eq?
1462  (letrec-classes ([<route> (a b c) (<root>)
1463                     ([a (+ a a)]
1464                      [b (+ a b)]
1465                      [c (+ b c)])
1466                     (get-b () b)
1467                     (sum (a) (+ a (+ (get-b self) c)))])
1468    (sum (make-<route> 1 2 3) 4))
1469
1470  ; should evaluate to 15
1471  15)
1472
1473  ;------------------------------------------------------------------------
1474
1475  (equal?
1476  (letrec-classes ([A (x y) (<root>)
1477                      ([x x] [y y])
1478                      (get-x () x)
1479                      (get-y () y)
1480                      (test (object)
1481                        (if (A? object)
1482                            (+ (- (get-x self) (get-x object))
1483                               (- (get-y self) (get-y object)))
1484                            (* (get-x self) (get-y self))))])
1485    (letrec-classes ([B () (A 2 3)
1486                      ()
1487                        (become-if-not-A (object)
1488                          (if (A? object) self object))]
1489                     [C (x y) (A x y)
1490                        (#;
1491                         [x x]
1492                         #;
1493                         [y y])])
1494      (let ([a-var (make-A 3 4)]
1495            [b-var (make-B)]
1496            [c-var (make-C 2 1)]
1497            [vec (make-vector 4)])
1498        (vector-set! vec 0 (test a-var b-var))
1499        (vector-set! vec 1 (test a-var c-var))
1500        (set! b-var (become-if-not-A b-var b-var))
1501        (vector-set! vec 2 (test a-var b-var))
1502        (set! b-var (become-if-not-A b-var c-var))
1503        (vector-set! vec 3 (test a-var b-var))
1504        vec)))
1505
1506  ; should evaluate to #(2 4 2 2)
1507  '#(2 4 2 2))
1508
1509  ;------------------------------------------------------------------------
1510
1511  #;
1512  (equal?
1513    (letrec-classes ([fish (head tail) (<root>)
1514                       ([head head] [tail tail])
1515                       (behead () (set! head tail))
1516                       (betail () (set! tail head))
1517                       (get-head () head)
1518                       (get-tail () tail)])
1519      (letrec-classes ([guppy (head tail) (fish head tail)
1520                         ()
1521                         (behead () (open-instance fish "" self) (set! head (cons tail tail)))
1522                         (betail () (open-instance fish "" self) (set! tail (cons head head)))])
1523        (letrec-classes ([minnow (head tail) (guppy head tail)
1524                           ()
1525                           (behead () (begin (super) (set! betail behead)))
1526                           (betail () (begin (super) (set! behead betail)))])
1527          (let ([fishy-1 (make-fish 4 8)]
1528                [fishy-2 (make-guppy 5 9)])
1529            (let ([fishy-red (make-minnow fishy-1 fishy-2)])
1530              (behead fishy-1)
1531              (betail fishy-2)
1532              (behead fishy-red)
1533              (betail fishy-red)
1534              (get-tail (cdr (get-head fishy-red))))))))
1535
1536  ; should evaluate to (5 . 5)
1537  '(5 . 5))
1538
1539  ; Brooke Chenoweth
1540
1541  (equal?
1542  ;; objects shouldn't be identifiable as vectors or procedures
1543  (letrec-classes ([foo () (<root>) ()])
1544    (let ([obj (make-foo)])
1545      (cons (foo? obj)
1546        (cons (procedure? obj)
1547          (cons (vector? obj) '())))))
1548  ; should return '(#t #f #f)
1549  '(#t #f #f))
1550
1551  (eq?
1552  ;; We should be able to package up methods for outside use
1553  (let ([foo-package
1554          (letrec-classes ([foo (x) (<root>)
1555                             ((x x))
1556                             (get-x () x)])
1557            (let ([v (make-vector 3)])
1558              (vector-set! v 0
1559                (lambda (x) (make-foo x))) ; foo-maker
1560              (vector-set! v 1
1561                (lambda (x) (foo? x))) ; foo?
1562              (vector-set! v 2
1563                (lambda (inst) (get-x inst))) ; get-x
1564              v))])
1565    (let ([make-foo (vector-ref foo-package 0)]
1566          [foo? (vector-ref foo-package 1)]
1567          [foo-get-x (vector-ref foo-package 2)])
1568      (let ([r (letrec-classes ([R () (<root>) ()]) (make-R))]
1569            [f (make-foo 4)])
1570        (if (foo? r)
1571            (foo-get-x r)
1572            (if (foo? f)
1573                (foo-get-x f)
1574                -100)))))
1575  ; should return 4
1576  4)
1577
1578  (equal?
1579  (letrec-classes ([A (x y) (<root>)
1580                     ((s (+ x y))
1581                      (d (- x y)))
1582                     (m1 () (- s d))
1583                     (m2 () (+ s d))]
1584                   [R () (<root>) ()])
1585    (letrec-classes ([B (x y z) (A y z)
1586                       ((p (* x y)))
1587                       (m1 () (+ (super) p))
1588                       (m3 () (- (m2 self) p))])
1589      (let ([robj (make-R)]
1590            [aobj (make-A 1 2)] ; s = 3, d = -1
1591            [bobj (make-B 3 4 5)] ; s = 9, d = -1, p = 12
1592            [gather-results
1593              (lambda (obj)
1594                (and (A? obj)
1595                     (cons (m1 obj)
1596                       (cons (m2 obj)
1597                         (cons (if (B? obj)
1598                                   (m3 obj)
1599                                   #f)
1600                           '())))))]
1601            [v (make-vector 3)])
1602        (vector-set! v 0 (gather-results robj))
1603        (vector-set! v 1 (gather-results aobj))
1604        (vector-set! v 2 (gather-results bobj))
1605        v)))
1606  ; should return #( #f (4 2 #f) (22 8 -4))
1607  '#(#f (4 2 #f) (22 8 -4)))
1608
1609
1610  ;; Allen Lee
1611
1612  (equal?
1613  (letrec-classes ([superguy (x y) (<root>)
1614                     ([x (* x x)]
1615                      [y (let ([x 3])
1616                           (+ x (- y y)))]
1617                      [z (lambda (x) (+ x x))])
1618                      (getX () x)
1619                      (getY () y)])
1620    (letrec-classes ([subguy (x y) (superguy (+ x x) (+ y y))
1621                       ([new-x x])
1622                       (plus (y) (+ new-x y))])
1623      (letrec-classes ([subsubguy (x y z) (subguy
1624                                            (+ (+ x y) z)
1625                                            (getY (make-subguy x (* y z))))
1626                         ()
1627                         (minus (y) (- new-x y))])
1628        (let ([supe (make-superguy 2 1)]
1629              [sub (make-subguy 3 4)]
1630              [subsub (make-subsubguy 1 2 3)])
1631          (letrec ([map (lambda (p ls)
1632                          (if (null? ls)
1633                              '()
1634                              (cons (p (car ls))
1635                                (map p (cdr ls)))))])
1636            (let ([true (if (superguy? supe)
1637                            (if (superguy? sub)
1638                                (if (superguy? subsub)
1639                                    (if (subguy? sub)
1640                                        (if (subguy? subsub)
1641                                            (if (subsubguy? subsub)
1642                                                (if (not (subsubguy? sub))
1643                                                    (if (not (subsubguy? supe))
1644                                                        (not (subguy? supe))
1645                                                        #f)
1646                                                    #f)
1647                                                #f)
1648                                            #f)
1649                                        #f)
1650                                    #f)
1651                                #f)
1652                            #f)]
1653                  [x-es (map (lambda (obj)
1654                               (getX obj))
1655                          (cons supe (cons sub (cons subsub '()))))]
1656                  [y-es (map (lambda (obj)
1657                               (getY obj))
1658                          (cons supe (cons sub (cons subsub '()))))])
1659              (cons true (cons x-es y-es))))))))
1660  '(#t (4 36 144) 3 3 3))
1661
1662  (equal?
1663    (letrec-classes ([NullEntity () (<root>)
1664                       ()
1665                       (notifyme (evt) (if #f #f))])
1666      (letrec-classes ([SchmentityEntity (int) (NullEntity)
1667                         ([value int])
1668                         (notifyme (evt)
1669                           (evt value))]
1670                       [Pool (size) (<root>)
1671                         ([numElements 0]
1672                          [pool (make-vector size)]
1673                          [observers (cons (make-NullEntity) '())])
1674                         (add (item)
1675                           (begin
1676                             (incrementElements self)
1677                             (if (not (< (getCurrentIndex self) (vector-length pool)))
1678                                 ;; need to re-expand the pool
1679                                 (let ([newPool (make-vector
1680                                                  (* (getSize self)
1681                                                    (getLoadFactor self)))])
1682                                   (letrec ([loop
1683                                              (lambda (n)
1684                                                (if (= n (getCurrentIndex self))
1685                                                    (begin
1686                                                      (vector-set! newPool n item)
1687                                                      newPool)
1688                                                    (begin
1689                                                      (vector-set! newPool n
1690                                                        (vector-ref pool n))
1691                                                      (loop (add1 n)))))])
1692                                     (setPool self (loop 0))))
1693                                 (vector-set! pool (getCurrentIndex self) item))))
1694                         (remove (item)
1695                           (letrec ([loop
1696                                      (lambda (n)
1697                                        (if (not (= n (getNumElements self)))
1698                                            (if (= (vector-ref pool n) item)
1699                                                (letrec
1700                                                    ([shift
1701                                                       (lambda (start)
1702                                                         (if (= start (getCurrentIndex self))
1703                                                             (vector-set! pool
1704                                                               start (void))
1705                                                             (begin
1706                                                               (vector-set! pool start
1707                                                                 (vector-ref pool (+ start 1)))
1708                                                               (shift (+ n 1)))))])
1709                                                  (shift n))
1710                                                (decrementElements self))
1711                                            (loop (+ n 1))))])
1712                             (loop 0)))
1713                         (isEmpty () (= (getNumElements self) 0))
1714                         (getCurrentIndex () (- (getNumElements self) 1))
1715                         (getSize () (vector-length pool))
1716                         (getNumElements () numElements)
1717                         (incrementElements ()
1718                           (set! numElements (+ numElements 1)))
1719                         (decrementElements ()
1720                           (if (not (= (getNumElements self) 0))
1721                               (set! numElements (- numElements 1))))
1722                         (getPool () pool)
1723                         (setPool (newPool)
1724                           (set! pool newPool))
1725                         (notify (evt)
1726                           (letrec ([loop
1727                                      (lambda (ls)
1728                                        (if (null? ls)
1729                                            '()
1730                                            (cons (notifyme (car ls) evt)
1731                                              (loop (cdr ls)))))])
1732                             (loop observers)))
1733                         (subscribe (obj)
1734                           (set! observers (cons obj observers)))
1735                         (purgeObservers ()
1736                           (set! observers (cons (make-NullEntity) '())))
1737                         (getLoadFactor () 2)
1738                         (contains (item)
1739                           (letrec ([loop
1740                                      (lambda (n)
1741                                        (if (< n (getNumElements self))
1742                                            (if (= item (vector-ref pool n))
1743                                                #t
1744                                                (loop (+ n 1)))
1745                                            #f))])
1746                             (loop 0)))])
1747        (let ([pool (make-Pool 37)])
1748          (letrec ([addToPool (lambda (n)
1749                                (if (= n 0)
1750                                    (isEmpty pool)
1751                                    (begin
1752                                      (add pool n)
1753                                      (addToPool (sub1 n)))))])
1754            (addToPool 42)
1755            (addToPool 23)
1756            (remove pool 14)
1757            (subscribe pool (make-SchmentityEntity 23))
1758            (subscribe pool (make-SchmentityEntity 14))
1759            (let ([notified (notify pool (lambda (x) (* x 3)))])
1760              (cons (isEmpty pool)
1761                (cons (getCurrentIndex pool)
1762                  (cons (getPool pool)
1763                    (cons (getNumElements pool)
1764                      (cons (contains pool 23)
1765                        (cons (contains pool 15)
1766                          notified)))))))))))
1767  ; should evaluate to (#f 63 #74(some-huge-vector-with-65-elements) 64 #t #t 42 69 #<void>)
1768    `(#f 63 #74(42 41 40 39 38 37 36 35 34 33 32 31 30 29 28 27 26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0) 64 #t #t 42 69 ,(void)))
1769
1770  (equal?
1771    (letrec-classes ([broken () (<root>)
1772                       ([vec (make-vector 5)])
1773                       (object-or-vector (n)
1774                         (if (< n 7)
1775                             (begin
1776                               (vector-set! vec 0 14)
1777                               (vector-set! vec 1 15)
1778                               (vector-set! vec 2 16)
1779                               vec)
1780                             self))])
1781      (letrec-classes ([fixed-broken (num) (broken)
1782                         ()
1783                         (object-or-vector (n)
1784                           (* n n))])
1785        (let ([all-k (make-broken)])
1786          (let ([still-valid1 (if (vector? (object-or-vector all-k 4))
1787                                  (vector-ref (object-or-vector all-k 4) 0)
1788                                  #f)]
1789                [still-valid2 (if (vector? (object-or-vector all-k 5))
1790                                  (vector-ref (object-or-vector all-k 5) 1)
1791                                  #f)]
1792                [still-valid3 (if (vector? (object-or-vector all-k 6))
1793                                  (vector-ref (object-or-vector all-k 6) 2)
1794                                  #f)]
1795                [is-vector? (vector? (object-or-vector all-k 7))]
1796                [fixed (make-fixed-broken 37)])
1797            (cons (object-or-vector fixed 37)
1798              (cons still-valid1
1799                (cons still-valid2
1800                  (cons still-valid3
1801                    (cons is-vector? '())))))))))
1802    ;; should return the list (14 15 16 #t)
1803    '(1369 14 15 16 #f))
1804
1805
1806  ;; Matthew Garrett
1807
1808  ;;; eopl-tests.ss
1809
1810  ;;; These test cases are translated as directly as possible from "Essentials
1811  ;;; of Programming Languages", 2nd Ed. by Friedman, Wand, and Haynes, Chapter
1812  ;;; 5, Objects and Classes.
1813
1814  (equal?
1815    ;;; Figure 5.1, A simple object-oriented program
1816    (letrec-classes
1817      ([c1 (x) (<root>)
1818        ([i x] [j (- 0 x)])
1819        (countup (d)
1820          (set! i (+ i d))
1821          (set! j (- j d)))
1822        (getstate () (list i j))])
1823      (let ([t1 0] [t2 0] [o1 (make-c1 3)])
1824        (set! t1 (getstate o1))
1825        (countup o1 2)
1826        (set! t2 (getstate o1))
1827        (list t1 t2)))
1828  '((3 -3) (5 -5)))
1829
1830  (eq?
1831    ;;; page 172, odd-even
1832    (letrec-classes
1833      ([oddeven () (<root>)
1834        ()
1835        (even (n)
1836          (if (zero? n)
1837              1
1838              (odd self (sub1 n))))
1839        (odd (n)
1840          (if (zero? n)
1841              0
1842              (even self (sub1 n))))])
1843      (let ([o1 (make-oddeven)])
1844        (odd o1 13)))
1845  1)
1846
1847  (eq?
1848    ;;; Figure 5.2 Object-oriented program for summing the leaves of a tree
1849    (letrec-classes ([<newroot> () (<root>) () [sum () (void)]])
1850      (letrec-classes
1851        ([interior_node (l r) (<newroot>)
1852          ([left l] [right r])
1853          (sum ()
1854            (+ (sum left) (sum right)))]
1855         [leaf_node (v) (<newroot>)
1856          ([value v])
1857          (sum () value)])
1858        (let ([o1 (make-interior_node
1859                    (make-interior_node
1860                      (make-leaf_node 3)
1861                      (make-leaf_node 4))
1862                    (make-leaf_node 5))])
1863          (sum o1))))
1864  12)
1865
1866  (equal?
1867    ;;; Figure 5.3 Classic example of inheritance: colorpoint
1868    (letrec-classes
1869      ([point (initx inity) (<root>)
1870        ([x initx] [y inity])
1871        (move (dx dy)
1872          (set! x (+ x dx))
1873          (set! y (+ y dy)))
1874        (get_location () (list x y))]
1875       [colorpoint (initx inity) (point initx inity)
1876        ([color 0])
1877        (set_color (c) (set! color c))
1878        (get_color () color)])
1879      (let ([p  (make-point       3  4)]
1880            [cp (make-colorpoint 10 20)])
1881        (move p 3 4)
1882        (set_color cp 87)
1883        (move cp 10 20)
1884        (list (get_location p) (get_location cp) (get_color cp))))
1885        ;;; should return '((6 8) (20 40) 87)
1886  '((6 8) (20 40) 87))
1887
1888  #;
1889    (equal?
1890      ;;; page 175, shadowing
1891      (letrec-classes
1892        ([c1 () (<root>)
1893          ([x 0] [y 0])
1894          (setx1 (v) (set! x v))
1895          (sety1 (v) (set! y v))
1896          (getx1 () x)
1897          (gety1 () y)])
1898        (letrec-classes
1899          ([c2 () (c1)
1900            ([y2 0])
1901            (sety2 (v) (set! y2 v))
1902            (getx2 () (open-instance c1 "" self) x)
1903            (gety2 () y2)])
1904          (let ([o2 (make-c2)])
1905            (setx1 o2 101)
1906            (sety1 o2 102)
1907            (sety2 o2 999)
1908            (list (getx1 o2) (gety1 o2) (getx2 o2) (gety2 o2)))))
1909          ;;; should return '(101 102 101 999)
1910  '(101 102 101 999))
1911
1912  (equal?
1913    ;;; page 176, redefining methods
1914    (letrec-classes
1915      ([c1 () (<root>)
1916        ()
1917        (m1 () 1)
1918        (m2 () (m1 self))]
1919       [c2 () (c1)
1920        ()
1921        (m1 () 2)])
1922      (let ([o1 (make-c1)] [o2 (make-c2)])
1923        (list (m1 o1) (m1 o2) (m2 o2))))
1924  '(1 2 2))
1925
1926  (equal?
1927    ;;; Figure 5.4 Example illustrating interaction of self and inheritance
1928    (letrec-classes
1929      ([c1 () (<root>)
1930        ()
1931        (m1 () 1)
1932        (m2 () 100)
1933        (m3 () (m2 self))]
1934       [c2 () (c1)
1935        ()
1936        (m2 () 2)])
1937      (let ([o1 (make-c1)] [o2 (make-c2)])
1938        (list (m1 o1)     ; 1
1939              (m2 o1)     ; 100
1940              (m3 o1)     ; 100
1941              (m1 o2)     ; 1 (from c1)
1942              (m2 o2)     ; 2 (from c2)
1943              (m3 o2))))  ; 2 (c1's m3 calls c2's m2)
1944  '(1 100 100 1 2 2))
1945
1946  (eq?
1947    ;;; Figure 5.5 Example demonstrating a need for static method dispatch
1948    (letrec-classes
1949      ([point (initx inity) (<root>)
1950        ([x initx] [y initx])
1951        (move (dx dy)
1952          (set! x (+ x dx))
1953          (set! y (+ y dy)))
1954        (getlocation ()
1955          (list x y))]
1956       [colorpoint (initx inity initcolor) (point 0 0)
1957        ([color initcolor])
1958        (set_color (c) (set! color c))
1959        (get_color () color)])
1960      (let ([o1 (make-colorpoint 3 4 172)])
1961        (get_color o1)))
1962  172)
1963
1964  (eq?
1965    ;;; Figure 5.6 Example illustrating interaction of super call with self
1966    (letrec-classes
1967      ([c1 () (<root>)
1968        ()
1969        (m1 () (m2 self))
1970        (m2 () 13)])
1971      (letrec-classes
1972        ([c2 () (c1)
1973          ()
1974          (m1 () (super))
1975          (m2 () 23)
1976          (m3 () (m1 self))])
1977        (letrec-classes
1978          ([c3 () (c2)
1979            ()
1980            (m1 () (super))
1981            (m2 () 33)])
1982          (let ([o3 (make-c3)])
1983            (m3 o3)))))
1984  33)
1985
1986  ; Jeremiah Willcock
1987
1988  (eq?
1989  (let ()
1990    (define-class (A n) (<root>)
1991      (ivars [next (foo n)])
1992      (methods
1993        [get-next () next]
1994        [get-length ()
1995          (if (null? next) 0 (+ 1 (get-length (get-next self))))]))
1996    (define (foo n) (if (zero? n) '() (make-A (- n 1))))
1997    (let ((a (make-A 10)))
1998      (get-length a)))
1999  10)
2000
2001  (eq?
2002  (letrec-classes ((A (n) (<root>) ((next
2003                                        (if (zero? n) '()
2004                                          (make-A (- n 1)))))
2005                                       (get-next () next)
2006                                       (get-length ()
2007                                        (if (null? next) 0
2008                                          (+ 1 (get-length (get-next self)))))))
2009        (let ((a (make-A 10)))
2010          (get-length a)))
2011  10)
2012
2013  ; should this really be an error?  It's not clear how to make base ivars
2014  ; visible in ivar inits efficiently if we want to do so.
2015  (error? ; variable oop-x1 is not bound
2016    (let ()
2017      (define-class (<a> oop-x) (<root>) (ivars [oop-x1 oop-x]))
2018      (define-class (<b> oop-x) (<a> oop-x) (ivars [oop-x2 (+ oop-x1 oop-x1)]))
2019      (define-class (<c> oop-x) (<b> oop-x) (ivars [oop-x3 (+ oop-x2 oop-x2)]))
2020      (define-class (<d> oop-x) (<c> oop-x) (ivars [oop-x4 (+ oop-x3 oop-x3)]))
2021      (define-class (<e> oop-x) (<d> oop-x) (ivars [oop-x5 (+ oop-x4 oop-x4)]))
2022      (define-class (<f> oop-x) (<e> oop-x) (ivars [oop-x6 (+ oop-x5 oop-x5)]))
2023      (define-class (<g> oop-x) (<f> oop-x) (ivars [oop-x7 (+ oop-x6 oop-x6)]))
2024      (define-class (<h> oop-x) (<g> oop-x) (ivars [oop-x8 (+ oop-x7 oop-x7)]))
2025      (define-class (<i> oop-x) (<h> oop-x) (ivars [oop-x9 (+ oop-x8 oop-x8)]) (methods [m () oop-x9]))
2026      (m (make-<i> 1))))
2027
2028  (eq?
2029    (let ()
2030      (define-class (<a> x0) (<root>)
2031        (ivars [x1 (+ x0 x0)]
2032               [x2 (+ x1 x1)]
2033               [x3 (+ x2 x2)]
2034               [x4 (+ x3 x3)]
2035               [x5 (+ x4 x4)]
2036               [x6 (+ x5 x5)]
2037               [x7 (+ x6 x6)]
2038               [x8 (+ x7 x7)]
2039               [x9 (+ x8 x8)])
2040        (methods [m () x9]))
2041      (m (make-<a> 1)))
2042  512)
2043
2044
2045  ; Abdulaziz Ghuloum
2046
2047  (begin
2048    (define-class (R) (<root>))
2049    #t)
2050  (eq?  (R? 0) #f)
2051
2052  (eq?  (R? (cons 1 2)) #f)
2053
2054  (eq?  (R? (make-vector 2)) #f)
2055
2056  (eq?  (R? (lambda () 4)) #f)
2057
2058  (eq?  (R? #f) #f)
2059
2060  (eq?  (R? #t) #f)
2061
2062  (eq?  (R? '()) #f)
2063
2064  (equal?
2065    (letrec-classes
2066      ([AA () (<root>)
2067        ([x 0][y 0])
2068            (get-x () x)
2069            (get-y () y)
2070            (set-x (a)
2071              (letrec-classes
2072                ([AA () (<root>)
2073                      ()
2074                      (set-x (a) (set! x a))])
2075                    (set-x (make-AA) a)))
2076            (set-y (a)
2077              (letrec-classes
2078                ([AA () (<root>)
2079                      ([y 0])
2080                      (set-y (a) (set! y a))])
2081                    (set-y (make-AA) a)))])
2082      (let ([a (make-AA)])
2083        (set-x a 5)
2084            (set-y a 0)
2085            (cons (get-x a) (get-y a))))
2086    '(5 . 0))
2087
2088  (eq?
2089    (letrec-classes
2090      ([<pair> (a b) (<root>)
2091        ([a a][b b])
2092            (car () a)
2093            (cdr () b)
2094            (set-car! (x) (set! a x))
2095            (set-cdr! (x) (set! b x))])
2096      (let ([cons (lambda (a b) (make-<pair> a b))]
2097            [pair? (lambda (x) (<pair>? x))])
2098            (let ([x (cons 4 5)])
2099              (let ([y (cons 3 4)])
2100            (set-car! y 12)
2101                (set-cdr! x y)
2102                (let ([cdr (cdr x)])
2103                  (if (pair? cdr)
2104                    (let ([car (car cdr)])
2105                          (if (pair? car) #f car))))))))
2106    12)
2107
2108  ; this doesn't test the oop system at all:
2109  #;
2110  (equal?
2111    (let
2112      ([letrec-classes
2113        (lambda (x y) (cons x y))]
2114       [<root> (lambda () 7)]
2115       [y (lambda () 3)]
2116       [x (lambda (y) y)]
2117       [self (cons 12 (cons 34 45))]
2118       [A (lambda (a b c d)
2119            (lambda ()
2120                      (let ([v (make-vector 4)])
2121                        (vector-set! v 0 a)
2122                        (vector-set! v 1 b)
2123                        (vector-set! v 2 c)
2124                        (vector-set! v 3 d)
2125                            v)))]
2126       [make (lambda (a b) b)]
2127       [inc-x (lambda (a b) (cons a b))]
2128       [s (lambda () 87)])
2129      (letrec-classes
2130        ([A (y) (<root>)
2131              ([x y])
2132              (inc-x (s) (begin self))])
2133            (inc-x (make-A 3) 3)))
2134  '(#4(3 7 3 (87 12 34 . 45)) 3 . 3))
2135
2136  (eq?
2137    (let ([let 0][lambda 1][letrec 2][if 5])
2138      (letrec-classes
2139        ([A (x) (<root>)
2140              ([x x])
2141              (inc-x (s) (begin (set! x (+ x s)) self))
2142              (get-x () x)])
2143            (get-x (inc-x (make-A 4) 3))))
2144    7)
2145
2146  ; Jeremiah Willcock
2147
2148  (eq?
2149    (letrec-classes () #f)
2150    #f)
2151
2152  (eq?
2153    (letrec-classes ((A () (<root>) ()))
2154      (letrec-classes ((B () (A) ()))
2155        (make-B)
2156        #f))
2157    #f)
2158
2159  (eq?
2160    (letrec-classes ((A () (<root>) () (foo () 5)))
2161      (letrec-classes ((B () (A) () (foo () 7) (bar () 8)))
2162        (foo (make-B))))
2163    7)
2164
2165  (equal?
2166    (letrec-classes
2167      ((A (x y) (<root>) ((x x) (y y))
2168        (get-x () x)
2169        (get-y () y)
2170        (set-x (value) (set! x value))))
2171      (let ((A (make-A 1 2)))
2172        (cons (get-x A) (get-y A))))
2173    '(1 . 2))
2174
2175  (eq?
2176    (letrec-classes ((A () (<root>) ()))
2177      (letrec-classes ((<root> () (A) () (foo () 5)))
2178        (foo (make-<root>))))
2179    5)
2180
2181  #;
2182  (equal?
2183    (letrec-classes
2184      ((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
2185        (get-x () (- x 3))
2186        (get-y () (* 2 y))))
2187      (letrec-classes
2188        ((<xroot> (z w) (A (* w z) (- w z)) ()
2189          (get-x () (open-instance A "" self) x)
2190          (set-x! (<yroot>) (open-instance A "" self) (set! x <yroot>))
2191          (call-get-x (set-x!) (get-x set-x!))
2192          (call-set-x! (A) (set-x! self A))))
2193        (let ((<zroot> (make-<xroot> 4 9)))
2194          (let ((x (get-x <zroot>))
2195                (y (get-y <zroot>))
2196                (x2 (call-get-x <zroot> <zroot>)))
2197            (cons x
2198              (cons y
2199                (cons x2
2200                  (let ((foo (set-x! <zroot> 7)))
2201                    (cons (get-x <zroot>) '())))))))))
2202    '(72 24 72 7))
2203
2204  #;
2205  (equal?
2206    (letrec-classes
2207      ((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
2208        (get-x () (- x 3))
2209        (get-y () (* 2 y))))
2210      (letrec-classes
2211        ((<xroot> (z w) (A (* w z) (- w z)) ()
2212          (get-x () (open-instance A "" self) x)
2213          (set-x! (<yroot>) (open-instance A "" self) (set! x <yroot>))
2214          (call-get-x (set-x!) (get-x set-x!))
2215          (call-set-x! (A) (set-x! self A))))
2216        (let ((<root> (make-<xroot> 4 9)))
2217          (let ((x (get-x <root>))
2218                (y (get-y <root>))
2219                (x2 (call-get-x <root> <root>)))
2220            (cons x
2221              (cons y
2222                (cons x2
2223                  (let ((foo (set-x! <root> 7)))
2224                    (cons (get-x <root>) '())))))))))
2225    '(72 24 72 7))
2226
2227  #;
2228  (equal?
2229    (letrec-classes
2230      ((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
2231        (get-x () (- x 3))
2232        (get-y () (* 2 y))))
2233      (letrec-classes
2234        ((<xroot> (z w) (A (* w z) (- w z)) ()
2235          (get-x () (open-instance A "" self) x)
2236          (set-x! (<root>) (open-instance A "" self) (set! x <root>))
2237          (call-get-x (set-x!) (get-x set-x!))
2238          (call-set-x! (A) (set-x! self A))))
2239        (let ((<root> (make-<xroot> 4 9)))
2240          (let ((x (get-x <root>))
2241                (y (get-y <root>))
2242                (x2 (call-get-x <root> <root>)))
2243            (cons x
2244              (cons y
2245                (cons x2
2246                  (let ((foo (set-x! <root> 7)))
2247                    (cons (get-x <root>) '())))))))))
2248    '(72 24 72 7))
2249
2250  (eq?
2251    (letrec-classes ((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
2252                      (get-x () x)))
2253      (letrec-classes
2254        ((<root> (z w) (A (* w z) (- w z)) ()
2255          (get-x () 7)
2256          (call-get-x (set-x!) (get-x set-x!))))
2257        (let ((<root> (make-<root> 4 9)))
2258          (call-get-x <root> <root>))))
2259    7)
2260
2261  (eq?
2262    (letrec-classes ((A () (<root>) ()))
2263      (letrec-classes
2264        ((<root> () (A) ()
2265          (set-x! (<root>) #f)))
2266        #f))
2267    #f)
2268
2269  #;
2270  (equal?
2271    (letrec-classes
2272      ((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
2273        (get-x () (- x 3))
2274        (get-y () (* 2 y))))
2275      (letrec-classes
2276        ((<root> (z w) (A (* w z) (- w z)) ()
2277          (get-x () (open-instance A "" self) x)
2278          (set-x! (<root>) (open-instance A "" self) (set! x <root>))
2279          (call-get-x (set-x!) (get-x set-x!))
2280          (call-set-x! (A) (set-x! self A))))
2281        (let ((<root> (make-<root> 4 9)))
2282          (let ((x (get-x <root>))
2283                (y (get-y <root>))
2284                (x2 (call-get-x <root> <root>)))
2285            (cons x
2286              (cons y
2287                (cons x2
2288                  (let ((foo (set-x! <root> 7)))
2289                    (cons (get-x <root>) '())))))))))
2290    '(72 24 72 7))
2291
2292  (equal?
2293    (letrec-classes
2294      ((xself () (<root>) ((x 7))
2295        (xisa-vtable? () (let ((self 5)) (+ x self)))))
2296      (cons
2297        (xisa-vtable? (make-xself))
2298        (xself? (make-xself))))
2299    '(12 . #t))
2300
2301  (equal?
2302    (letrec-classes
2303      ((xself () (<root>) ((x 7))
2304        (isa-vtable? () (let ((self 5)) (+ x self)))))
2305      (cons
2306        (isa-vtable? (make-xself))
2307        (xself? (make-xself))))
2308    '(12 . #t))
2309
2310  (equal?
2311    (letrec-classes ; Cannot have class named "self"
2312      ((self () (<root>) ((x 7))
2313        (isa-vtable? () (let ((self 5)) (+ x self)))))
2314      (cons
2315        (isa-vtable? (make-self))
2316        (self? (make-self))))
2317    '(12 . #t))
2318
2319  (eq?
2320    (let ((self 5))
2321      (letrec-classes ((A () (<root>) ()
2322                        (foo () self)
2323                        (bar () 5)))
2324        (let ((self 7))
2325          (bar (foo (make-A))))))
2326    5)
2327
2328  (equal?
2329    (letrec-classes ((A () (<root>) ())
2330                     (B () (<root>) ()))
2331      (letrec-classes ((C () (A) ()))
2332        (letrec-classes ((D () (C) ()))
2333          (let ((isa-grid-entry (lambda (obj)
2334                    (cons (A? obj)
2335                    (cons (B? obj)
2336                    (cons (C? obj)
2337                    (cons (D? obj) '())))))))
2338            (letrec ((map (lambda (f l)
2339                      (if (null? l) '()
2340                        (cons (f (car l))
2341                              (map f (cdr l)))))))
2342              (map isa-grid-entry
2343                (cons 5
2344                (cons (make-A)
2345                (cons (make-B)
2346                (cons (make-C)
2347                (cons (make-D) '())))))))))))
2348    '((#f #f #f #f)
2349      (#t #f #f #f)
2350      (#f #t #f #f)
2351      (#t #f #t #f)
2352      (#t #f #t #t)))
2353
2354  (equal?
2355    (letrec-classes ((A () (<root>) ()))
2356      (let ((z (make-A)))
2357        (cons (pair? z)
2358        (cons (vector? z)
2359        (cons (null? z)
2360        (cons (procedure? z)
2361        (cons (boolean? z)
2362        '())))))))
2363    '(#f #f #f #f #f))
2364
2365  #;
2366  (equal?
2367    (let ((x 7))
2368      (letrec-classes ((A () (<root>) ((y x))))
2369        (letrec-classes ((B () (A) () (set-x (value) (set! x value))
2370                                      (get-y () (open-instance A "" self) y)))
2371          (let ((w (make-B)))
2372            (set-x w 9)
2373            (cons (get-y w) x)))))
2374    '(7 . 9))
2375
2376  (equal?
2377    (letrec-classes ((A () (<root>) () (x () 1) (y () 2)))
2378      (letrec-classes ((B () (A) () (x () (- 0 (super))) (z () 3)))
2379        (letrec-classes ((C () (B) () (y () (+ 10 (super)))
2380                                      (z () (- 0 (super)))))
2381          (let ((a (make-A)) (b (make-B)) (c (make-C)))
2382            (cons
2383              (cons (x a) (y a))
2384            (cons
2385              (cons (x b) (cons (y b) (z b)))
2386            (cons
2387              (cons (x c) (cons (y c) (z c))) '())))))))
2388    '((1 . 2) (-1 2 . 3) (-1 12 . -3)))
2389
2390  (eq?
2391    ; Based on suggestion in class about constructors making the same class
2392    (letrec-classes ((A (n) (<root>) ((next
2393                                      (if (zero? n) '()
2394                                        (make-A (- n 1)))))
2395                                     (get-next () next)
2396                                     (get-length ()
2397                                      (if (null? next) 0
2398                                        (+ 1 (get-length (get-next self)))))))
2399      (let ((a (make-A 10)))
2400        (get-length a)))
2401    10)
2402
2403  (equal?
2404    ; Automatic differentiator -- expressions of one variable w/ int constants
2405    (letrec-classes ((Differentiable () (<root>) () (compute () #f)
2406                                                    (diff () #f)))
2407      (letrec-classes (
2408        (sum (a b) (Differentiable) ((a a) (b b))
2409                                    (compute ()
2410                                      (lambda (x)
2411                                        (+ ((compute a) x)
2412                                           ((compute b) x))))
2413                                    (diff () (make-sum (diff a) (diff b))))
2414        (prod (a b) (Differentiable) ((a a) (b b))
2415                                     (compute ()
2416                                      (lambda (x)
2417                                        (* ((compute a) x)
2418                                           ((compute b) x))))
2419                                     (diff () (make-sum
2420                                      (make-prod a (diff b))
2421                                      (make-prod b (diff a)))))
2422        (pow (a b) (Differentiable) ((a a) (b b)) ; Constant exponent
2423                                    (compute ()
2424                                      (letrec ((real-pow
2425                                        (lambda (base power)
2426                                          (if (zero? power)
2427                                            1
2428                                            (* base
2429                                               (real-pow base (- power 1)))))))
2430                                        (lambda (x)
2431                                          (real-pow ((compute a) x) b))))
2432                                    (diff ()
2433                                      (if (zero? b)
2434                                        (make-constant 0)
2435                                        (make-prod (make-constant b)
2436                                          (make-prod
2437                                           (make-pow a (- b 1))
2438                                           (diff a))))))
2439        (constant (x) (Differentiable) ((x x))
2440                                       (compute ()
2441                                        (lambda (z) x))
2442                                       (diff () (make-constant 0)))
2443        (variable () (Differentiable) ()
2444                                      (compute ()
2445                                        (lambda (x) x))
2446                                      (diff () (make-constant 1))))
2447      (let ((+ (lambda (a b) (make-sum a b)))
2448            (- (lambda (a b) (make-sum a (make-prod b (make-constant -1)))))
2449            (* (lambda (a b) (make-prod a b)))
2450            (^ (lambda (a b) (make-pow a b)))
2451            (! (lambda (x) (make-constant x)))
2452            (x (make-variable)))
2453        (let ((fun (+ (^ (- x (! 1)) 9) (* x (! 7)))))
2454          (letrec ((diff-at-values (lambda (fun ndiffs vals)
2455                    (if (zero? ndiffs)
2456                      '()
2457                      (cons
2458                        (letrec ((map (lambda (f l)
2459                                  (if (null? l) '()
2460                                    (cons (f (car l))
2461                                          (map f (cdr l)))))))
2462                          (map (compute fun) vals))
2463                        (diff-at-values (diff fun) (sub1 ndiffs) vals))))))
2464            (diff-at-values fun 4 '(-5 -4 -3 -2 -1 0 1 2 3 4 5)))))))
2465    '((-10077731 -1953153 -262165 -19697 -519 -1 7 15 533 19711 262179)
2466      (15116551 3515632 589831 59056 2311 16 7 16 2311 59056 589831)
2467      (-20155392 -5625000 -1179648 -157464 -9216 -72 0 72 9216 157464 1179648)
2468      (23514624 7875000 2064384 367416 32256 504 0 504 32256 367416 2064384)))
2469
2470  ; Robert George
2471
2472  (eq?
2473    (letrec-classes ([A () (<root>)
2474                       ([x 1]
2475                        [y (letrec-classes ([B () (<root>)
2476                                              ([x2 2])
2477                                              (get-x () (if x2 x2 (letrec-classes ([C () (<root>)
2478                                                                                     ([x3 3])
2479                                                                                     (get-x () x3)])
2480                                                                    (let ([obj (make-C)])
2481                                                                      (get-x obj)))))])
2482                             (let ([obj (make-B)])
2483                               (get-x obj)))])
2484                       (get-x () x)])
2485      (get-x (make-A)))
2486    1)
2487
2488  (equal?
2489    (letrec ([map (lambda (proc ls)
2490                    (if (null? ls)
2491                        '()
2492                        (cons (proc (car ls)) (map proc (cdr ls)))))])
2493      (letrec-classes ([A () (<root>)
2494                         ([x 0])
2495                         (square-and-set (y) (let ([val (* y y)])
2496                                               (set! x (+ x val))
2497                                               val))
2498                         (get-x () x)])
2499        (let ([obj (make-A)])
2500          (let ([ls (map (lambda (x) (square-and-set obj x)) '(1 2 3 4 5))])
2501            (cons ls (get-x obj))))))
2502    '((1 4 9 16 25) . 55))
2503
2504  #;
2505  (eq?
2506    (let ([x 5])
2507      (letrec-classes ([A () (<root>)
2508                         ([x 3])
2509                         (get-x () x)])
2510        (letrec-classes ([B () (A)
2511                          ([y 4])
2512                          (get-x () (open-instance A "" self) x)])
2513          (+ x (get-x (make-B)) (get-x (make-A))))))
2514    11)
2515
2516  (eq?
2517    (letrec-classes ([A () (<root>)
2518                       ([x 1] [y (+ x x)])
2519                       (get-x () x)
2520                       (get-y () y)])
2521      (letrec-classes ([B () (A)
2522                        ([z 3])
2523                        (add-em () (+ (get-x (make-A)) (get-x (make-B)) z))])
2524        (add-em (make-B))))
2525    5)
2526
2527  (eq?
2528    (letrec-classes ([A () (<root>)
2529                       ([x 1])
2530                       (get-x () x)])
2531      (letrec-classes ([B () (A)
2532                        ([y 3])
2533                        (get-x () (super))])
2534        (get-x (make-B))))
2535    1)
2536
2537  (eq?
2538    (letrec-classes ([A () (<root>)
2539                       ([x 1])
2540                       (create-A () (make-A))])
2541      (letrec-classes ([B () (A)
2542                        ([y 2])
2543                        (do-it () (A? (create-A (make-B))))])
2544        (do-it (make-B))))
2545    #t)
2546
2547  (eq?
2548    (let ()
2549      (define-syntax albatross
2550        (syntax-rules ()
2551          [(_ f m)
2552           (begin
2553             (define-class (fowl) (<root>) (ivars [x 77]) (methods [m () x]))
2554             (define f (lambda () (make-fowl))))]))
2555      (albatross alcatraz pelican)
2556      (pelican (alcatraz)))
2557    77)
2558
2559  (error? ; variable make-fowl is not bound
2560    (make-fowl))
2561
2562  ; Jeremy Siek
2563
2564  (eq?
2565    (letrec-classes ((shape () (<root>) () (foo (s) s)))
2566      (letrec-classes ((rect () (shape) () (get-h () 0) (foo (s) s)))
2567        (let ([r (make-rect)]) (get-h r))))
2568    0)
2569)
2570