Section 38Want more of a challenge? View in iconic form (experimental)

# OBJECT adding a special form for classes
# need a bunch of extra machinery first, will push this
# back into previous sections eventually, and simplify
[hear] (define list-append
(lambda (lst1 lst2)
(if (> (list-length (lst1)) 0)
(list-append (except-last (lst1))
(prepend (last (lst1)) (lst2)))
(lst2))));

[hear] (= (list-append (vector 1 2 3) (vector 4 5 6)) (vector 1 2 3 4 5 6));

[hear] (define append
(? x
(? lst
(if (> (list-length (lst)) 0)
(prepend (head (lst)) (append (x) (tail (lst))))
(vector (x))))));

[hear] (= (append 5 (vector 1 2)) (vector 1 2 5));

[hear] (define select-match
(lambda (test lst)
(if (> (list-length (lst)) 0)
(prepend (head (lst)) (select-match (test) (tail (lst))))
(select-match (test) (tail (lst))))
(lst))));

[hear] (define unique
(let ((store (make-cell 0)))
(lambda (x)
(let ((id (get! (store))))
(begin
(set! (store) (+ (id) 1))
(id))))));

[hear] (= (unique new) 0);

[hear] (= (unique new) 1);

[hear] (= (unique new) 2);

[hear] (not (= (unique new) (unique new)));

# okay, here it comes. don't panic!
# I need to split this up into helpers, and simplify.
# It basically just writes code for classes like we saw in
# a previous section.
[hear] (define prev-translate (translate));

[hear] (define translate
(let ((prev (prev-translate)))
(? x
(if (number? (x))
(prev (x))
(let ((name (list-ref (x) 1))
(args (list-ref (x) 2))
(fields (tail (tail (tail (x))))))
(translate
(vector
define
(name)
(vector
lambda
(prepend method (args))
(vector
let
(append
(vector unique-id (vector unique new))
(map
(tail)
(select-match (? x (= (first (x)) field)) (fields))))
(vector
let
(vector
(vector
self
(vector
reflective
(vector
lambda
(vector self method)
(list-append
(prepend
cond
(list-append
(map
(? x
(vector
(vector = (vector method) (first (x)))
(second (x))))
(map (tail)
(select-match
(? x (= (first (x)) method))
(fields))))
(map
(? x
(vector
(vector = (vector method) (x))
(vector (x))))
(map (second)
(select-match
(? x (= (first (x)) field))
(fields))))))
(vector
(vector
(vector = (vector method) self)
(vector self))
(vector
(vector = (vector method) (name))
(vector self self))
(vector
(vector = (vector method) unknown)
(vector lambda (vector x) 0))
(vector
(vector = (vector method) new)
0)
(vector
(vector = (vector method) unique-id)
(vector unique-id))
(vector
(vector = (vector method) ==)
(vector
lambda
(vector x)
(vector =
(vector unique-id)
(vector x unique-id))))
(vector self unknown (vector method))))))))
(vector
begin
(vector self (vector method))
(vector self))))))))
(prev (x)))))));

# revisit the point class example
[hear] (class point (x y)
(method x (x))
(method y (y))
(method + (lambda ((p point))
(point new
(+ (x) (p x))
(+ (y) (p y)))))
(method = (lambda ((p point))
(and (= (x) (p x))
(= (y) (p y))))));

# note the appearance of new in the next line --
# this is the only difference to previous version
[hear] (define point1 (point new 1 11));

[hear] (define point2 (point new 2 22));

[hear] (= 1 (point1 x));

[hear] (= 22 (point2 y));

[hear] (= 11 ((point new 11 12) x));

[hear] (= 11 (((point new 11 12) point) x));

[hear] (= 16 (((point new 16 17) point) x));

[hear] (= 33 (point1 + (point2) y));

[hear] (point1 + (point2) = (point new 3 33));

[hear] (point2 + (point1) = (point new 3 33));

[hear] ((point new 100 200) + (point new 200 100) = (point new 300 300));

[hear] (instanceof point (point1));

[hear] (not (instanceof int (point1)));