On Scheme

Thoughts on Scheme and teaching Scheme

Cloning Problems, and a Fix

Posted by Peter on March 21, 2006

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.

Advertisements

3 Responses to “Cloning Problems, and a Fix”

  1. Alexis said

    Hi!. Thanks for the blog. I’ve been digging around for info, but there is so much out there. Google lead me here – good for you i suppose! Keep up the good work. I will be coming back in a couple of days to see if there is any more info.

  2. Alvaro said

    What’s up?. Thanks a bunch for the blog. I’ve been digging around for info, but i think i’m getting lost!. Yahoo lead me here – good for you i suppose! Keep up the great information. I will be coming back over here in a few days to see if there is updated posts.

  3. Considerably, the article is actually the greatest on this worthy topic. I harmonize with your conclusions and will thirstily look forward to your future updates. Saying thanks will not just be adequate, for the tremendous lucidity in your writing. I will directly grab your rss feed to stay abreast of any updates. De lightful work and much success in your business endeavors!

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: