On Scheme

Thoughts on Scheme and teaching Scheme

Inheritance and Copying

Posted by Peter on March 21, 2006

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.

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

 
%d bloggers like this: