---

       # 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= (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] (list= (append 5 (vector 1 2)) (vector 1 2 5));

[hear] (define select-match
         (lambda (test lst)
           (if (> (list-length (lst)) 0)
           (if (test (head (lst)))
               (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)));

[hear] (define setup-this
         (lambda (this self)
           (if (number? / this)
           (self)
           (this))));

       # 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))
              (if (= (head (x)) class)
                  (let ((name (list-ref (x) 1))
                    (args (list-ref (x) 2))
                    (fields (tail (tail (tail (x))))))
                (translate
                 (vector
                  define
                  (name)
                  (vector
                   lambda
                   (prepend ext-this (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)
                     (vector
                      let
                      (vector
                       (vector
                        this
                        (vector setup-this
                            (vector ext-this)
                            (vector self))))
                      (vector
                       let
                       (vector (vector ignore-this 1))
                       (vector
                        lambda
                        (vector method)
                        (vector
                         (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) classname)
                        (name))
                       (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 new)
                      (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)));

       # Check that virtual calls can be made to work.
       # They are a little awkward right now.
       # Should they be the default?
[hear] (class c1 ()
              (method getid 100)
              (method altid (this getid)));

[hear] (class c2 ()
              (field super-ref (make-cell 0))
              (method new (set! (super-ref) (c1 / this)))
              (method super (? x ((get! / super-ref) (x))))
              (method unknown (? x (self super / x)))
              (method getid 200));

[hear] (= 100 / c1 new altid);

[hear] (= 200 / c2 new altid);