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.
|
|
|
|
(cond-expand
|
|
|
|
|
(chicken-4
|
|
|
|
|
(load-relative "../foops")
|
|
|
|
|
(use test))
|
|
|
|
|
(chicken-5
|
|
|
|
|
(import srfi-1 test foops)))
|
|
|
|
|
|
|
|
|
|
(import foops)
|
|
|
|
|
|
|
|
|
|
(test-group "basic functionality"
|
|
|
|
|
(define foo (make-object () ((bar) 'baz)))
|
|
|
|
|
(test 'baz (foo 'bar))
|
|
|
|
|
|
|
|
|
|
(define widget
|
|
|
|
|
(make-object (self)
|
|
|
|
|
((frob) 'foo)
|
|
|
|
|
((echo s) s)
|
|
|
|
|
((send m) (self m))))
|
|
|
|
|
|
|
|
|
|
(test 'foo (widget 'frob))
|
|
|
|
|
(test "here" (widget 'echo "here"))
|
|
|
|
|
(test 'foo (widget 'send 'frob))
|
|
|
|
|
(test-error (widget 'err)))
|
|
|
|
|
|
|
|
|
|
(test-group "inheritance"
|
|
|
|
|
(define dinosaur
|
|
|
|
|
(make-object (self)
|
|
|
|
|
((sound) 'rawr)
|
|
|
|
|
((talk) (self 'sound))))
|
|
|
|
|
|
|
|
|
|
(define t-rex
|
|
|
|
|
(derive-object (dinosaur self super)
|
|
|
|
|
((sound) 'hah)
|
|
|
|
|
((talk-original) (super 'sound))))
|
|
|
|
|
|
|
|
|
|
(test 'rawr (dinosaur 'talk))
|
|
|
|
|
(test 'hah (t-rex 'talk))
|
|
|
|
|
(test 'rawr (t-rex 'talk-original)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-group "pattern matching"
|
|
|
|
|
(define vehicle
|
|
|
|
|
(make-object (self)
|
|
|
|
|
((drive) 'wroom)
|
|
|
|
|
((drive distance)
|
|
|
|
|
(map (lambda (i) (self 'drive))
|
|
|
|
|
(iota distance)))
|
|
|
|
|
((drive distance speed)
|
|
|
|
|
(cons speed (self 'drive distance)))))
|
|
|
|
|
|
|
|
|
|
(test 'wroom (vehicle 'drive))
|
|
|
|
|
(test '(wroom wroom) (vehicle 'drive 2))
|
|
|
|
|
(test '(fast wroom wroom wroom) (vehicle 'drive 3 'fast)))
|
