Cloning Problems, and a Fix

In my multiple inheritance system, described in the previous post, I discovered a problem with 'clone and thought it appropriate to publish the fix. The problem is that in the previous version to override one of the parent’s function a weak-boxing of the object was saved in a closure. However this value isn’t changed when the object is cloned, so those overridden functions will all send their messages back to the same object, not necessarily the one that they are parents of after cloning. My solution to this problem is with an application of fluid-let that allows subclass to be a reference to the derived instance when parent calls are invoked. Also I changed the way in which I accessed the old, parent version of a method, the reason for which will become apparent when I wrap inheritance with macros.

Anyways the new implementation of iobject is:

(define subclass #f)

(define make-iobject
  (lambda ()
    (let ((o-3
           (let
               ((dispatches (make-hash-table)) (i-self '()) (parents '()))
             (lambda (message . params)
               (cond ((eq? message 'set-dispatch)
                      (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params))))
                      (hash-table-put! dispatches (car params) (car (cdr params))))
                     ((eq? message 'has-dispatch?)
                      (let ((result #t)) (hash-table-get dispatches (car params) (lambda () (set! result #f))) result))
                     ((eq? message 'get-dispatch)
                      (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params)))))
                     ((eq? message 'create-dispatch)
                      (hash-table-put! dispatches (car params) (car (cdr params))))
                     ((eq? message 'remove-dispatch)
                      (hash-table-remove! dispatches (car params)))
                     ((eq? message 'clone)
                      (let ((rslt (make-iobject)))
                        (hash-table-for-each dispatches (lambda (key value) (rslt 'create-dispatch key value)))
                        (for-each (lambda (p) (rslt 'set-parent! (p 'clone))) parents)
                        rslt))
                     ((eq? message 'set-self)
                      (if (null? i-self) (set! i-self (make-weak-box (car params)))))
                     ((eq? message 'set-parent!)
                      (set! parents (cons (car params) parents)))
                     ((eq? message 'get-parents)
                      parents)
                     (else (fluid-let ((self (weak-box-value i-self)))
                             (letrec ((tryparents
                                       (lambda (message params parents)
                                         (if (null? parents)
                                             (throw (make-dispatch-exception (cons message params)))
                                             (try
                                              (fluid-let ((subclass self))
                                                (apply (car parents) message params))
                                              catch dispatch-exception?
                                               (tryparents message params (cdr parents)))))))
                               (if self
                                   (try
                                     (apply (hash-table-get dispatches
                                                          message
                                                          (lambda ()
                                                            (throw (make-dispatch-exception (cons message params)))))
                                          params)
                                   catch dispatch-exception?
                                     (tryparents message params parents)
                                   ))))))
               )
             )))
      (o-3 'set-self o-3)
      (set-member! o-3 'type? (lambda (val) (eq? val 'object)))
      o-3)))

and the revised example is:

(define make-auto
  (lambda ()
    (let ((obj (make-iobject)) (rslt (make-iobject)))
      (rslt 'set-parent! obj)
      (let ((old-type (get-member obj 'type?)))
        (set-member! rslt 'type? (lambda (val) (or (eq? val 'auto) (old-type val))))
        )
      (set-member! rslt 'drive (lambda () (self 'name) (display ": ") (display "vroom") (newline)))
      (set-member! rslt 'name (lambda () (display "automobile")))
      rslt
      )))

(define make-plane
  (lambda ()
    (let ((obj (make-iobject)) (rslt (make-iobject)))
      (rslt 'set-parent! obj)
      (let ((old-type (get-member obj 'type?)))
        (set-member! rslt 'type? (lambda (val) (or (eq? val 'plane) (old-type val))))
        )
      (set-member! rslt 'fly (lambda () (self 'name) (display ": ") (display "zoom") (newline)))
      (set-member! rslt 'name (lambda () (display "airplane")))
      rslt
      )))

(define make-car-plane
  (lambda ()
    (let ((auto (make-auto)) (plane (make-plane)) (rslt (make-iobject)))
      (rslt 'set-parent! auto)
      (rslt 'set-parent! plane)
      (let ((auto-type (get-member auto 'type?)) (plane-type (get-member plane 'type?)))
        (set-member! rslt 'type? (lambda (val) (or (eq? val 'car-plane) (auto-type val) (plane-type val))))
        )
      (set-member! rslt 'name (lambda () (display "car-plane")))
      (if (has-member? auto 'name)
          (set-member! auto 'name (lambda x (apply subclass 'name x))))
      (if (has-member? plane 'name)
          (set-member! plane 'name (lambda x (apply subclass 'name x))))
      rslt
      )))

Another thought on future implementations: you notice how much work goes into making an inherited class, well it may be more efficient to make the inherited class once and simply clone it from that point forward (keeping an unaltered copy for cloning around of course). It is this line of thinking that exposed the error to me.

Inheritance and Copying

Since I couldn’t figure out which was better I created two object systems that supported inheritance. The first is a simpler, but more elegant, system which only supports single inheritance. But first some helper functions:

(define get-member
  (lambda (obj m)
    (obj 'get-dispatch m)
    ))

(define set-member!
  (lambda (obj m val)
    (obj 'create-dispatch m val)
    ))

(define has-member?
  (lambda (obj m)
    (obj 'has-dispatch? m)
    ))

Our object generator is as follows:

(define make-object
  (lambda ()
    (let ((o-3
           (let
               ((dispatches (make-hash-table)) (i-self '()))
             (lambda (message . params)
               (cond ((eq? message 'set-dispatch)
                      (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params))))
                      (hash-table-put! dispatches (car params) (car (cdr params))))
                     ((eq? message 'has-dispatch?)
                      (let ((result #t)) (hash-table-get dispatches (car params) (lambda () (set! result #f))) result))
                     ((eq? message 'get-dispatch)
                      (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params)))))
                     ((eq? message 'create-dispatch)
                      (hash-table-put! dispatches (car params) (car (cdr params))))
                     ((eq? message 'remove-dispatch)
                      (hash-table-remove! dispatches (car params)))
                     ((eq? message 'clone)
                      (let ((rslt (make-object)))
                        (hash-table-for-each dispatches (lambda (key value) (rslt 'create-dispatch key value)))
                        rslt))
                     ((eq? message 'set-self)
                      (if (null? i-self) (set! i-self (make-weak-box (car params)))))
                     (else (fluid-let ((self (weak-box-value i-self)))
                             (if self
                                 (apply (hash-table-get dispatches
                                                        message
                                                        (lambda () (throw (make-dispatch-exception (cons message params)))))
                                        params)))))
               )
             )))
      (o-3 'set-self o-3)
      (set-member! o-3 'type? (lambda (val) (eq? val 'object)))
      o-3)))

New in this object is the ability to pass the message 'clone and receive a copy of the object. Also you can pass the message 'type? to test if the object is a given type.
Here is how you might define a class called dog (obviously the final implementation would wrap this in macros).

(define make-dog
  (lambda ()
    (let ((obj (make-object)))
      (set-member! obj 'bark (lambda () (display "bark!") (newline)))
      (set-member! obj 'nap (lambda () (display "zzzzzz") (newline)))
      (let ((old-type (get-member obj 'type?)))
        (set-member! obj 'type? (lambda (val) (or (eq? val 'dog) (old-type val)))))
      obj
      )))

Also you can define a class that inherits from dog, called big-dog as follows:

(define make-big-dog
  (lambda ()
    (let ((obj (make-dog)))
      (set-member! obj 'bark (lambda () (display "woof!") (newline)))
      (let ((old-type (get-member obj 'type?)))
        (set-member! obj 'type? (lambda (val) (or (eq? val 'big-dog) (old-type val)))))
      obj
      )))

If you call 'bark on dog and big-dog objects you will get different results. However since big-dog inherits 'nap from dog and doesn’t override it you will get the same results. Also you can see in the definition of the 'type? message how you can use the earlier implantation of a message in the implementation of a class that inherits and overrides the message.

The other system is much uglier, but supports multiple inheritance. Its basic objects are generated as follows:

(define make-iobject
  (lambda ()
    (let ((o-3
           (let
               ((dispatches (make-hash-table)) (i-self '()) (parents '()))
             (lambda (message . params)
               (cond ((eq? message 'set-dispatch)
                      (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params))))
                      (hash-table-put! dispatches (car params) (car (cdr params))))
                     ((eq? message 'has-dispatch?)
                      (let ((result #t)) (hash-table-get dispatches (car params) (lambda () (set! result #f))) result))
                     ((eq? message 'get-dispatch)
                      (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params)))))
                     ((eq? message 'create-dispatch)
                      (hash-table-put! dispatches (car params) (car (cdr params))))
                     ((eq? message 'remove-dispatch)
                      (hash-table-remove! dispatches (car params)))
                     ((eq? message 'clone)
                      (let ((rslt (make-iobject)))
                        (hash-table-for-each dispatches (lambda (key value) (rslt 'create-dispatch key value)))
                        (for-each (lambda (p) (rslt 'set-parent! (p 'clone))) parents)
                        rslt))
                     ((eq? message 'set-self)
                      (if (null? i-self) (set! i-self (make-weak-box (car params)))))
                     ((eq? message 'set-parent!)
                      (set! parents (cons (car params) parents)))
                     ((eq? message 'get-parents)
                      parents)
                     (else (fluid-let ((self (weak-box-value i-self)))
                             (letrec ((tryparents
                                       (lambda (message params parents)
                                         (if (null? parents)
                                             (throw (make-dispatch-exception (cons message params)))
                                             (try
                                               (apply (car parents) message params)
                                              catch dispatch-exception?
                                               (tryparents message params (cdr parents)))))))
                               (if self
                                   (try
                                     (apply (hash-table-get dispatches
                                                          message
                                                          (lambda ()
                                                            (throw (make-dispatch-exception (cons message params)))))
                                          params)
                                   catch dispatch-exception?
                                     (tryparents message params parents)
                                   ))))))
               )
             )))
      (o-3 'set-self o-3)
      (set-member! o-3 'type? (lambda (val) (eq? val 'object)))
      o-3)))

This implementation keeps a lists of the parents, so that it can attempt to dispatch unhandled messages to them.

The implantation of two classes, auto and plane, are as follows:

(define make-auto
  (lambda ()
    (let ((obj (make-iobject)) (rslt (make-iobject)))
      (rslt 'set-parent! obj)
      (set-member! rslt 'type? (lambda (val) (or (eq? val 'auto) (obj 'type? val))))
      (set-member! rslt 'drive (lambda () (self 'name) (display ": ") (display "vroom") (newline)))
      (set-member! rslt 'name (lambda () (display "automobile")))
      rslt
      )))

(define make-plane
  (lambda ()
    (let ((obj (make-iobject)) (rslt (make-iobject)))
      (rslt 'set-parent! obj)
      (set-member! rslt 'type? (lambda (val) (or (eq? val 'plane) (obj 'type? val))))
      (set-member! rslt 'fly (lambda () (self 'name) (display ": ") (display "zoom") (newline)))
      (set-member! rslt 'name (lambda () (display "airplane")))
      rslt
      )))

Once again the implementation of the 'type? message demonstrates how to call the older versions of a method.

We could implement a class car-plane that inherits from both of them as follows:

(define make-car-plane
  (lambda ()
    (let ((auto (make-auto)) (plane (make-plane)) (rslt (make-iobject)))
      (rslt 'set-parent! auto)
      (rslt 'set-parent! plane)
      (set-member! rslt 'type? (lambda (val) (or (eq? val 'car-plane) (auto 'type? val) (plane 'type? val))))
      (set-member! rslt 'name (lambda () (display "car-plane")))
      (let ((slf (make-weak-box rslt)))
        (if (has-member? auto 'name)
            (set-member! auto 'name (lambda x (apply (weak-box-value slf) 'name x))))
        (if (has-member? plane 'name)
            (set-member! plane 'name (lambda x (apply (weak-box-value slf) 'name x))))
        )
      rslt
      )))

Note that the if statements after the implementation of the ’name message are there to ensure that the parent classes invoke the overridden methods, not their original methods. If we did not have these statements then if ’drive was passed to a car plane object then it would print "automobile: vroom" instead of "car-plane: vroom" which is what we wanted.

Next time: static data and methods, and possibly some sort of conclusion as to which of these methods is a better way of doing inheritance.
Also this code topic in comp.lang.scheme is a bit relevant.