You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2570 lines
80 KiB
Scheme
2570 lines
80 KiB
Scheme
;;; oop
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
(mat oop
|
|
(begin
|
|
(import (oop))
|
|
(define-syntax seq-list
|
|
(lambda (x)
|
|
(import (only scheme list))
|
|
(syntax-case x ()
|
|
[(_ e ...)
|
|
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
|
#'(let* ([t e] ...) (list t ...)))])))
|
|
(define true? (lambda (x) (eq? x #t)))
|
|
#t)
|
|
(begin
|
|
(define-class (<a> a1) (<root>)
|
|
(ivars [x1 a1])
|
|
(methods
|
|
[m1 (q) (list self x1 q)]
|
|
[m2 () x1]))
|
|
#t)
|
|
(error? ; incorrect argument count
|
|
(make-<a>))
|
|
(error? ; incorrect argument count
|
|
(make-<a> 1 2))
|
|
(begin
|
|
(define i1 (make-<a> 3))
|
|
#t)
|
|
(equal? (cdr (m1 i1 4)) '(3 4))
|
|
(eq? (car (m1 i1 4)) i1)
|
|
(error? ; incorrect argument count
|
|
(m1 i1))
|
|
(error? ; incorrect argument count
|
|
(m1 i1 4 5))
|
|
(error? ; m1 not applicable to 17
|
|
(m1 17 4))
|
|
(error? ; not bound
|
|
(<a>-x1 i1))
|
|
(error? ; not bound
|
|
(<a>-x1-set! i1 17))
|
|
|
|
; no longer an error to duplicate x1
|
|
(begin
|
|
(define x1 'outer-x1)
|
|
(define x3 'outer-x3)
|
|
(define-class (<b> b1 b2) (<a> (+ b1 b2))
|
|
(ivars [x1 b1] [x2 b2])
|
|
(methods
|
|
[m1 (q) (vector self x1 q)]
|
|
[m3 (s t) (list s t x1 x2)]
|
|
[m4 () x3]))
|
|
(define i2 (make-<b> 10 4))
|
|
#t
|
|
)
|
|
(equal? (m2 i2) 14)
|
|
(equal? (m3 i2 'kurds 'weigh) '(kurds weigh 10 4))
|
|
(eq? (m4 i2) 'outer-x3)
|
|
|
|
(begin
|
|
(define-class (<b> b1 b2) (<a> (+ b1 b2))
|
|
(ivars [x2 b1] [x3 b2])
|
|
(methods
|
|
[m1 (q) (vector self x2 q)]
|
|
[m4 () x1]
|
|
[m3 (s t) (list s t x1 x2 x3)]))
|
|
(define i2 (make-<b> 4 5))
|
|
#t)
|
|
(eq? (m4 i2) 'outer-x1)
|
|
(eq? (vector-ref (m1 i2 6) 0) i2)
|
|
(equal? (vector-ref (m1 i2 6) 1) 4)
|
|
(equal? (vector-ref (m1 i2 6) 2) 6)
|
|
|
|
(begin
|
|
(define-class (<c> x) (<root>)
|
|
(ivars [x x])
|
|
(methods [c1 (a) (make-<c> a)]))
|
|
#t)
|
|
((lambda (x) (<c>? x)) (c1 (make-<c> 4) 5))
|
|
|
|
(eq?
|
|
(let ()
|
|
(define-class (<c> x) (<root>)
|
|
(ivars [x x])
|
|
(methods
|
|
[c1 (a) (make-<c> a)]
|
|
[c2 () x]))
|
|
(c2 (c1 (make-<c> 44) 87)))
|
|
87)
|
|
|
|
(begin
|
|
(define-class (foo x) (<root>)
|
|
(ivars [x x])
|
|
(methods
|
|
[hit () x]
|
|
[hit (y) (set! x (+ x y))]))
|
|
#t)
|
|
|
|
(equal?
|
|
(let ([a (make-foo 1)])
|
|
(let ((b (hit a)))
|
|
(hit a 17)
|
|
(list b (hit a))))
|
|
'(1 18))
|
|
|
|
(error? ; invalid arity for hit
|
|
(define-class (bar) (foo 1) (methods [hit (y z) (list y z)])))
|
|
|
|
; test variable arity methods
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (foo) (<root>) (methods [test (a . b) (list 'test a b)]))
|
|
(test (make-foo) 1 2 3 4 5))
|
|
'(test 1 (2 3 4 5)))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (foo) (<root>) (methods [test (a . b) (list 'test a b)]))
|
|
(define-class (bar) (foo) (methods [test (x . y) (list 'bar x y (super 'p 'd 'q 'r 's 't 'u))]))
|
|
(test (make-bar) 1 2 3 4 5 6 7))
|
|
'(bar 1 (2 3 4 5 6 7) (test p (d q r s t u))))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (foo x) (<root>)
|
|
(ivars [x x])
|
|
(methods
|
|
[ping () x]
|
|
[ping (v) (set! x v)]))
|
|
(define-class (bar x) (foo x)
|
|
(methods
|
|
[ping () super] ; return super method
|
|
[ping (v) (super (+ (super) v))]))
|
|
(let ([x (make-foo 1)] [y (make-bar 10)])
|
|
(let ([before-x (ping x)] [before-y ((ping y))])
|
|
(ping x 100)
|
|
(ping y 100)
|
|
(let ([after-x (ping x)] [after-y ((ping y))])
|
|
((ping y) 76)
|
|
(list before-x before-y after-x after-y ((ping y)))))))
|
|
'(1 10 100 110 76))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (foo) (<root>) (methods [chow x (cons 'foo x)]))
|
|
(define-class (bar) (foo) (methods [chow x (apply super 'bar x)]))
|
|
(list (chow (make-foo) 1 2 3)
|
|
(chow (make-bar) 4 5 6)))
|
|
'((foo 1 2 3) (foo bar 4 5 6)))
|
|
|
|
; Verify that first-class super knows all arities of corresponding method.
|
|
(equal?
|
|
(let ()
|
|
(define-class (foo) (<root>)
|
|
(methods
|
|
[chow (mein) (list 'foo 'chow-1 mein)]
|
|
[chow (a b) (list 'foo 'chow-2 a b)]))
|
|
(define-class (bar) (foo) (methods [chow (a b) super]))
|
|
(let ([sup (chow (make-bar) 'ignore1 'ignore2)])
|
|
(list (sup 'mane) (sup "ay" "bee"))))
|
|
'((foo chow-1 mane) (foo chow-2 "ay" "bee")))
|
|
|
|
; Verify that we don't override method unless its generic is visible,
|
|
; i.e., we get a new method of the same name
|
|
(equal?
|
|
(let ()
|
|
(module (foo (alpha bar))
|
|
(define-class (foo) (<root>) (methods [bar () 'foobar]))
|
|
(define-syntax alpha (identifier-syntax bar)))
|
|
(define-class (baz) (foo) (methods [bar () 'bazbar]))
|
|
(let ([x (make-baz)]) (list (alpha x) (bar x))))
|
|
'(foobar bazbar))
|
|
|
|
; Verify that we can't send super unless method's generic is visible.
|
|
(error? ; no inherited bar method (super)
|
|
(let ()
|
|
(module (foo (alpha bar))
|
|
(define-class (foo) (<root>) (methods [bar () 'foobar]))
|
|
(define-syntax alpha (identifier-syntax bar)))
|
|
(define-class (baz) (foo) (methods [bar () (super)]))
|
|
(make-baz)))
|
|
|
|
; Verify that we can't define a generic for a method with the same name
|
|
; as an interface method, i.e., supply an implementation of an
|
|
; interface-inherited method with the wrong arity
|
|
(begin
|
|
(define-interface bonk [whack (a mole)])
|
|
#t)
|
|
(error? ; invalid arity for whack
|
|
(define-class (pewter) (<root>) (implements bonk)
|
|
(methods
|
|
[whack (e) "method w/ same name as interface method, but diff arity"]
|
|
[whack (o no) "method matches interface method"])))
|
|
|
|
; more elaborate verification that we can't define a generic for a method
|
|
; with the same name as an interface method, i.e., supply an implementation
|
|
; of an interface-inherited method with the wrong arity
|
|
(begin
|
|
(define-interface bark [ham ()] [spam (y)])
|
|
#t)
|
|
(error? ; invalid arity for whack (or spam)
|
|
(define-class (platinum) (<root>) (implements bark bonk)
|
|
(methods
|
|
[ham () "and cheese"]
|
|
[spam () "spam"]
|
|
[spam (y) "spam"]
|
|
[xspam (x) "xspam"]
|
|
[whack (e) "method w/ same name as interface method, but diff arity"]
|
|
[whack (o no) "method matches interface method"])))
|
|
(error? ; invalid arity for whack (or spam)
|
|
(define-class (platinum) (<root>) (implements bonk bark)
|
|
(methods
|
|
[ham () "and cheese"]
|
|
[spam () "spam"]
|
|
[spam (y) "spam"]
|
|
[xspam (x) "xspam"]
|
|
[whack (e) "method w/ same name as interface method, but diff arity"]
|
|
[whack (o no) "method matches interface method"])))
|
|
(error? ; invalid arity for spam (or whack)
|
|
(define-class (platinum) (<root>) (implements bark bonk)
|
|
(methods
|
|
[whack (e) "method w/ same name as interface method, but diff arity"]
|
|
[whack (o no) "method matches interface method"]
|
|
[ham () "and cheese"]
|
|
[spam () "spam"]
|
|
[spam (y) "spam"]
|
|
[xspam (x) "xspam"])))
|
|
(error? ; invalid arity for spam (or whack)
|
|
(define-class (platinum) (<root>) (implements bonk bark)
|
|
(methods
|
|
[whack (e) "method w/ same name as interface method, but diff arity"]
|
|
[whack (o no) "method matches interface method"]
|
|
[ham () "and cheese"]
|
|
[spam () "spam"]
|
|
[spam (y) "spam"]
|
|
[xspam (x) "xspam"])))
|
|
|
|
|
|
(begin
|
|
(define-interface i1 [fish (fry)])
|
|
(define-interface i2 [rats (around)])
|
|
#t)
|
|
|
|
(error? ; fish not applicable to 3
|
|
(fish 3 4))
|
|
(error? ; rats not applicable to 3
|
|
(rats 3 4))
|
|
(error? ; fish not applicable to #<frob>
|
|
(let ()
|
|
(define-record frob ())
|
|
(record-writer (type-descriptor frob)
|
|
(lambda (x p wr)
|
|
(display "#<frob>" p)))
|
|
(fish (make-frob) 4)))
|
|
|
|
(error? ; no implementation of interface method rats
|
|
(define-class (<d> x) (<root>) (implements i1 i2)
|
|
(ivars [x (* x x)])
|
|
(methods
|
|
[fish (fry) (list fry x)]
|
|
[run (around) (cons around x)]
|
|
[x! (v) (set! x (* v v))])))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (<d> x) (<root>) (implements i1 i2)
|
|
(ivars [x (* x x)])
|
|
(methods
|
|
[fish (fry) (list fry x)]
|
|
[rats (around) (cons around x)]
|
|
[x? () x]
|
|
[x! (v) (set! x (* v v))]))
|
|
(define d (make-<d> 3))
|
|
(x! d 7)
|
|
(list (x? d) (fish d "hi") (rats d "ih")))
|
|
'(49 ("hi" 49) ("ih" . 49)))
|
|
|
|
(begin
|
|
(define-class (<e>) (<root>)
|
|
(methods
|
|
[m1 () (define-class (<f>) (<e>) (methods [m2 () 14])) (* (m2 (make-<f>)) 2)]))
|
|
#t)
|
|
(eqv? (m1 (make-<e>)) 28)
|
|
|
|
(equal?
|
|
(let ()
|
|
(define (m2 x) "undefined")
|
|
(module (c1 make-c1 m1 c1-friends)
|
|
(module all (c1 make-c1 m1 m2)
|
|
(define-class (c1) (<root>)
|
|
(methods
|
|
[m1 () "public"]
|
|
[m2 () "protected"])))
|
|
(module c1-friends (m2) (import all))
|
|
(import all))
|
|
(module (make-c2 m3)
|
|
(import c1-friends)
|
|
(define-class (c2) (c1)
|
|
(methods [m3 () (m2 self)])))
|
|
(module (make-c3 m4)
|
|
(import c1-friends)
|
|
(define-class (c3) (<root>)
|
|
(methods [m4 (x) (m2 x)])))
|
|
(let ([x (make-c2)] [y (make-c3)])
|
|
(list (m1 x) (m2 x) (m3 x) (m4 y x))))
|
|
'("public" "undefined" "protected" "protected"))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define (m2 x) "undefined")
|
|
(module (c1 make-c1 m1 c2 make-c2 m3 make-c3 m4)
|
|
(define-class (c1) (<root>)
|
|
(methods
|
|
[m1 () "public"]
|
|
[m2 () "protected"]))
|
|
(define-class (c2) (c1)
|
|
(methods [m3 () (m2 self)]))
|
|
(define-class (c3) (<root>)
|
|
(methods [m4 (x) (m2 x)])))
|
|
(let ([x (make-c2)] [y (make-c3)])
|
|
(list (m1 x) (m2 x) (m3 x) (m4 y x))))
|
|
'("public" "undefined" "protected" "protected"))
|
|
|
|
(true?
|
|
(let ([f (lambda ()
|
|
(define-class (frap) (<root>))
|
|
(cons make-frap frap?))])
|
|
((cdr (f)) ((car (f))))))
|
|
|
|
(true?
|
|
(let ([f (lambda ()
|
|
(define-class (frap) (<root>) (methods [m () 5]))
|
|
(cons make-frap frap?))])
|
|
(not ((cdr (f)) ((car (f)))))))
|
|
|
|
(true?
|
|
(let ([f (lambda ()
|
|
(define-class (frap) (<root>))
|
|
(cons make-frap frap?))]
|
|
[g (lambda ()
|
|
(define-class (frap) (<root>))
|
|
(cons make-frap frap?))])
|
|
(and (not ((cdr (f)) ((car (g)))))
|
|
(not ((cdr (g)) ((car (f))))))))
|
|
|
|
(true?
|
|
(let ([f (lambda ()
|
|
(define-class (#{frap |.O7*%gC?Sxs~2\\%|}) (<root>))
|
|
(cons make-frap frap?))]
|
|
[g (lambda ()
|
|
(define-class (#{frap |.O7*%gC?Sxs~2\\%|}) (<root>))
|
|
(cons make-frap frap?))])
|
|
(and ((cdr (f)) ((car (g))))
|
|
((cdr (g)) ((car (f)))))))
|
|
|
|
(true?
|
|
(let ([f (lambda ()
|
|
(define-class (#{frap |.TfvA+Ml1*u&?\\%|}) (<root>) (ivars [x 0]))
|
|
(cons make-frap frap?))]
|
|
[g (lambda ()
|
|
(define-class (#{frap |.TfvA+Ml1*u&?\\%|}) (<root>) (ivars [x 0]))
|
|
(cons make-frap frap?))])
|
|
(and ((cdr (f)) ((car (g))))
|
|
((cdr (g)) ((car (f)))))))
|
|
|
|
(error? ; incompatible record type
|
|
(let ([f (lambda ()
|
|
(define-class (#{frap |.Uo3>P+Wu9o=u\\%|}) (<root>) (ivars [x 0]))
|
|
(cons make-frap frap?))]
|
|
[g (lambda ()
|
|
(define-class (#{frap |.Uo3>P+Wu9o=u\\%|}) (<root>) (ivars [y 0]))
|
|
(cons make-frap frap?))])
|
|
(and ((cdr (f)) ((car (g))))
|
|
((cdr (g)) ((car (f)))))))
|
|
|
|
(error? ; cannot specify gensym class-name with methods or interfaces
|
|
(let ([f (lambda ()
|
|
(define-class (frap) (<root>) (methods [m1 () 5]))
|
|
(cons make-frap frap?))]
|
|
[g (lambda ()
|
|
(define-class (#{frap |.R@iB9FE~OXVz\\%|}) (<root>) (methods [m1 () 5]))
|
|
(cons make-frap frap?))])
|
|
(and ((cdr (f)) ((car (g))))
|
|
((cdr (g)) ((car (f)))))))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (<frozwell> x) (<root>)
|
|
(constructor frozwell-make)
|
|
(predicate is-frozwell?))
|
|
(let ([frzwl (frozwell-make 3)])
|
|
(list (is-frozwell? frzwl)
|
|
(is-frozwell? 17))))
|
|
'(#t #f))
|
|
|
|
(begin
|
|
(define-class (<frozwell> x) (<root>)
|
|
(constructor frozwell-make)
|
|
(predicate is-frozwell?))
|
|
#t)
|
|
(equal?
|
|
(let ([frzwl (frozwell-make 3)])
|
|
(list (is-frozwell? frzwl)
|
|
(is-frozwell? 17)))
|
|
'(#t #f))
|
|
|
|
(begin
|
|
(library (L1)
|
|
(export <frozwell> frozwell-make is-frozwell?)
|
|
(import (chezscheme) (oop))
|
|
(define-class (<frozwell> x) (<root>)
|
|
(constructor frozwell-make)
|
|
(predicate is-frozwell?)))
|
|
#t)
|
|
|
|
(equal?
|
|
(let ()
|
|
(import (L1))
|
|
(let ([frzwl (frozwell-make 3)])
|
|
(list (is-frozwell? frzwl)
|
|
(is-frozwell? 17))))
|
|
'(#t #f))
|
|
|
|
(error? ; invalid syntax <frozwell>
|
|
(let ()
|
|
(import (L1))
|
|
<frozwell>))
|
|
|
|
(error? ; extra ivars clause
|
|
(define-class (foo) (<root>)
|
|
(ivars [x 0])
|
|
(ivars [y 1])
|
|
(methods [show () (values x y)])))
|
|
|
|
(error? ; extra methods clause
|
|
(define-class (foo) (<root>)
|
|
(ivars [x 0] [y 1])
|
|
(methods [show () (values x y)])
|
|
(methods [get-x () x])))
|
|
|
|
(begin
|
|
(define-interface istud [cram (z)])
|
|
(define-class (fritz q) (<root>)
|
|
(methods [fritz-x+ (y) (+ x y)] [cram (n) (set! x (+ x n))])
|
|
(predicate ?fritzy)
|
|
(ivars [x (* q q)])
|
|
(constructor fritzit)
|
|
(implements istud))
|
|
#t)
|
|
(equal?
|
|
(let ([w (fritzit 10)])
|
|
(cram w 50)
|
|
(list (?fritzy w)
|
|
(?fritzy 'fritzy)
|
|
(fritz-x+ w 7)))
|
|
'(#t #f 157))
|
|
|
|
|
|
(error? ; invalid assignment of immutable ivar x
|
|
(define-class (blast x) (<root>) (ivars [immutable x x] [mutable y x])
|
|
(init (set! x (* x x)))))
|
|
|
|
(error? ; invalid assignment of immutable ivar x
|
|
(define-class (blast x) (<root>) (ivars [immutable x x] [mutable y x])
|
|
(methods
|
|
[m (v) (set! x v)])))
|
|
|
|
(error? ; blast-x-set! not bound
|
|
(let ()
|
|
(define-class (blast x) (<root>) (ivars [public immutable x x] [public mutable y x]))
|
|
(define b (make-blast 17))
|
|
(blast-x-set! b (* (blast-x b) (blast-x b)))
|
|
(blast-x b)))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (blast x) (<root>) (ivars [public immutable x x] [public mutable y x])
|
|
(init (set! y (* y y))))
|
|
(define b (make-blast 9))
|
|
(list (blast-x b) (blast-y b)))
|
|
'(9 81))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (blast x) (<root>)
|
|
(ivars [public immutable x x] [public mutable y x])
|
|
(methods
|
|
[m (v) (set! y v)]))
|
|
(define b (make-blast 9))
|
|
(m b 35)
|
|
(list (blast-x b) (blast-y b)))
|
|
'(9 35))
|
|
|
|
(equal?
|
|
(let ()
|
|
(define-class (blast x) (<root>)
|
|
(ivars [public immutable x x] [public mutable y x]))
|
|
(define b (make-blast 17))
|
|
(blast-y-set! b (* (blast-x b) (blast-x b)))
|
|
(list (blast-x b) (blast-y b)))
|
|
'(17 289))
|
|
|
|
(begin
|
|
(define-class (<q> a1) (<root>)
|
|
(ivars [public mupu1 (+ a1 1)]
|
|
[public mutable mupu2 (+ a1 2)]
|
|
[public immutable impu3 (+ a1 3)]
|
|
|
|
[private mupr4 (+ a1 4)]
|
|
[private mutable mupr5 (+ a1 5)]
|
|
[private immutable impr6 (+ a1 6)]
|
|
|
|
[private mupr7 (+ a1 7)]
|
|
[private mutable mupr8 (+ a1 8)]
|
|
[private immutable impr9 (+ a1 9)]))
|
|
(define i1 (make-<q> 10))
|
|
#t)
|
|
(equal?
|
|
(list (<q>-mupu1 i1) (<q>-mupu2 i1) (<q>-impu3 i1))
|
|
'(11 12 13))
|
|
(equal?
|
|
(begin
|
|
(<q>-mupu1-set! i1 'a)
|
|
(<q>-mupu2-set! i1 'b)
|
|
(list (<q>-mupu1 i1) (<q>-mupu2 i1) (<q>-impu3 i1)))
|
|
'(a b 13))
|
|
(error? ; not bound
|
|
<q>-mupr4)
|
|
(error? ; not bound
|
|
<q>-mupr5)
|
|
(error? ; not bound
|
|
<q>-impr6)
|
|
(error? ; not bound
|
|
<q>-mupr7)
|
|
(error? ; not bound
|
|
<q>-mupr8)
|
|
(error? ; not bound
|
|
<q>-impr9)
|
|
(error? ; not bound
|
|
<q>-impu3-set!)
|
|
(error? ; not bound
|
|
<q>-mupr4-set!)
|
|
(error? ; not bound
|
|
<q>-mupr5-set!)
|
|
(error? ; not bound
|
|
<q>-impr6-set!)
|
|
(error? ; not bound
|
|
<q>-mupr7-set!)
|
|
(error? ; not bound
|
|
<q>-mupr8-set!)
|
|
(error? ; not bound
|
|
<q>-impr9-set!)
|
|
|
|
(begin
|
|
(define-class (<r> a1) (<q> (+ a1 10))
|
|
(ivars [public mupu1 (+ a1 1)]
|
|
[mutable public mupu2 (+ a1 2)]
|
|
[immutable public impu3 (+ a1 3)]))
|
|
(define i2 (make-<r> 10))
|
|
#t)
|
|
(equal?
|
|
(list (<q>-mupu1 i2) (<q>-mupu2 i2) (<q>-impu3 i2)
|
|
(<r>-mupu1 i2) (<r>-mupu2 i2) (<r>-impu3 i2))
|
|
'(21 22 23 11 12 13))
|
|
(equal?
|
|
(begin
|
|
(<q>-mupu1-set! i2 "hi")
|
|
(<q>-mupu2-set! i2 "there")
|
|
(<r>-mupu1-set! i2 "ye")
|
|
(<r>-mupu2-set! i2 "matey")
|
|
(list (<q>-mupu1 i2) (<q>-mupu2 i2) (<q>-impu3 i2)
|
|
(<r>-mupu1 i2) (<r>-mupu2 i2) (<r>-impu3 i2)))
|
|
'("hi" "there" 23 "ye" "matey" 13))
|
|
(error? ; not bound
|
|
<r>-impu3-set!)
|
|
(error? ; not applicable
|
|
(<r>-mupu1 i1))
|
|
(error? ; not applicable
|
|
(<r>-mupu1-set! i1 55))
|
|
|
|
(begin
|
|
(define-class (<s> a1) (<r> (+ a1 10))
|
|
(ivars [public mupu1 (+ a1 1)]
|
|
[public mutable mupu2 (+ a1 2)]
|
|
[public immutable impu3 (+ a1 3)])
|
|
(prefix "s$"))
|
|
(define i3 (make-<s> 10))
|
|
#t)
|
|
(equal?
|
|
(list (<q>-mupu1 i3) (<q>-mupu2 i3) (<q>-impu3 i3)
|
|
(<r>-mupu1 i3) (<r>-mupu2 i3) (<r>-impu3 i3)
|
|
(s$mupu1 i3) (s$mupu2 i3) (s$impu3 i3))
|
|
'(31 32 33 21 22 23 11 12 13))
|
|
(equal?
|
|
(begin
|
|
(<q>-mupu1-set! i3 'hi)
|
|
(<q>-mupu2-set! i3 'there)
|
|
(<r>-mupu1-set! i3 'ye)
|
|
(<r>-mupu2-set! i3 'matey)
|
|
(s$mupu1-set! i3 'scaliwag)
|
|
(s$mupu2-set! i3 'pirate)
|
|
(list (<q>-mupu1 i3) (<q>-mupu2 i3) (<q>-impu3 i3)
|
|
(<r>-mupu1 i3) (<r>-mupu2 i3) (<r>-impu3 i3)
|
|
(s$mupu1 i3) (s$mupu2 i3) (s$impu3 i3)))
|
|
'(hi there 33 ye matey 23 scaliwag pirate 13))
|
|
(error? ; not bound
|
|
<s>-impu1)
|
|
(error? ; not bound
|
|
s$impu3-set!)
|
|
(error? ; not applicable
|
|
(s$mupu1 i1))
|
|
(error? ; not applicable
|
|
(s$mupu1-set! i1 55))
|
|
(error? ; not applicable
|
|
(s$mupu1 i2))
|
|
(error? ; not applicable
|
|
(s$mupu1-set! i2 55))
|
|
|
|
;;; tests from Michael Lenaghan of frogware, Inc.
|
|
|
|
(begin
|
|
;; simple init expression
|
|
(define-class (<test-1> x y) (<root>)
|
|
(ivars [x x] [y y] [z (* x y)])
|
|
(methods [method-1 () z]))
|
|
|
|
;; simple init expressions that depend
|
|
;; on previously computed values
|
|
(define-class (<test-2> x y) (<root>)
|
|
(ivars [x x] [y y] [z1 (* x y)] [z2 (* 2 z1)])
|
|
(methods [method-2 () z2]))
|
|
|
|
;; simple init proc
|
|
(define-class (<test-3> x y) (<root>)
|
|
(ivars [x x] [y y] [z 0])
|
|
(init
|
|
(set! z (* x y)))
|
|
(methods [method-3 () z]))
|
|
|
|
;; class and base class initialization can have
|
|
;; different arity
|
|
(define-class (<test-4> x) (<test-1> x x))
|
|
|
|
;; class and base class initialization can have
|
|
;; different arity and base class can use expressions
|
|
(define-class (<test-5> x) (<test-1> x (* 2 x)))
|
|
#t)
|
|
|
|
(eqv?
|
|
(let ([test (make-<test-1> 5 10)])
|
|
(method-1 test))
|
|
50)
|
|
|
|
(eqv?
|
|
(let ([test (make-<test-2> 5 10)])
|
|
(method-2 test))
|
|
100)
|
|
|
|
(eqv?
|
|
(let ([test (make-<test-3> 5 10)])
|
|
(method-3 test))
|
|
50)
|
|
|
|
(eqv?
|
|
(let ([test (make-<test-4> 5)])
|
|
(method-1 test))
|
|
25)
|
|
|
|
(eqv?
|
|
(let ([test (make-<test-5> 5)])
|
|
(method-1 test))
|
|
50)
|
|
|
|
(begin
|
|
;; base class
|
|
(define-class (<test-1> init-1) (<root>)
|
|
(ivars [fld-1 init-1])
|
|
(methods
|
|
[whoami () self]
|
|
[method-1 () fld-1]
|
|
[method-2 (x) (set! fld-1 x)]))
|
|
|
|
;; sub-class
|
|
(define-class (<test-2> init-1 init-2) (<test-1> init-1)
|
|
(ivars [fld-2 init-2])
|
|
(methods
|
|
[method-3 () fld-2]
|
|
[method-4 (x) (set! fld-2 x)]))
|
|
|
|
;; Note: The class <test-3> can't use the method names
|
|
;; "method-3" and "method-4" because they're used by
|
|
;; <test-2>. Chez OOP produces a "generic function"
|
|
;; for each method, and it looks like those functions
|
|
;; all have to belong to one line of the class inheritance
|
|
;; tree.
|
|
|
|
;; sub-class w/ overload
|
|
(define-class (<test-3> init-1 init-2) (<test-1> init-1)
|
|
(ivars [fld-2 init-2])
|
|
(methods
|
|
[method-1 () (method-3a self)]
|
|
[method-2 (x) (method-4a self x)]
|
|
[method-3a () fld-2]
|
|
[method-4a (x) (set! fld-2 x)]))
|
|
|
|
;; sub-class w/ overload & fields
|
|
;; if this is uncommented, uncomment <test-4> test below
|
|
#;
|
|
(define-class (<test-4> init-1) (<test-1> init-1)
|
|
(methods
|
|
[method-3b ()
|
|
;; this provides access to super-class fields
|
|
(open-instance <test-1> "" self)
|
|
fld-1]
|
|
[method-4b (x)
|
|
;; this provides access to super-class fields
|
|
(open-instance <test-1> "" self)
|
|
(set! fld-1 x)]))
|
|
|
|
;; sub-class w/ overload & super
|
|
(define-class (<test-5> init-1) (<test-1> init-1)
|
|
(methods
|
|
[method-1 () (string->symbol
|
|
(string-append (symbol->string (super)) "!!!"))]
|
|
[method-2 (x) (super
|
|
(string->symbol
|
|
(string-append (symbol->string x) "!!!")))]))
|
|
|
|
;; sub-class w/ variable arity
|
|
(define-class (<test-6> init-1) (<test-1> init-1)
|
|
(methods
|
|
[method-5 () (method-1 self)]
|
|
[method-5 (x) (method-2 self x)]))
|
|
#t)
|
|
|
|
(equal?
|
|
(let ((test (make-<test-1> 'hello)))
|
|
(seq-list
|
|
(eq? test (whoami test))
|
|
(method-1 test)
|
|
(method-2 test 'goodbye)
|
|
(method-1 test)))
|
|
`(#t hello ,(void) goodbye))
|
|
|
|
(equal?
|
|
(let ((test (make-<test-2> 'hello 'hello-again)))
|
|
(seq-list
|
|
(method-1 test)
|
|
(method-2 test 'goodbye)
|
|
(method-1 test)
|
|
(method-3 test)
|
|
(method-4 test 'goodbye-again)
|
|
(method-3 test)))
|
|
`(hello ,(void) goodbye hello-again ,(void) goodbye-again))
|
|
|
|
(equal?
|
|
(let ((test (make-<test-3> 'hello 'hello-again)))
|
|
(seq-list
|
|
(method-1 test)
|
|
(method-2 test 'goodbye-again)
|
|
(method-1 test)
|
|
(method-3a test)
|
|
(method-4a test 'hello-again)
|
|
(method-3a test)))
|
|
`(hello-again ,(void) goodbye-again goodbye-again ,(void) hello-again))
|
|
|
|
#;
|
|
(equal?
|
|
(let ((test (make-<test-4> 'hello)))
|
|
(seq-list
|
|
(method-1 test)
|
|
(method-2 test 'goodbye)
|
|
(method-1 test)
|
|
|
|
(method-3b test)
|
|
(method-4b test 'hello)
|
|
(method-3b test)))
|
|
`(hello ,(void) goodbye goodbye ,(void) hello))
|
|
|
|
(equal?
|
|
(let ((test (make-<test-5> 'hello)))
|
|
(seq-list
|
|
(method-1 test)
|
|
(method-2 test 'goodbye)
|
|
(method-1 test)))
|
|
`(hello!!! ,(void) goodbye!!!!!!))
|
|
|
|
(equal?
|
|
(let ((test (make-<test-6> 'hello)))
|
|
(seq-list
|
|
(method-5 test)
|
|
(method-5 test 'goodbye)
|
|
(method-5 test)))
|
|
`(hello ,(void) goodbye))
|
|
|
|
(begin
|
|
;; use class exported from module
|
|
(module test-1 (<test-1> make-<test-1> method-1)
|
|
(define-class (<test-1> x) (<root>)
|
|
(ivars [x x])
|
|
(methods [method-1 () x])))
|
|
#t)
|
|
|
|
(eqv? (let () (import test-1) (method-1 (make-<test-1> 3))) 3)
|
|
(eqv?
|
|
(let ()
|
|
(import test-1)
|
|
(define-class (<frob> x) (<test-1> x))
|
|
(method-1 (make-<test-1> 3)))
|
|
3)
|
|
|
|
(begin
|
|
;; use sub-class exported from module
|
|
(module test-2 (<test-2> make-<test-2> method-1)
|
|
(import test-1)
|
|
(define-class (<test-2> x) (<test-1> x)))
|
|
#t)
|
|
|
|
(eqv? (let () (import test-2) (method-1 (make-<test-2> 3))) 3)
|
|
|
|
(begin
|
|
;; use sub-class w/ overload exported from module
|
|
(module test-3 (make-<test-3> method-1)
|
|
(import test-2)
|
|
(define-class (<test-3> x) (<test-2> x)
|
|
(ivars [x x])
|
|
(methods [method-1 () (* x x)])))
|
|
#t)
|
|
|
|
(eqv?
|
|
(let ()
|
|
(import test-1)
|
|
(let ([test (make-<test-1> 10)])
|
|
(method-1 test)))
|
|
10)
|
|
|
|
(eqv?
|
|
(let ()
|
|
(import test-2)
|
|
(let ([test (make-<test-2> 10)])
|
|
(method-1 test)))
|
|
10)
|
|
|
|
(eqv?
|
|
(let ()
|
|
(import test-3)
|
|
(let ([test (make-<test-3> 10)])
|
|
(method-1 test)))
|
|
100)
|
|
|
|
(begin
|
|
;; base interface
|
|
(define-interface <<interface-1>>
|
|
[imethod-1 ()]
|
|
[imethod-2 (x)])
|
|
|
|
;; sub-interface
|
|
(define-interface <<interface-2>> <<interface-1>>
|
|
[imethod-3 ()]
|
|
[imethod-4 (x)])
|
|
|
|
;; base interface
|
|
(define-interface <<interface-3>>
|
|
[imethod-5 ()]
|
|
[imethod-6 (x)])
|
|
|
|
;; base class w/ base interface
|
|
(define-class (<itest-1> init-1) (<root>)
|
|
(implements <<interface-1>>)
|
|
(ivars [fld-1 init-1])
|
|
(methods
|
|
[method-1 () 'method-1]
|
|
[imethod-1 () fld-1]
|
|
[imethod-2 (x) (set! fld-1 x)]))
|
|
|
|
;; sub-class w/ sub-interface
|
|
(define-class (<itest-2> init-1 init-2) (<itest-1> init-1)
|
|
(implements <<interface-2>>)
|
|
(ivars [fld-2 init-2])
|
|
(methods
|
|
[method-2 () 'method-2]
|
|
[imethod-3 () fld-2]
|
|
[imethod-4 (x) (set! fld-2 x)]))
|
|
|
|
;; sub-class w/ new method
|
|
(define-class (<itest-3> init-1 init-2) (<itest-2> init-1 init-2)
|
|
(ivars [fld-3 (+ init-1 init-2)])
|
|
(methods
|
|
[method-3 () fld-3]))
|
|
|
|
;; base class w/ interfaces & new method
|
|
(define-class (<itest-4> init-1) (<root>)
|
|
(implements <<interface-1>> <<interface-3>>)
|
|
(ivars [fld-1 init-1])
|
|
(methods
|
|
[imethod-1 () (* 2 fld-1)]
|
|
[imethod-2 (x) (set! fld-1 x)]
|
|
[imethod-5 () (* 4 fld-1)]
|
|
[imethod-6 (x) (set! fld-1 x)]
|
|
[method-4 () fld-1]
|
|
[method-4! (x) (set! fld-1 x)]))
|
|
#t)
|
|
|
|
(equal?
|
|
(let ((itest (make-<itest-1> 'hello)))
|
|
(seq-list
|
|
(method-1 itest)
|
|
(imethod-1 itest)
|
|
(imethod-2 itest 'goodbye)
|
|
(imethod-1 itest)))
|
|
`(method-1 hello ,(void) goodbye))
|
|
|
|
(eqv?
|
|
(let ((itest (make-<itest-2> 'hello 'hello-again)))
|
|
(method-2 itest))
|
|
'method-2)
|
|
|
|
(equal?
|
|
(let ((itest (make-<itest-2> 'hello 'hello-again)))
|
|
(seq-list
|
|
(imethod-1 itest)
|
|
(imethod-2 itest 'goodbye)
|
|
(imethod-1 itest)
|
|
|
|
(imethod-3 itest)
|
|
(imethod-4 itest 'goodbye-again)
|
|
(imethod-3 itest)))
|
|
`(hello ,(void) goodbye hello-again ,(void) goodbye-again))
|
|
|
|
(eqv?
|
|
(let ((itest (make-<itest-3> 5 10)))
|
|
(method-3 itest))
|
|
15)
|
|
|
|
(equal?
|
|
(let ((itest (make-<itest-4> 10)))
|
|
(seq-list
|
|
(imethod-1 itest)
|
|
(imethod-5 itest)
|
|
(method-4 itest)
|
|
(method-4! itest 20)
|
|
(imethod-1 itest)
|
|
(imethod-5 itest)
|
|
(method-4 itest)))
|
|
`(20 40 10 ,(void) 40 80 20))
|
|
|
|
(begin
|
|
;; export interface from module
|
|
(module test-1 (<<interface-1>> imethod-1 imethod-2)
|
|
(define-interface <<interface-1>>
|
|
[imethod-1 ()]
|
|
[imethod-2 (v)]))
|
|
|
|
;; export sub-interface from module
|
|
(module test-2 (<<interface-2>> imethod-3 imethod-4)
|
|
(import test-1)
|
|
(define-interface <<interface-2>> <<interface-1>>
|
|
[imethod-3 ()]
|
|
[imethod-4 (v)]))
|
|
|
|
;; use class w/ interface exported from module
|
|
(module test-3 (<itest-3> make-<itest-3> imethod-1 imethod-2)
|
|
(import test-1)
|
|
(define-class (<itest-3> x) (<root>)
|
|
(implements <<interface-1>>)
|
|
(ivars [x x])
|
|
(methods
|
|
[imethod-1 () x]
|
|
[imethod-2 (v) (set! x v)])))
|
|
|
|
;; use sub-class w/ interface exported from module
|
|
(module test-4 (<itest-4> make-<itest-4> imethod-1 imethod-2 imethod-3 imethod-4)
|
|
(import test-2)
|
|
(import test-3)
|
|
(define-class (<itest-4> x) (<itest-3> x)
|
|
(implements <<interface-2>>)
|
|
(methods
|
|
[imethod-3 () (* 2 (imethod-1 self))]
|
|
[imethod-4 (v) (imethod-2 self (* 2 v))])))
|
|
|
|
;; use sub-class w/ overload of interface methods exported from module
|
|
(module test-5 (make-<itest-5> imethod-1 imethod-2 imethod-3 imethod-4)
|
|
(import test-4)
|
|
(define-class (<itest-5> x) (<itest-4> x)
|
|
(methods
|
|
[imethod-1 () (* 2 (super))]
|
|
[imethod-3 () (* 2 (super))])))
|
|
|
|
;; use sub-class w/ new methods exported from module
|
|
(module test-6 (make-<itest-6> method-1)
|
|
(import test-4)
|
|
(define-class (<itest-6> x) (<itest-4> x)
|
|
(ivars [x x])
|
|
(methods
|
|
[method-1 () (* x x)])))
|
|
#t)
|
|
|
|
(equal?
|
|
(let ()
|
|
(import test-3)
|
|
(let ([test (make-<itest-3> 10)])
|
|
(seq-list
|
|
(imethod-1 test)
|
|
(imethod-2 test 20)
|
|
(imethod-1 test))))
|
|
`(10 ,(void) 20))
|
|
|
|
(equal?
|
|
(let ()
|
|
(import test-4)
|
|
(let ([test (make-<itest-4> 10)])
|
|
(seq-list
|
|
(imethod-1 test)
|
|
(imethod-2 test 20)
|
|
(imethod-1 test)
|
|
(imethod-3 test)
|
|
(imethod-4 test 20)
|
|
(imethod-3 test))))
|
|
`(10 ,(void) 20 40 ,(void) 80))
|
|
|
|
(equal?
|
|
(let ()
|
|
(import test-5)
|
|
(let ([test (make-<itest-5> 10)])
|
|
(seq-list
|
|
(imethod-1 test)
|
|
(imethod-2 test 20)
|
|
(imethod-1 test)
|
|
(imethod-3 test)
|
|
(imethod-4 test 20)
|
|
(imethod-3 test))))
|
|
`(20 ,(void) 40 160 ,(void) 320))
|
|
|
|
(eqv?
|
|
(let ()
|
|
(import test-6)
|
|
(let ([test (make-<itest-6> 10)])
|
|
(method-1 test)))
|
|
100)
|
|
|
|
;;; end of tests from Michael Lenaghan of frogware, Inc.
|
|
|
|
;;; letrec-classes tests from seminar
|
|
|
|
(begin
|
|
(define-syntax letrec-classes
|
|
(syntax-rules ()
|
|
[(_ ([class-name (class-formal ...) (base-name base-arg ...)
|
|
([ivar ivar-init] ...)
|
|
[method-name (method-formal ...) method-b1 method-b2 ...] ...]
|
|
...)
|
|
b1 b2 ...)
|
|
(let ()
|
|
(define-class (class-name class-formal ...) (base-name base-arg ...)
|
|
(ivars [ivar ivar-init] ...)
|
|
(methods [method-name (method-formal ...) method-b1 method-b2 ...] ...))
|
|
...
|
|
b1 b2 ...)]))
|
|
#t)
|
|
|
|
(error? ; wrong number of base-class arguments
|
|
(letrec-classes ([<a> (x) (<root>) ()])
|
|
(letrec-classes ([<b> () (<a>) ()])
|
|
(make-<b>))))
|
|
|
|
(error? ; no inherited foo method for (super)
|
|
(letrec-classes ([<a> () (<root>) () [foo () (super)]])
|
|
(foo (make-<a>))))
|
|
|
|
(eq?
|
|
(let ()
|
|
(letrec-classes ([<c> (x) (<root>)
|
|
([x x])
|
|
[c1 (a) (make-<c> a)]
|
|
[c2 () x]])
|
|
(c2 (c1 (make-<c> 44) 87))))
|
|
87)
|
|
|
|
(eq?
|
|
(letrec-classes ((A () (<root>) ()))
|
|
(letrec-classes
|
|
((<root> () (A) ()
|
|
(foo (<root>) 77)))
|
|
(foo (make-<root>) 88)))
|
|
77)
|
|
|
|
; Ronald Garcia
|
|
|
|
; Here are some INVALID test cases that I use to exercise what errors my
|
|
; compiler will catch. A few might not fail given the proper compiler
|
|
; extension (i.e. do classes and variables share the same namespace...)
|
|
|
|
(error? ; duplicate definition repeat, repeat?, and make-repeat
|
|
(letrec-classes ([Repeat () (<root>) ()]
|
|
[Repeat () (<root>) ()])
|
|
0))
|
|
|
|
(error? ; duplicate ivar i
|
|
(letrec-classes ([Vars () (<root>) ((i 1) (i 1))])
|
|
0))
|
|
|
|
(error? ; unrecognized base class aaaaa
|
|
(letrec-classes ([Empty () (aaaaa) ()])
|
|
(let ([mt (make-Empty)])
|
|
0)))
|
|
|
|
;;; Chez Scheme allows this:
|
|
(eqv?
|
|
(letrec-classes ([One () (<root>) ()]
|
|
[Two () (One) ()])
|
|
0)
|
|
0)
|
|
|
|
(error? ; unrecognized base class aaaaa
|
|
(letrec-classes ([One () (<root>) ()])
|
|
(letrec-classes ([Two () (aaaaa) ()])
|
|
0)))
|
|
|
|
(error? ; duplicate same-arity method definition
|
|
(letrec-classes ([Vars () (<root>) ()
|
|
(M1 () 0)
|
|
(M1 () 1)])
|
|
0))
|
|
|
|
(error? ; incorrect base argument count
|
|
(letrec-classes ([Class () (<root> unbound) ()])
|
|
0))
|
|
|
|
(error? ; unbound is not bound
|
|
(letrec-classes ([c1 (x) (<root>) ()])
|
|
(letrec-classes ([c2 () (c1 unbound) ()])
|
|
(make-c2))))
|
|
|
|
(error? ; unbound is not bound
|
|
(letrec-classes ([c () (<root>) ((i unbound))])
|
|
(make-c)))
|
|
|
|
(error? ; j is unbound
|
|
(letrec-classes ([c () (<root>) ((i j) (j 0))])
|
|
(make-c)
|
|
0))
|
|
|
|
(eqv?
|
|
(letrec-classes ([c () (<root>) ((i 1) (j (+ i 2))) (m () j)])
|
|
(m (make-c)))
|
|
3)
|
|
|
|
(error? ; unbound is not bound
|
|
(letrec-classes ([c (i j) (<root>) ()])
|
|
(make-c 1 unbound)))
|
|
|
|
(error? ; unbound is not bound
|
|
(letrec-classes ([c (i j) (<root>) ()])
|
|
(c? unbound)))
|
|
|
|
(error? ; unbound is not bound
|
|
(letrec-classes ([Class () (<root>) () (M1 (i) unbound)])
|
|
(M1 (make-Class) 6)))
|
|
|
|
(error? ; duplicate definition of M1
|
|
(letrec-classes ([One () (<root>) () (M1 () 0)]
|
|
[Two () (<root>) () (M1 () 0)])
|
|
0))
|
|
|
|
(eqv?
|
|
(letrec-classes ([Pop () (<root>) () (M1 () 0)])
|
|
(letrec-classes ([One () (Pop) () (M1 () 1)]
|
|
[Two () (<root>) () (M1 () 2)])
|
|
(M1 (make-Two))))
|
|
2)
|
|
|
|
(error? ; duplicate definition of M2
|
|
(letrec-classes ([Pop () (<root>) () (M1 () 0)])
|
|
(letrec-classes ([One () (Pop) () (M1 () 1) (M2 () 2)]
|
|
[Two () (Pop) () (M2 () 2)])
|
|
0)))
|
|
|
|
(equal?
|
|
(letrec-classes ([Pop () (<root>) () (M1 () 0)])
|
|
(letrec-classes ([One () (Pop) () (M1 () 1)]
|
|
[Two () (Pop) () (M2 () 2)])
|
|
(let ([M2* M2])
|
|
(letrec-classes ([Three () (One) () (M1 () 3) (M2 () 4)])
|
|
(list (M1 (make-Pop))
|
|
(M1 (make-One))
|
|
(M1 (make-Two))
|
|
(M2* (make-Two))
|
|
(M1 (make-Three))
|
|
(M2 (make-Three)))))))
|
|
'(0 1 0 2 3 4))
|
|
|
|
(error? ; variable ingnacious is unbound
|
|
(letrec-classes ([Pop () (<root>) ([ingnacious 1])])
|
|
(letrec-classes ([One () (<root>) () (M1 () ingnacious)])
|
|
(M1 (make-One)))))
|
|
|
|
(equal?
|
|
(letrec-classes ([Pop () (<root>) ([i 1]) [get () i]])
|
|
(letrec-classes ([One () (Pop) ([i 2]) [get () (list (super) i)]])
|
|
(get (make-One))))
|
|
'(1 2))
|
|
|
|
(error? ; invalid syntax class
|
|
(let ([Class #f])
|
|
(letrec-classes ([Class () (<root>) ()])
|
|
(let ([Class Class])
|
|
0))))
|
|
|
|
(eqv?
|
|
(letrec-classes ([Class () (<root>) ()])
|
|
(let ([Class #f]
|
|
[foo (make-Class)])
|
|
(Class? foo)))
|
|
#t)
|
|
|
|
; Here are some pretty trivial (i.e. relatively easy to follow by hand) test cases.
|
|
; They cover some pretty basic functionality (specifying classes without making them, etc.)
|
|
|
|
(eq?
|
|
;; simplest example...
|
|
(letrec-classes ([Empty () (<root>)
|
|
()])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; It's okay for ivars in separate classes to have the same name.
|
|
(letrec-classes ([One () (<root>) ((var 0))]
|
|
[Two () (<root>) ((var 0))])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; naive inheritance example
|
|
(letrec-classes ([One () (<root>) ()])
|
|
(letrec-classes ([Two () (One) ()])
|
|
0))
|
|
0)
|
|
|
|
(eq?
|
|
;; Actually make a class
|
|
(letrec-classes ([Empty () (<root>)
|
|
()])
|
|
(let ([mt (make-Empty)])
|
|
0))
|
|
0)
|
|
|
|
(eq?
|
|
;; simple example of using class formals in base-init
|
|
(letrec-classes ([One (i) (<root>) ()])
|
|
(letrec-classes ([Two (j) (One j) ()])
|
|
0))
|
|
0)
|
|
|
|
(eq?
|
|
;; simple example of using class formal in ivar-init.
|
|
(letrec-classes ([Class (i) (<root>)
|
|
((var i))])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; ivar-init's can see the previous ivar.
|
|
(letrec-classes ([Class () (<root>)
|
|
((var1 0)
|
|
(var2 var1))])
|
|
0)
|
|
0)
|
|
|
|
|
|
(eq?
|
|
;; parameters to methods are visible in methods
|
|
(letrec-classes ([Class () (<root>) ()
|
|
(M1 (i) i)])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; "self" is implicitly added to method environments.
|
|
(letrec-classes ([Class () (<root>) ()
|
|
(M1 () self)])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; inheritance hierarchy can share methods
|
|
(letrec-classes ([Pop () (<root>) ()
|
|
(M1 () 0)])
|
|
(letrec-classes ([One () (Pop) ()
|
|
(M1 () 1)]
|
|
[Two () (Pop) ()
|
|
(M1 () 2)])
|
|
0))
|
|
0)
|
|
|
|
(eq?
|
|
;; more windy inheritance hierarchy
|
|
(letrec-classes ([Pop () (<root>) () (M1 () 0)])
|
|
(letrec-classes ([One () (Pop) () (M1 () 1)]
|
|
[Two () (Pop) () (M2 () 2)])
|
|
(letrec-classes ([Three () (One) ()
|
|
(M1 () 1)
|
|
(M3 () 2)]
|
|
[Four () (Two) ()
|
|
(M2 () 1)
|
|
(M4 () 2)])
|
|
0)))
|
|
0)
|
|
|
|
(eq?
|
|
;; Skip a generation before overloading...
|
|
(letrec-classes ([Pop () (<root>) () (M1 () 0)])
|
|
(letrec-classes ([One () (Pop) ()])
|
|
(letrec-classes ([Three () (One) ()
|
|
(M1 () 1)
|
|
(M3 () 2)])
|
|
0)))
|
|
0)
|
|
|
|
(eq?
|
|
;; classes in the same block can see each other.
|
|
(letrec-classes ([One () (<root>) () (M1 () (make-Two))]
|
|
[Two () (<root>) ()])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; classes in the same block can call each other's methods.
|
|
(letrec-classes ([One () (<root>) () (M1 (obj) (M2 obj))]
|
|
[Two () (<root>) () (M2 () 3)])
|
|
0)
|
|
0)
|
|
|
|
(eq?
|
|
;; class methods in the same block can be seen in base inits
|
|
(letrec-classes ([Pop (i j) (<root>) ()])
|
|
(letrec-classes ([One () (<root>) () (M1 (obj) (M2 obj))]
|
|
[Two () (Pop (M1 (make-One)) 5) () (M2 () 3)])
|
|
0))
|
|
0)
|
|
|
|
(eq?
|
|
;; subclass methods can see superclass instance vars
|
|
(letrec-classes ([Pop () (<root>) ([i 1])])
|
|
(letrec-classes ([One () (Pop) () (M1 () i)])
|
|
0))
|
|
0)
|
|
|
|
|
|
(eq?
|
|
;; class names should become unique
|
|
(letrec-classes ([Class () (<root>) ()])
|
|
(letrec-classes ([Class () (<root>) ()])
|
|
0))
|
|
0)
|
|
|
|
(eq?
|
|
;; class names should not clash with variables either
|
|
(let ([Class #f])
|
|
(letrec-classes ([Class () (<root>) ()])
|
|
(letrec-classes ([Class () (<root>) ()])
|
|
0)))
|
|
0)
|
|
|
|
|
|
(eq?
|
|
;; Variables bound outside letrec-classes should be visible
|
|
(let ([bound-var #f])
|
|
(letrec-classes ([Super (i) (<root>) ()])
|
|
(letrec-classes ([Class () (Super bound-var) ([i bound-var])
|
|
(M1 () bound-var)])
|
|
0)))
|
|
0)
|
|
|
|
(eq?
|
|
;; Number has one instance variable that holds a number and one method
|
|
;; that returns the number.
|
|
(letrec-classes ([Number (num^) (<root>)
|
|
((num num^))
|
|
(Val () num)])
|
|
(let ([nb1 (make-Number 1)]
|
|
[nb2 (make-Number 2)])
|
|
(+ (Val nb1) (Val nb2))))
|
|
;; result: 3
|
|
3)
|
|
|
|
(eq?
|
|
;; test out method binding
|
|
(letrec-classes ([Pop () (<root>) () (MP1 () 0) (MP2 (i) 0)])
|
|
(letrec-classes ([One () (Pop) () (M1 () 1)])
|
|
(letrec-classes ([Two () (One) () (M2 (i j) 2) (MP1 () 2)])
|
|
(letrec-classes ([Three () (Two) () (MP2 (i) 3) (M3 () 3)])
|
|
0))))
|
|
0)
|
|
|
|
; Mark Meiss
|
|
|
|
(eq?
|
|
(let ([object (letrec-classes
|
|
([duo (n) (<root>)
|
|
([n n])
|
|
(plus () (+ n 2))
|
|
(times () (* n 2))
|
|
(expt () (* n n))
|
|
(export ()
|
|
(let ([vec (make-vector 4)])
|
|
(vector-set! vec 0 self)
|
|
(vector-set! vec 1 plus)
|
|
(vector-set! vec 2 times)
|
|
(vector-set! vec 3 expt)
|
|
vec))])
|
|
(export (make-duo 6)))])
|
|
(* ((vector-ref object 1) (vector-ref object 0))
|
|
(+ ((vector-ref object 2) (vector-ref object 0))
|
|
((vector-ref object 3) (vector-ref object 0)))))
|
|
|
|
; should evaluate to 384
|
|
384)
|
|
|
|
;------------------------------------------------------------------------
|
|
|
|
(eq?
|
|
(letrec ([class-maker (lambda (n)
|
|
(if (zero? n)
|
|
(letrec-classes
|
|
([zero () (<root>)
|
|
()
|
|
(get-n () 0)])
|
|
(cons (make-zero) get-n))
|
|
(letrec-classes
|
|
([succ () (<root>)
|
|
()
|
|
(get-n () (let ([prev (class-maker (sub1 n))])
|
|
(add1 ((cdr prev) (car prev)))))])
|
|
(cons (make-succ) get-n))))]
|
|
[fib (lambda (n)
|
|
(if (< ((cdr n) (car n)) 2)
|
|
((cdr n) (car n))
|
|
(+ (fib (class-maker (sub1 ((cdr n) (car n)))))
|
|
(fib (class-maker (sub1 (sub1 ((cdr n) (car n)))))))))])
|
|
(fib (class-maker 7)))
|
|
|
|
; should evaluate to 13
|
|
13)
|
|
|
|
;------------------------------------------------------------------------
|
|
|
|
(eq?
|
|
(letrec-classes ([<route> (a b c) (<root>)
|
|
([a (+ a a)]
|
|
[b (+ a b)]
|
|
[c (+ b c)])
|
|
(get-b () b)
|
|
(sum (a) (+ a (+ (get-b self) c)))])
|
|
(sum (make-<route> 1 2 3) 4))
|
|
|
|
; should evaluate to 15
|
|
15)
|
|
|
|
;------------------------------------------------------------------------
|
|
|
|
(equal?
|
|
(letrec-classes ([A (x y) (<root>)
|
|
([x x] [y y])
|
|
(get-x () x)
|
|
(get-y () y)
|
|
(test (object)
|
|
(if (A? object)
|
|
(+ (- (get-x self) (get-x object))
|
|
(- (get-y self) (get-y object)))
|
|
(* (get-x self) (get-y self))))])
|
|
(letrec-classes ([B () (A 2 3)
|
|
()
|
|
(become-if-not-A (object)
|
|
(if (A? object) self object))]
|
|
[C (x y) (A x y)
|
|
(#;
|
|
[x x]
|
|
#;
|
|
[y y])])
|
|
(let ([a-var (make-A 3 4)]
|
|
[b-var (make-B)]
|
|
[c-var (make-C 2 1)]
|
|
[vec (make-vector 4)])
|
|
(vector-set! vec 0 (test a-var b-var))
|
|
(vector-set! vec 1 (test a-var c-var))
|
|
(set! b-var (become-if-not-A b-var b-var))
|
|
(vector-set! vec 2 (test a-var b-var))
|
|
(set! b-var (become-if-not-A b-var c-var))
|
|
(vector-set! vec 3 (test a-var b-var))
|
|
vec)))
|
|
|
|
; should evaluate to #(2 4 2 2)
|
|
'#(2 4 2 2))
|
|
|
|
;------------------------------------------------------------------------
|
|
|
|
#;
|
|
(equal?
|
|
(letrec-classes ([fish (head tail) (<root>)
|
|
([head head] [tail tail])
|
|
(behead () (set! head tail))
|
|
(betail () (set! tail head))
|
|
(get-head () head)
|
|
(get-tail () tail)])
|
|
(letrec-classes ([guppy (head tail) (fish head tail)
|
|
()
|
|
(behead () (open-instance fish "" self) (set! head (cons tail tail)))
|
|
(betail () (open-instance fish "" self) (set! tail (cons head head)))])
|
|
(letrec-classes ([minnow (head tail) (guppy head tail)
|
|
()
|
|
(behead () (begin (super) (set! betail behead)))
|
|
(betail () (begin (super) (set! behead betail)))])
|
|
(let ([fishy-1 (make-fish 4 8)]
|
|
[fishy-2 (make-guppy 5 9)])
|
|
(let ([fishy-red (make-minnow fishy-1 fishy-2)])
|
|
(behead fishy-1)
|
|
(betail fishy-2)
|
|
(behead fishy-red)
|
|
(betail fishy-red)
|
|
(get-tail (cdr (get-head fishy-red))))))))
|
|
|
|
; should evaluate to (5 . 5)
|
|
'(5 . 5))
|
|
|
|
; Brooke Chenoweth
|
|
|
|
(equal?
|
|
;; objects shouldn't be identifiable as vectors or procedures
|
|
(letrec-classes ([foo () (<root>) ()])
|
|
(let ([obj (make-foo)])
|
|
(cons (foo? obj)
|
|
(cons (procedure? obj)
|
|
(cons (vector? obj) '())))))
|
|
; should return '(#t #f #f)
|
|
'(#t #f #f))
|
|
|
|
(eq?
|
|
;; We should be able to package up methods for outside use
|
|
(let ([foo-package
|
|
(letrec-classes ([foo (x) (<root>)
|
|
((x x))
|
|
(get-x () x)])
|
|
(let ([v (make-vector 3)])
|
|
(vector-set! v 0
|
|
(lambda (x) (make-foo x))) ; foo-maker
|
|
(vector-set! v 1
|
|
(lambda (x) (foo? x))) ; foo?
|
|
(vector-set! v 2
|
|
(lambda (inst) (get-x inst))) ; get-x
|
|
v))])
|
|
(let ([make-foo (vector-ref foo-package 0)]
|
|
[foo? (vector-ref foo-package 1)]
|
|
[foo-get-x (vector-ref foo-package 2)])
|
|
(let ([r (letrec-classes ([R () (<root>) ()]) (make-R))]
|
|
[f (make-foo 4)])
|
|
(if (foo? r)
|
|
(foo-get-x r)
|
|
(if (foo? f)
|
|
(foo-get-x f)
|
|
-100)))))
|
|
; should return 4
|
|
4)
|
|
|
|
(equal?
|
|
(letrec-classes ([A (x y) (<root>)
|
|
((s (+ x y))
|
|
(d (- x y)))
|
|
(m1 () (- s d))
|
|
(m2 () (+ s d))]
|
|
[R () (<root>) ()])
|
|
(letrec-classes ([B (x y z) (A y z)
|
|
((p (* x y)))
|
|
(m1 () (+ (super) p))
|
|
(m3 () (- (m2 self) p))])
|
|
(let ([robj (make-R)]
|
|
[aobj (make-A 1 2)] ; s = 3, d = -1
|
|
[bobj (make-B 3 4 5)] ; s = 9, d = -1, p = 12
|
|
[gather-results
|
|
(lambda (obj)
|
|
(and (A? obj)
|
|
(cons (m1 obj)
|
|
(cons (m2 obj)
|
|
(cons (if (B? obj)
|
|
(m3 obj)
|
|
#f)
|
|
'())))))]
|
|
[v (make-vector 3)])
|
|
(vector-set! v 0 (gather-results robj))
|
|
(vector-set! v 1 (gather-results aobj))
|
|
(vector-set! v 2 (gather-results bobj))
|
|
v)))
|
|
; should return #( #f (4 2 #f) (22 8 -4))
|
|
'#(#f (4 2 #f) (22 8 -4)))
|
|
|
|
|
|
;; Allen Lee
|
|
|
|
(equal?
|
|
(letrec-classes ([superguy (x y) (<root>)
|
|
([x (* x x)]
|
|
[y (let ([x 3])
|
|
(+ x (- y y)))]
|
|
[z (lambda (x) (+ x x))])
|
|
(getX () x)
|
|
(getY () y)])
|
|
(letrec-classes ([subguy (x y) (superguy (+ x x) (+ y y))
|
|
([new-x x])
|
|
(plus (y) (+ new-x y))])
|
|
(letrec-classes ([subsubguy (x y z) (subguy
|
|
(+ (+ x y) z)
|
|
(getY (make-subguy x (* y z))))
|
|
()
|
|
(minus (y) (- new-x y))])
|
|
(let ([supe (make-superguy 2 1)]
|
|
[sub (make-subguy 3 4)]
|
|
[subsub (make-subsubguy 1 2 3)])
|
|
(letrec ([map (lambda (p ls)
|
|
(if (null? ls)
|
|
'()
|
|
(cons (p (car ls))
|
|
(map p (cdr ls)))))])
|
|
(let ([true (if (superguy? supe)
|
|
(if (superguy? sub)
|
|
(if (superguy? subsub)
|
|
(if (subguy? sub)
|
|
(if (subguy? subsub)
|
|
(if (subsubguy? subsub)
|
|
(if (not (subsubguy? sub))
|
|
(if (not (subsubguy? supe))
|
|
(not (subguy? supe))
|
|
#f)
|
|
#f)
|
|
#f)
|
|
#f)
|
|
#f)
|
|
#f)
|
|
#f)
|
|
#f)]
|
|
[x-es (map (lambda (obj)
|
|
(getX obj))
|
|
(cons supe (cons sub (cons subsub '()))))]
|
|
[y-es (map (lambda (obj)
|
|
(getY obj))
|
|
(cons supe (cons sub (cons subsub '()))))])
|
|
(cons true (cons x-es y-es))))))))
|
|
'(#t (4 36 144) 3 3 3))
|
|
|
|
(equal?
|
|
(letrec-classes ([NullEntity () (<root>)
|
|
()
|
|
(notifyme (evt) (if #f #f))])
|
|
(letrec-classes ([SchmentityEntity (int) (NullEntity)
|
|
([value int])
|
|
(notifyme (evt)
|
|
(evt value))]
|
|
[Pool (size) (<root>)
|
|
([numElements 0]
|
|
[pool (make-vector size)]
|
|
[observers (cons (make-NullEntity) '())])
|
|
(add (item)
|
|
(begin
|
|
(incrementElements self)
|
|
(if (not (< (getCurrentIndex self) (vector-length pool)))
|
|
;; need to re-expand the pool
|
|
(let ([newPool (make-vector
|
|
(* (getSize self)
|
|
(getLoadFactor self)))])
|
|
(letrec ([loop
|
|
(lambda (n)
|
|
(if (= n (getCurrentIndex self))
|
|
(begin
|
|
(vector-set! newPool n item)
|
|
newPool)
|
|
(begin
|
|
(vector-set! newPool n
|
|
(vector-ref pool n))
|
|
(loop (add1 n)))))])
|
|
(setPool self (loop 0))))
|
|
(vector-set! pool (getCurrentIndex self) item))))
|
|
(remove (item)
|
|
(letrec ([loop
|
|
(lambda (n)
|
|
(if (not (= n (getNumElements self)))
|
|
(if (= (vector-ref pool n) item)
|
|
(letrec
|
|
([shift
|
|
(lambda (start)
|
|
(if (= start (getCurrentIndex self))
|
|
(vector-set! pool
|
|
start (void))
|
|
(begin
|
|
(vector-set! pool start
|
|
(vector-ref pool (+ start 1)))
|
|
(shift (+ n 1)))))])
|
|
(shift n))
|
|
(decrementElements self))
|
|
(loop (+ n 1))))])
|
|
(loop 0)))
|
|
(isEmpty () (= (getNumElements self) 0))
|
|
(getCurrentIndex () (- (getNumElements self) 1))
|
|
(getSize () (vector-length pool))
|
|
(getNumElements () numElements)
|
|
(incrementElements ()
|
|
(set! numElements (+ numElements 1)))
|
|
(decrementElements ()
|
|
(if (not (= (getNumElements self) 0))
|
|
(set! numElements (- numElements 1))))
|
|
(getPool () pool)
|
|
(setPool (newPool)
|
|
(set! pool newPool))
|
|
(notify (evt)
|
|
(letrec ([loop
|
|
(lambda (ls)
|
|
(if (null? ls)
|
|
'()
|
|
(cons (notifyme (car ls) evt)
|
|
(loop (cdr ls)))))])
|
|
(loop observers)))
|
|
(subscribe (obj)
|
|
(set! observers (cons obj observers)))
|
|
(purgeObservers ()
|
|
(set! observers (cons (make-NullEntity) '())))
|
|
(getLoadFactor () 2)
|
|
(contains (item)
|
|
(letrec ([loop
|
|
(lambda (n)
|
|
(if (< n (getNumElements self))
|
|
(if (= item (vector-ref pool n))
|
|
#t
|
|
(loop (+ n 1)))
|
|
#f))])
|
|
(loop 0)))])
|
|
(let ([pool (make-Pool 37)])
|
|
(letrec ([addToPool (lambda (n)
|
|
(if (= n 0)
|
|
(isEmpty pool)
|
|
(begin
|
|
(add pool n)
|
|
(addToPool (sub1 n)))))])
|
|
(addToPool 42)
|
|
(addToPool 23)
|
|
(remove pool 14)
|
|
(subscribe pool (make-SchmentityEntity 23))
|
|
(subscribe pool (make-SchmentityEntity 14))
|
|
(let ([notified (notify pool (lambda (x) (* x 3)))])
|
|
(cons (isEmpty pool)
|
|
(cons (getCurrentIndex pool)
|
|
(cons (getPool pool)
|
|
(cons (getNumElements pool)
|
|
(cons (contains pool 23)
|
|
(cons (contains pool 15)
|
|
notified)))))))))))
|
|
; should evaluate to (#f 63 #74(some-huge-vector-with-65-elements) 64 #t #t 42 69 #<void>)
|
|
`(#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)))
|
|
|
|
(equal?
|
|
(letrec-classes ([broken () (<root>)
|
|
([vec (make-vector 5)])
|
|
(object-or-vector (n)
|
|
(if (< n 7)
|
|
(begin
|
|
(vector-set! vec 0 14)
|
|
(vector-set! vec 1 15)
|
|
(vector-set! vec 2 16)
|
|
vec)
|
|
self))])
|
|
(letrec-classes ([fixed-broken (num) (broken)
|
|
()
|
|
(object-or-vector (n)
|
|
(* n n))])
|
|
(let ([all-k (make-broken)])
|
|
(let ([still-valid1 (if (vector? (object-or-vector all-k 4))
|
|
(vector-ref (object-or-vector all-k 4) 0)
|
|
#f)]
|
|
[still-valid2 (if (vector? (object-or-vector all-k 5))
|
|
(vector-ref (object-or-vector all-k 5) 1)
|
|
#f)]
|
|
[still-valid3 (if (vector? (object-or-vector all-k 6))
|
|
(vector-ref (object-or-vector all-k 6) 2)
|
|
#f)]
|
|
[is-vector? (vector? (object-or-vector all-k 7))]
|
|
[fixed (make-fixed-broken 37)])
|
|
(cons (object-or-vector fixed 37)
|
|
(cons still-valid1
|
|
(cons still-valid2
|
|
(cons still-valid3
|
|
(cons is-vector? '())))))))))
|
|
;; should return the list (14 15 16 #t)
|
|
'(1369 14 15 16 #f))
|
|
|
|
|
|
;; Matthew Garrett
|
|
|
|
;;; eopl-tests.ss
|
|
|
|
;;; These test cases are translated as directly as possible from "Essentials
|
|
;;; of Programming Languages", 2nd Ed. by Friedman, Wand, and Haynes, Chapter
|
|
;;; 5, Objects and Classes.
|
|
|
|
(equal?
|
|
;;; Figure 5.1, A simple object-oriented program
|
|
(letrec-classes
|
|
([c1 (x) (<root>)
|
|
([i x] [j (- 0 x)])
|
|
(countup (d)
|
|
(set! i (+ i d))
|
|
(set! j (- j d)))
|
|
(getstate () (list i j))])
|
|
(let ([t1 0] [t2 0] [o1 (make-c1 3)])
|
|
(set! t1 (getstate o1))
|
|
(countup o1 2)
|
|
(set! t2 (getstate o1))
|
|
(list t1 t2)))
|
|
'((3 -3) (5 -5)))
|
|
|
|
(eq?
|
|
;;; page 172, odd-even
|
|
(letrec-classes
|
|
([oddeven () (<root>)
|
|
()
|
|
(even (n)
|
|
(if (zero? n)
|
|
1
|
|
(odd self (sub1 n))))
|
|
(odd (n)
|
|
(if (zero? n)
|
|
0
|
|
(even self (sub1 n))))])
|
|
(let ([o1 (make-oddeven)])
|
|
(odd o1 13)))
|
|
1)
|
|
|
|
(eq?
|
|
;;; Figure 5.2 Object-oriented program for summing the leaves of a tree
|
|
(letrec-classes ([<newroot> () (<root>) () [sum () (void)]])
|
|
(letrec-classes
|
|
([interior_node (l r) (<newroot>)
|
|
([left l] [right r])
|
|
(sum ()
|
|
(+ (sum left) (sum right)))]
|
|
[leaf_node (v) (<newroot>)
|
|
([value v])
|
|
(sum () value)])
|
|
(let ([o1 (make-interior_node
|
|
(make-interior_node
|
|
(make-leaf_node 3)
|
|
(make-leaf_node 4))
|
|
(make-leaf_node 5))])
|
|
(sum o1))))
|
|
12)
|
|
|
|
(equal?
|
|
;;; Figure 5.3 Classic example of inheritance: colorpoint
|
|
(letrec-classes
|
|
([point (initx inity) (<root>)
|
|
([x initx] [y inity])
|
|
(move (dx dy)
|
|
(set! x (+ x dx))
|
|
(set! y (+ y dy)))
|
|
(get_location () (list x y))]
|
|
[colorpoint (initx inity) (point initx inity)
|
|
([color 0])
|
|
(set_color (c) (set! color c))
|
|
(get_color () color)])
|
|
(let ([p (make-point 3 4)]
|
|
[cp (make-colorpoint 10 20)])
|
|
(move p 3 4)
|
|
(set_color cp 87)
|
|
(move cp 10 20)
|
|
(list (get_location p) (get_location cp) (get_color cp))))
|
|
;;; should return '((6 8) (20 40) 87)
|
|
'((6 8) (20 40) 87))
|
|
|
|
#;
|
|
(equal?
|
|
;;; page 175, shadowing
|
|
(letrec-classes
|
|
([c1 () (<root>)
|
|
([x 0] [y 0])
|
|
(setx1 (v) (set! x v))
|
|
(sety1 (v) (set! y v))
|
|
(getx1 () x)
|
|
(gety1 () y)])
|
|
(letrec-classes
|
|
([c2 () (c1)
|
|
([y2 0])
|
|
(sety2 (v) (set! y2 v))
|
|
(getx2 () (open-instance c1 "" self) x)
|
|
(gety2 () y2)])
|
|
(let ([o2 (make-c2)])
|
|
(setx1 o2 101)
|
|
(sety1 o2 102)
|
|
(sety2 o2 999)
|
|
(list (getx1 o2) (gety1 o2) (getx2 o2) (gety2 o2)))))
|
|
;;; should return '(101 102 101 999)
|
|
'(101 102 101 999))
|
|
|
|
(equal?
|
|
;;; page 176, redefining methods
|
|
(letrec-classes
|
|
([c1 () (<root>)
|
|
()
|
|
(m1 () 1)
|
|
(m2 () (m1 self))]
|
|
[c2 () (c1)
|
|
()
|
|
(m1 () 2)])
|
|
(let ([o1 (make-c1)] [o2 (make-c2)])
|
|
(list (m1 o1) (m1 o2) (m2 o2))))
|
|
'(1 2 2))
|
|
|
|
(equal?
|
|
;;; Figure 5.4 Example illustrating interaction of self and inheritance
|
|
(letrec-classes
|
|
([c1 () (<root>)
|
|
()
|
|
(m1 () 1)
|
|
(m2 () 100)
|
|
(m3 () (m2 self))]
|
|
[c2 () (c1)
|
|
()
|
|
(m2 () 2)])
|
|
(let ([o1 (make-c1)] [o2 (make-c2)])
|
|
(list (m1 o1) ; 1
|
|
(m2 o1) ; 100
|
|
(m3 o1) ; 100
|
|
(m1 o2) ; 1 (from c1)
|
|
(m2 o2) ; 2 (from c2)
|
|
(m3 o2)))) ; 2 (c1's m3 calls c2's m2)
|
|
'(1 100 100 1 2 2))
|
|
|
|
(eq?
|
|
;;; Figure 5.5 Example demonstrating a need for static method dispatch
|
|
(letrec-classes
|
|
([point (initx inity) (<root>)
|
|
([x initx] [y initx])
|
|
(move (dx dy)
|
|
(set! x (+ x dx))
|
|
(set! y (+ y dy)))
|
|
(getlocation ()
|
|
(list x y))]
|
|
[colorpoint (initx inity initcolor) (point 0 0)
|
|
([color initcolor])
|
|
(set_color (c) (set! color c))
|
|
(get_color () color)])
|
|
(let ([o1 (make-colorpoint 3 4 172)])
|
|
(get_color o1)))
|
|
172)
|
|
|
|
(eq?
|
|
;;; Figure 5.6 Example illustrating interaction of super call with self
|
|
(letrec-classes
|
|
([c1 () (<root>)
|
|
()
|
|
(m1 () (m2 self))
|
|
(m2 () 13)])
|
|
(letrec-classes
|
|
([c2 () (c1)
|
|
()
|
|
(m1 () (super))
|
|
(m2 () 23)
|
|
(m3 () (m1 self))])
|
|
(letrec-classes
|
|
([c3 () (c2)
|
|
()
|
|
(m1 () (super))
|
|
(m2 () 33)])
|
|
(let ([o3 (make-c3)])
|
|
(m3 o3)))))
|
|
33)
|
|
|
|
; Jeremiah Willcock
|
|
|
|
(eq?
|
|
(let ()
|
|
(define-class (A n) (<root>)
|
|
(ivars [next (foo n)])
|
|
(methods
|
|
[get-next () next]
|
|
[get-length ()
|
|
(if (null? next) 0 (+ 1 (get-length (get-next self))))]))
|
|
(define (foo n) (if (zero? n) '() (make-A (- n 1))))
|
|
(let ((a (make-A 10)))
|
|
(get-length a)))
|
|
10)
|
|
|
|
(eq?
|
|
(letrec-classes ((A (n) (<root>) ((next
|
|
(if (zero? n) '()
|
|
(make-A (- n 1)))))
|
|
(get-next () next)
|
|
(get-length ()
|
|
(if (null? next) 0
|
|
(+ 1 (get-length (get-next self)))))))
|
|
(let ((a (make-A 10)))
|
|
(get-length a)))
|
|
10)
|
|
|
|
; should this really be an error? It's not clear how to make base ivars
|
|
; visible in ivar inits efficiently if we want to do so.
|
|
(error? ; variable oop-x1 is not bound
|
|
(let ()
|
|
(define-class (<a> oop-x) (<root>) (ivars [oop-x1 oop-x]))
|
|
(define-class (<b> oop-x) (<a> oop-x) (ivars [oop-x2 (+ oop-x1 oop-x1)]))
|
|
(define-class (<c> oop-x) (<b> oop-x) (ivars [oop-x3 (+ oop-x2 oop-x2)]))
|
|
(define-class (<d> oop-x) (<c> oop-x) (ivars [oop-x4 (+ oop-x3 oop-x3)]))
|
|
(define-class (<e> oop-x) (<d> oop-x) (ivars [oop-x5 (+ oop-x4 oop-x4)]))
|
|
(define-class (<f> oop-x) (<e> oop-x) (ivars [oop-x6 (+ oop-x5 oop-x5)]))
|
|
(define-class (<g> oop-x) (<f> oop-x) (ivars [oop-x7 (+ oop-x6 oop-x6)]))
|
|
(define-class (<h> oop-x) (<g> oop-x) (ivars [oop-x8 (+ oop-x7 oop-x7)]))
|
|
(define-class (<i> oop-x) (<h> oop-x) (ivars [oop-x9 (+ oop-x8 oop-x8)]) (methods [m () oop-x9]))
|
|
(m (make-<i> 1))))
|
|
|
|
(eq?
|
|
(let ()
|
|
(define-class (<a> x0) (<root>)
|
|
(ivars [x1 (+ x0 x0)]
|
|
[x2 (+ x1 x1)]
|
|
[x3 (+ x2 x2)]
|
|
[x4 (+ x3 x3)]
|
|
[x5 (+ x4 x4)]
|
|
[x6 (+ x5 x5)]
|
|
[x7 (+ x6 x6)]
|
|
[x8 (+ x7 x7)]
|
|
[x9 (+ x8 x8)])
|
|
(methods [m () x9]))
|
|
(m (make-<a> 1)))
|
|
512)
|
|
|
|
|
|
; Abdulaziz Ghuloum
|
|
|
|
(begin
|
|
(define-class (R) (<root>))
|
|
#t)
|
|
(eq? (R? 0) #f)
|
|
|
|
(eq? (R? (cons 1 2)) #f)
|
|
|
|
(eq? (R? (make-vector 2)) #f)
|
|
|
|
(eq? (R? (lambda () 4)) #f)
|
|
|
|
(eq? (R? #f) #f)
|
|
|
|
(eq? (R? #t) #f)
|
|
|
|
(eq? (R? '()) #f)
|
|
|
|
(equal?
|
|
(letrec-classes
|
|
([AA () (<root>)
|
|
([x 0][y 0])
|
|
(get-x () x)
|
|
(get-y () y)
|
|
(set-x (a)
|
|
(letrec-classes
|
|
([AA () (<root>)
|
|
()
|
|
(set-x (a) (set! x a))])
|
|
(set-x (make-AA) a)))
|
|
(set-y (a)
|
|
(letrec-classes
|
|
([AA () (<root>)
|
|
([y 0])
|
|
(set-y (a) (set! y a))])
|
|
(set-y (make-AA) a)))])
|
|
(let ([a (make-AA)])
|
|
(set-x a 5)
|
|
(set-y a 0)
|
|
(cons (get-x a) (get-y a))))
|
|
'(5 . 0))
|
|
|
|
(eq?
|
|
(letrec-classes
|
|
([<pair> (a b) (<root>)
|
|
([a a][b b])
|
|
(car () a)
|
|
(cdr () b)
|
|
(set-car! (x) (set! a x))
|
|
(set-cdr! (x) (set! b x))])
|
|
(let ([cons (lambda (a b) (make-<pair> a b))]
|
|
[pair? (lambda (x) (<pair>? x))])
|
|
(let ([x (cons 4 5)])
|
|
(let ([y (cons 3 4)])
|
|
(set-car! y 12)
|
|
(set-cdr! x y)
|
|
(let ([cdr (cdr x)])
|
|
(if (pair? cdr)
|
|
(let ([car (car cdr)])
|
|
(if (pair? car) #f car))))))))
|
|
12)
|
|
|
|
; this doesn't test the oop system at all:
|
|
#;
|
|
(equal?
|
|
(let
|
|
([letrec-classes
|
|
(lambda (x y) (cons x y))]
|
|
[<root> (lambda () 7)]
|
|
[y (lambda () 3)]
|
|
[x (lambda (y) y)]
|
|
[self (cons 12 (cons 34 45))]
|
|
[A (lambda (a b c d)
|
|
(lambda ()
|
|
(let ([v (make-vector 4)])
|
|
(vector-set! v 0 a)
|
|
(vector-set! v 1 b)
|
|
(vector-set! v 2 c)
|
|
(vector-set! v 3 d)
|
|
v)))]
|
|
[make (lambda (a b) b)]
|
|
[inc-x (lambda (a b) (cons a b))]
|
|
[s (lambda () 87)])
|
|
(letrec-classes
|
|
([A (y) (<root>)
|
|
([x y])
|
|
(inc-x (s) (begin self))])
|
|
(inc-x (make-A 3) 3)))
|
|
'(#4(3 7 3 (87 12 34 . 45)) 3 . 3))
|
|
|
|
(eq?
|
|
(let ([let 0][lambda 1][letrec 2][if 5])
|
|
(letrec-classes
|
|
([A (x) (<root>)
|
|
([x x])
|
|
(inc-x (s) (begin (set! x (+ x s)) self))
|
|
(get-x () x)])
|
|
(get-x (inc-x (make-A 4) 3))))
|
|
7)
|
|
|
|
; Jeremiah Willcock
|
|
|
|
(eq?
|
|
(letrec-classes () #f)
|
|
#f)
|
|
|
|
(eq?
|
|
(letrec-classes ((A () (<root>) ()))
|
|
(letrec-classes ((B () (A) ()))
|
|
(make-B)
|
|
#f))
|
|
#f)
|
|
|
|
(eq?
|
|
(letrec-classes ((A () (<root>) () (foo () 5)))
|
|
(letrec-classes ((B () (A) () (foo () 7) (bar () 8)))
|
|
(foo (make-B))))
|
|
7)
|
|
|
|
(equal?
|
|
(letrec-classes
|
|
((A (x y) (<root>) ((x x) (y y))
|
|
(get-x () x)
|
|
(get-y () y)
|
|
(set-x (value) (set! x value))))
|
|
(let ((A (make-A 1 2)))
|
|
(cons (get-x A) (get-y A))))
|
|
'(1 . 2))
|
|
|
|
(eq?
|
|
(letrec-classes ((A () (<root>) ()))
|
|
(letrec-classes ((<root> () (A) () (foo () 5)))
|
|
(foo (make-<root>))))
|
|
5)
|
|
|
|
#;
|
|
(equal?
|
|
(letrec-classes
|
|
((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
|
|
(get-x () (- x 3))
|
|
(get-y () (* 2 y))))
|
|
(letrec-classes
|
|
((<xroot> (z w) (A (* w z) (- w z)) ()
|
|
(get-x () (open-instance A "" self) x)
|
|
(set-x! (<yroot>) (open-instance A "" self) (set! x <yroot>))
|
|
(call-get-x (set-x!) (get-x set-x!))
|
|
(call-set-x! (A) (set-x! self A))))
|
|
(let ((<zroot> (make-<xroot> 4 9)))
|
|
(let ((x (get-x <zroot>))
|
|
(y (get-y <zroot>))
|
|
(x2 (call-get-x <zroot> <zroot>)))
|
|
(cons x
|
|
(cons y
|
|
(cons x2
|
|
(let ((foo (set-x! <zroot> 7)))
|
|
(cons (get-x <zroot>) '())))))))))
|
|
'(72 24 72 7))
|
|
|
|
#;
|
|
(equal?
|
|
(letrec-classes
|
|
((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
|
|
(get-x () (- x 3))
|
|
(get-y () (* 2 y))))
|
|
(letrec-classes
|
|
((<xroot> (z w) (A (* w z) (- w z)) ()
|
|
(get-x () (open-instance A "" self) x)
|
|
(set-x! (<yroot>) (open-instance A "" self) (set! x <yroot>))
|
|
(call-get-x (set-x!) (get-x set-x!))
|
|
(call-set-x! (A) (set-x! self A))))
|
|
(let ((<root> (make-<xroot> 4 9)))
|
|
(let ((x (get-x <root>))
|
|
(y (get-y <root>))
|
|
(x2 (call-get-x <root> <root>)))
|
|
(cons x
|
|
(cons y
|
|
(cons x2
|
|
(let ((foo (set-x! <root> 7)))
|
|
(cons (get-x <root>) '())))))))))
|
|
'(72 24 72 7))
|
|
|
|
#;
|
|
(equal?
|
|
(letrec-classes
|
|
((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
|
|
(get-x () (- x 3))
|
|
(get-y () (* 2 y))))
|
|
(letrec-classes
|
|
((<xroot> (z w) (A (* w z) (- w z)) ()
|
|
(get-x () (open-instance A "" self) x)
|
|
(set-x! (<root>) (open-instance A "" self) (set! x <root>))
|
|
(call-get-x (set-x!) (get-x set-x!))
|
|
(call-set-x! (A) (set-x! self A))))
|
|
(let ((<root> (make-<xroot> 4 9)))
|
|
(let ((x (get-x <root>))
|
|
(y (get-y <root>))
|
|
(x2 (call-get-x <root> <root>)))
|
|
(cons x
|
|
(cons y
|
|
(cons x2
|
|
(let ((foo (set-x! <root> 7)))
|
|
(cons (get-x <root>) '())))))))))
|
|
'(72 24 72 7))
|
|
|
|
(eq?
|
|
(letrec-classes ((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
|
|
(get-x () x)))
|
|
(letrec-classes
|
|
((<root> (z w) (A (* w z) (- w z)) ()
|
|
(get-x () 7)
|
|
(call-get-x (set-x!) (get-x set-x!))))
|
|
(let ((<root> (make-<root> 4 9)))
|
|
(call-get-x <root> <root>))))
|
|
7)
|
|
|
|
(eq?
|
|
(letrec-classes ((A () (<root>) ()))
|
|
(letrec-classes
|
|
((<root> () (A) ()
|
|
(set-x! (<root>) #f)))
|
|
#f))
|
|
#f)
|
|
|
|
#;
|
|
(equal?
|
|
(letrec-classes
|
|
((A (x y) (<root>) ((x (* 2 x)) (y (+ 7 y)))
|
|
(get-x () (- x 3))
|
|
(get-y () (* 2 y))))
|
|
(letrec-classes
|
|
((<root> (z w) (A (* w z) (- w z)) ()
|
|
(get-x () (open-instance A "" self) x)
|
|
(set-x! (<root>) (open-instance A "" self) (set! x <root>))
|
|
(call-get-x (set-x!) (get-x set-x!))
|
|
(call-set-x! (A) (set-x! self A))))
|
|
(let ((<root> (make-<root> 4 9)))
|
|
(let ((x (get-x <root>))
|
|
(y (get-y <root>))
|
|
(x2 (call-get-x <root> <root>)))
|
|
(cons x
|
|
(cons y
|
|
(cons x2
|
|
(let ((foo (set-x! <root> 7)))
|
|
(cons (get-x <root>) '())))))))))
|
|
'(72 24 72 7))
|
|
|
|
(equal?
|
|
(letrec-classes
|
|
((xself () (<root>) ((x 7))
|
|
(xisa-vtable? () (let ((self 5)) (+ x self)))))
|
|
(cons
|
|
(xisa-vtable? (make-xself))
|
|
(xself? (make-xself))))
|
|
'(12 . #t))
|
|
|
|
(equal?
|
|
(letrec-classes
|
|
((xself () (<root>) ((x 7))
|
|
(isa-vtable? () (let ((self 5)) (+ x self)))))
|
|
(cons
|
|
(isa-vtable? (make-xself))
|
|
(xself? (make-xself))))
|
|
'(12 . #t))
|
|
|
|
(equal?
|
|
(letrec-classes ; Cannot have class named "self"
|
|
((self () (<root>) ((x 7))
|
|
(isa-vtable? () (let ((self 5)) (+ x self)))))
|
|
(cons
|
|
(isa-vtable? (make-self))
|
|
(self? (make-self))))
|
|
'(12 . #t))
|
|
|
|
(eq?
|
|
(let ((self 5))
|
|
(letrec-classes ((A () (<root>) ()
|
|
(foo () self)
|
|
(bar () 5)))
|
|
(let ((self 7))
|
|
(bar (foo (make-A))))))
|
|
5)
|
|
|
|
(equal?
|
|
(letrec-classes ((A () (<root>) ())
|
|
(B () (<root>) ()))
|
|
(letrec-classes ((C () (A) ()))
|
|
(letrec-classes ((D () (C) ()))
|
|
(let ((isa-grid-entry (lambda (obj)
|
|
(cons (A? obj)
|
|
(cons (B? obj)
|
|
(cons (C? obj)
|
|
(cons (D? obj) '())))))))
|
|
(letrec ((map (lambda (f l)
|
|
(if (null? l) '()
|
|
(cons (f (car l))
|
|
(map f (cdr l)))))))
|
|
(map isa-grid-entry
|
|
(cons 5
|
|
(cons (make-A)
|
|
(cons (make-B)
|
|
(cons (make-C)
|
|
(cons (make-D) '())))))))))))
|
|
'((#f #f #f #f)
|
|
(#t #f #f #f)
|
|
(#f #t #f #f)
|
|
(#t #f #t #f)
|
|
(#t #f #t #t)))
|
|
|
|
(equal?
|
|
(letrec-classes ((A () (<root>) ()))
|
|
(let ((z (make-A)))
|
|
(cons (pair? z)
|
|
(cons (vector? z)
|
|
(cons (null? z)
|
|
(cons (procedure? z)
|
|
(cons (boolean? z)
|
|
'())))))))
|
|
'(#f #f #f #f #f))
|
|
|
|
#;
|
|
(equal?
|
|
(let ((x 7))
|
|
(letrec-classes ((A () (<root>) ((y x))))
|
|
(letrec-classes ((B () (A) () (set-x (value) (set! x value))
|
|
(get-y () (open-instance A "" self) y)))
|
|
(let ((w (make-B)))
|
|
(set-x w 9)
|
|
(cons (get-y w) x)))))
|
|
'(7 . 9))
|
|
|
|
(equal?
|
|
(letrec-classes ((A () (<root>) () (x () 1) (y () 2)))
|
|
(letrec-classes ((B () (A) () (x () (- 0 (super))) (z () 3)))
|
|
(letrec-classes ((C () (B) () (y () (+ 10 (super)))
|
|
(z () (- 0 (super)))))
|
|
(let ((a (make-A)) (b (make-B)) (c (make-C)))
|
|
(cons
|
|
(cons (x a) (y a))
|
|
(cons
|
|
(cons (x b) (cons (y b) (z b)))
|
|
(cons
|
|
(cons (x c) (cons (y c) (z c))) '())))))))
|
|
'((1 . 2) (-1 2 . 3) (-1 12 . -3)))
|
|
|
|
(eq?
|
|
; Based on suggestion in class about constructors making the same class
|
|
(letrec-classes ((A (n) (<root>) ((next
|
|
(if (zero? n) '()
|
|
(make-A (- n 1)))))
|
|
(get-next () next)
|
|
(get-length ()
|
|
(if (null? next) 0
|
|
(+ 1 (get-length (get-next self)))))))
|
|
(let ((a (make-A 10)))
|
|
(get-length a)))
|
|
10)
|
|
|
|
(equal?
|
|
; Automatic differentiator -- expressions of one variable w/ int constants
|
|
(letrec-classes ((Differentiable () (<root>) () (compute () #f)
|
|
(diff () #f)))
|
|
(letrec-classes (
|
|
(sum (a b) (Differentiable) ((a a) (b b))
|
|
(compute ()
|
|
(lambda (x)
|
|
(+ ((compute a) x)
|
|
((compute b) x))))
|
|
(diff () (make-sum (diff a) (diff b))))
|
|
(prod (a b) (Differentiable) ((a a) (b b))
|
|
(compute ()
|
|
(lambda (x)
|
|
(* ((compute a) x)
|
|
((compute b) x))))
|
|
(diff () (make-sum
|
|
(make-prod a (diff b))
|
|
(make-prod b (diff a)))))
|
|
(pow (a b) (Differentiable) ((a a) (b b)) ; Constant exponent
|
|
(compute ()
|
|
(letrec ((real-pow
|
|
(lambda (base power)
|
|
(if (zero? power)
|
|
1
|
|
(* base
|
|
(real-pow base (- power 1)))))))
|
|
(lambda (x)
|
|
(real-pow ((compute a) x) b))))
|
|
(diff ()
|
|
(if (zero? b)
|
|
(make-constant 0)
|
|
(make-prod (make-constant b)
|
|
(make-prod
|
|
(make-pow a (- b 1))
|
|
(diff a))))))
|
|
(constant (x) (Differentiable) ((x x))
|
|
(compute ()
|
|
(lambda (z) x))
|
|
(diff () (make-constant 0)))
|
|
(variable () (Differentiable) ()
|
|
(compute ()
|
|
(lambda (x) x))
|
|
(diff () (make-constant 1))))
|
|
(let ((+ (lambda (a b) (make-sum a b)))
|
|
(- (lambda (a b) (make-sum a (make-prod b (make-constant -1)))))
|
|
(* (lambda (a b) (make-prod a b)))
|
|
(^ (lambda (a b) (make-pow a b)))
|
|
(! (lambda (x) (make-constant x)))
|
|
(x (make-variable)))
|
|
(let ((fun (+ (^ (- x (! 1)) 9) (* x (! 7)))))
|
|
(letrec ((diff-at-values (lambda (fun ndiffs vals)
|
|
(if (zero? ndiffs)
|
|
'()
|
|
(cons
|
|
(letrec ((map (lambda (f l)
|
|
(if (null? l) '()
|
|
(cons (f (car l))
|
|
(map f (cdr l)))))))
|
|
(map (compute fun) vals))
|
|
(diff-at-values (diff fun) (sub1 ndiffs) vals))))))
|
|
(diff-at-values fun 4 '(-5 -4 -3 -2 -1 0 1 2 3 4 5)))))))
|
|
'((-10077731 -1953153 -262165 -19697 -519 -1 7 15 533 19711 262179)
|
|
(15116551 3515632 589831 59056 2311 16 7 16 2311 59056 589831)
|
|
(-20155392 -5625000 -1179648 -157464 -9216 -72 0 72 9216 157464 1179648)
|
|
(23514624 7875000 2064384 367416 32256 504 0 504 32256 367416 2064384)))
|
|
|
|
; Robert George
|
|
|
|
(eq?
|
|
(letrec-classes ([A () (<root>)
|
|
([x 1]
|
|
[y (letrec-classes ([B () (<root>)
|
|
([x2 2])
|
|
(get-x () (if x2 x2 (letrec-classes ([C () (<root>)
|
|
([x3 3])
|
|
(get-x () x3)])
|
|
(let ([obj (make-C)])
|
|
(get-x obj)))))])
|
|
(let ([obj (make-B)])
|
|
(get-x obj)))])
|
|
(get-x () x)])
|
|
(get-x (make-A)))
|
|
1)
|
|
|
|
(equal?
|
|
(letrec ([map (lambda (proc ls)
|
|
(if (null? ls)
|
|
'()
|
|
(cons (proc (car ls)) (map proc (cdr ls)))))])
|
|
(letrec-classes ([A () (<root>)
|
|
([x 0])
|
|
(square-and-set (y) (let ([val (* y y)])
|
|
(set! x (+ x val))
|
|
val))
|
|
(get-x () x)])
|
|
(let ([obj (make-A)])
|
|
(let ([ls (map (lambda (x) (square-and-set obj x)) '(1 2 3 4 5))])
|
|
(cons ls (get-x obj))))))
|
|
'((1 4 9 16 25) . 55))
|
|
|
|
#;
|
|
(eq?
|
|
(let ([x 5])
|
|
(letrec-classes ([A () (<root>)
|
|
([x 3])
|
|
(get-x () x)])
|
|
(letrec-classes ([B () (A)
|
|
([y 4])
|
|
(get-x () (open-instance A "" self) x)])
|
|
(+ x (get-x (make-B)) (get-x (make-A))))))
|
|
11)
|
|
|
|
(eq?
|
|
(letrec-classes ([A () (<root>)
|
|
([x 1] [y (+ x x)])
|
|
(get-x () x)
|
|
(get-y () y)])
|
|
(letrec-classes ([B () (A)
|
|
([z 3])
|
|
(add-em () (+ (get-x (make-A)) (get-x (make-B)) z))])
|
|
(add-em (make-B))))
|
|
5)
|
|
|
|
(eq?
|
|
(letrec-classes ([A () (<root>)
|
|
([x 1])
|
|
(get-x () x)])
|
|
(letrec-classes ([B () (A)
|
|
([y 3])
|
|
(get-x () (super))])
|
|
(get-x (make-B))))
|
|
1)
|
|
|
|
(eq?
|
|
(letrec-classes ([A () (<root>)
|
|
([x 1])
|
|
(create-A () (make-A))])
|
|
(letrec-classes ([B () (A)
|
|
([y 2])
|
|
(do-it () (A? (create-A (make-B))))])
|
|
(do-it (make-B))))
|
|
#t)
|
|
|
|
(eq?
|
|
(let ()
|
|
(define-syntax albatross
|
|
(syntax-rules ()
|
|
[(_ f m)
|
|
(begin
|
|
(define-class (fowl) (<root>) (ivars [x 77]) (methods [m () x]))
|
|
(define f (lambda () (make-fowl))))]))
|
|
(albatross alcatraz pelican)
|
|
(pelican (alcatraz)))
|
|
77)
|
|
|
|
(error? ; variable make-fowl is not bound
|
|
(make-fowl))
|
|
|
|
; Jeremy Siek
|
|
|
|
(eq?
|
|
(letrec-classes ((shape () (<root>) () (foo (s) s)))
|
|
(letrec-classes ((rect () (shape) () (get-h () 0) (foo (s) s)))
|
|
(let ([r (make-rect)]) (get-h r))))
|
|
0)
|
|
)
|