Why Scheme Shouldn’t Have An Official Object System

Obviously object systems can be created in Scheme, even I created one, but objects are not part of the language specification itself. I don’t pretend to know the motivations behind the design of Scheme, but I think that fundamentally Scheme may lack objects because it is a minimalist language. Here however I will defend the benefits of not having an object system built into the language, whatever the designers’ real reasons are.

As you may know some Lisp languages, most notably Common Lisp, and some dialects of Scheme, such as Bigloo, do have a built in object system. Other distributions, such as PLT, come packaged with modules that implement an object system if you choose to include them. Individuals have also devised their own flavors of object systems for scheme, ranging from imitations of CLOS, to prototype based systems, to slot based systems, to message oriented systems, and many which are some mixture of these features and more. Clearly then objects seem to be desired by programmers even in Lisp family languages.

The best, and most basic, use of objects is to abstract a set of related data and operations upon this data from the rest of the program. Obviously anything an object can do could be done with a properly structured list and some operations that act on it, but the beauty of using objects is that all these functions can be conveniently tied together allowing the programmer to easily alter implementation of the object without breaking other parts of the program unintentionally. Ideally objects can result in smaller and more elegant programs, in terms of the code written, although they may have more run-time overhead. Admittedly there are drawbacks to the object oriented style of programming, which have been already covered extensively by others wiser than me. Although I recognize that the over-use of objects can be a problem, it also seems clear that objects, used in a more limited fashion, can be an excellent programming tool. Why else would developers create object systems over and over again for Scheme?

So if objects can be useful why leave them out of Scheme? There are obviously drawbacks to their omission, as object systems invented independently of each other function and look different, which can make reading code that employs an object system difficult. One advantage of not having a standard system is that it leaves out a lot of clutter from the language in its bare specification form. When object system are built into the language you end up with not only a new keyword for defining a class, but you end up with special ways of defining member functions (how else can you access the “this” reference), special functions to describe inheritance relationships, calling member functions of an object, determining the type of an object, getting and setting member variables, ect. Depending on who designs the built-in system there may be more or less added syntax, but on some level you have added a new “black box” to the language. A black box is a construct that can’t be described in terms of other constructs available in the language. For example if you consider if to be a black box construct then cond is not since it can be described in terms of the if statements. Part of the elegance of Scheme is that it only has a few of these black box constructs, and adding an object system could possibly double the number of “black boxes” in the language.

More important however is that object oriented programming is still young. Admittedly we have had object oriented systems for many years, but even so object oriented languages are still finding new ways to approach objects, both syntactically and conceptually. Compare this to functional programming, which has only a few styles of implementation, and a mathematical foundation to boot. The problem with adopting “officially” one object system into the language is that it discourages experimentation with new ideas. Consider for example CLOS in Common Lisp. Because it is already incorporated in the language, and an official standard, few Common Lisp programmers would consider using a different object system. Despite this CLOS is primitive in several ways, for example it handles name clashing in multiple inheritance poorly*, and unfortunately programmers who have become accustomed to one style of object oriented programming are unlikely to see the benefits of other styles or to dismiss them merely “syntactic sugar”, much the way programmers who are accustomed to a procedural style often react to functional programming at first.

So while Scheme’s lack of an official standard for handling objects may seem to lead to some confusion and inefficiency these shortcomings are offset by the cleanness of the language and the acceptance of the community of different approaches to the problem. Perhaps when object oriented programming matures, and it becomes clear that one way of handling objects that is superior to any others should it be incorporated officially into Scheme, but until that day I feel it is best to let homebrew solutions be the norm.

* according to a conversation concerning inheritance I had with a CLOS user, when a class inherits from multiple classes that contain variables of the same name the new class must explicitly override get and set methods for that variable so that they address a new variable internally. I don’t know how conflicts between method names are resolved. I claimed that this put an unnecessary burden to the programmer, i.e. to ensure that every time any parent class is revised no new variables have been added which might conflict with any of the other inherited classes. To defend CLOS they added that this system could handle both the case when only one copy of a parent class found more than once in the inheritance tree is needed and the case when multiple copies of such a parent class is needed. When I in turn pointed out that such problems had been solved in C++ with the distinction between virtual and non-virtual inheritance with no need to worry about conflicting variable names they seemed insulted, which I think is a case of programmers used to one system seeing any improvements as mere syntactic sugar.

Multiple Inheritance, Finally

Hopefully this will be my last OOP post for a while, minus any updates for fixes of course. Also I have applied for a Sourceforge project to host the various modules that I have been developing. That way you can play around with the code yourself without having to copy and paste it around. Judging by the last time I applied for a Sourceforge project I should hear back from them sometime next week.

Anyways, I had to modify the make-iobject function extensively to make virtual and non virtual inheritance work. As an added bonus the following messages were added: 'Rget-dispatch and 'Rhas-dispatch? which return and test for the existence of a dispatch not only on the current object but also all through its inheritance tree as well.

A class can be defined as follows:

(define-iclass class-name ([nv] parent-classes)+
  [static statics-list]
  members
  [nv] name value
  …
  )

As with the single inheritance model this definition creates a make-class-name function that passes any parameters it receives to the 'init message as well as a class-name? function that tests if an object is of that type. Putting nv before a class name indicates that that class (and all its parent classes) should be inherited non-virtually with respect to the current class. Basically if a class inherits from multiple classes virtually only one copy of a class in the inheritance tree will be made, even if several classes inherit from it. On the other hand in non-virtual inheritance there will be one copy created every time the class in created. Likewise unless a member is marked as nv it will override versions of that function created in parent classes, so that if that function is invoked by a parent class the new function will be called instead. If a function is marked as nv then if the parent class invokes that function the old version will be called. Finally when declaring a class that inherits from classes A, B, … you can refer to the parent objects directly in member function as A, B, … Similarly when declaring a member function you can call the previous version of that function with A:function-name, B:function-name, ect, these are references to the function, not the parent object, so there is no need to pass them messages, and even if the old version of the function is overridden these references will still invoke the old operations. One last note, classes must inherit from at least one other class, so that all classes inherit from iobject directly or indirectly.

An example of virtual inheritance:

(define-iclass named iobject
  members
  internal-name "default"
  set-name (lambda (newval) (set-member! self 'internal-name newval))
  show-name (lambda () (display (get-member self 'internal-name)) (newline))
  )

(define-iclass bob-named named
  members
  bobname (lambda () (self 'show-name) (self 'set-name "bob") (self 'show-name))
  )

(define-iclass jim-named named
  members
  jimname (lambda () (self 'show-name) (self 'set-name "jim") (self 'show-name))
  )

(define-iclass jim-bob jim-named bob-named
  )

In this case a jim-bob object will flip between the name "jim" and the name "bob" when the 'jimname and 'bobname messages are passed. If jim-bob had inherited from these classes using nv or the bob-named and jim-named classes had inherited from named using nv they would each have their own copy of the name, and thus would not flip back and forth. Try it and see.

An example of virtual members:

(define-iclass auto iobject
  members
  name (lambda () (display "automobile"))
  drive (lambda () (self 'name) (display ": ") (display "vroom") (newline))
  )

(define-iclass plane iobject
  members
  name (lambda () (display "airplane"))
  fly (lambda () (self 'name) (display ": ") (display "zoom") (newline))
  )

(define-iclass car-plane auto plane
  members
  name (lambda () (display "car-plane"))
  )

In this example if a car-plane is instructed to fly or drive it will print out "car-plane: " first. If the name function was declared as nv it would still print out "auto: " and "plane: " first. Try it and see.

Now for the body of the code:
iobject and its helpers are defined as follows:

(define subclass #f)

(define opt-param
  (lambda (number lst alt)
    (if (>= (length lst) number)
        (list-ref lst (- number 1))
        alt)))

(define make-iobject
  (lambda opts
    (let ((o-3
           (let
               ((dispatches (make-hash-table))
                (i-self '())
                (parents '())
                (vparents '())
                (vparenthash (opt-param 1 opts (make-hash-table)))
                (i-subclass (opt-param 2 opts #f)))
             (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 'Rhas-dispatch?)
                      (if (let ((result #t)) (hash-table-get dispatches (car params) (lambda () (set! result #f))) result)
                          #t
                          (letrec (
                                   (search-parents
                                    (lambda (disp parents)
                                      (if (null? parents)
                                          #f
                                          (if ((car parents) 'Rhas-dispatch? disp)
                                              #t
                                              (search-parents disp (cdr parents))))))
                                   (search-vparents
                                    (lambda (disp vparents)
                                      (if (null? vparents)
                                          #f
                                          (if ((hash-table-get vparenthash (car vparents)
                                                            (lambda () (throw (make-dispatch-exception params))))
                                               'Rhas-dispatch? disp)
                                              #t
                                              (search-vparents disp (cdr vparents))))))
                                   )
                            (if (search-parents (car params) parents)
                                #t
                                (search-vparents (car params) vparents)))))
                     ((eq? message 'Rget-dispatch)
                      (try
                        (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params))))
                       catch dispatch-exception?
                        (letrec (
                                 (get-parent-dispatch
                                  (lambda (disp parents)
                                    (if (null? parents)
                                        (throw (make-dispatch-exception disp))
                                        (try
                                          ((car parents) 'Rget-dispatch disp)
                                         catch dispatch-exception?
                                          (get-parent-dispatch disp (cdr parents))))))
                                 (get-vparent-dispatch
                                  (lambda (disp vparents)
                                    (if (null? vparents)
                                        (throw (make-dispatch-exception disp))
                                        (try
                                          ((hash-table-get vparenthash (car vparents)
                                                            (lambda () (throw (make-dispatch-exception params))))
                                               'Rget-dispatch disp)
                                         catch dispatch-exception?
                                          (get-vparent-dispatch disp (cdr vparents))))))
                                 )
                          (try
                           (get-parent-dispatch (car params) parents)
                          catch dispatch-exception?
                           (get-vparent-dispatch (car params) vparents))
                          )))
                     ((eq? message 'clone)
                      (let ((vtble (opt-param 1 params (make-hash-table))) (i-subclass (opt-param 2 params #f)))
                        (let ((rslt (make-iobject vtble i-subclass)))
                          (unless i-subclass (set! i-subclass (make-weak-box rslt)))
                          (hash-table-for-each dispatches (lambda (key value) (rslt 'create-dispatch key value)))
                          (for-each (lambda (p) (rslt 'set-parent! (lambda (t s)
                                                                     (p 'clone (make-hash-table) i-subclass))))
                                    parents)
                          (for-each (lambda (p) (rslt 'set-vparent! p
                                                      (lambda (t s)
                                                        ((hash-table-get vparenthash p) 'clone t i-subclass))))
                                    vparents)
                          rslt)))
                     ((eq? message 'override)
                      (for-each (lambda (par)
                                  (if (has-member? par (car params))
                                      (set-member! par (car params) (lambda x (apply subclass (car params) x))))
                                  (par 'override (car params))) parents)
                      (for-each (lambda (par)
                                  (let ((cpar (hash-table-get vparenthash par)))
                                    (if (has-member? cpar (car params))
                                        (set-member! cpar (car params)
                                                     (lambda x (apply subclass (car params) x))))
                                    (cpar 'override (car params)))) vparents))
                     ((eq? message 'set-self)
                      (if (null? i-self) (set! i-self (make-weak-box (car params)))))
                     ((eq? message 'set-parent!)
                      (let ((pval ((car params) (make-hash-table) (or i-subclass i-self))))
                        (set! parents (cons pval parents))
                        pval))
                     ((eq? message 'set-vparent!)
                      (set! vparents (cons (car params) vparents))
                      (if (let ((result #f)) (hash-table-get vparenthash (car params) (lambda () (set! result #t))) result)
                          (let ((rval ((car (cdr params)) vparenthash (or i-subclass i-self))))
                            (hash-table-put! vparenthash (car params) rval)
                            rval)
                          (hash-table-get vparenthash
                                          (car params)
                                          (lambda () (throw (make-exception "inconsistant v inheritance")))))
                      )
                     (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 (if i-subclass (weak-box-value i-subclass) self)))
                                                (apply (car parents) message params))
                                              catch dispatch-exception?
                                               (tryparents message params (cdr parents))))))
                                      (tryvparents
                                       (lambda (message params vparents)
                                         (if (null? vparents)
                                             (throw (make-dispatch-exception (cons message params)))
                                             (try
                                              (fluid-let ((subclass (if i-subclass (weak-box-value i-subclass) self)))
                                                (apply (hash-table-get vparenthash (car vparents)) message params))
                                              catch dispatch-exception?
                                                (tryvparents message params (cdr vparents))))))
                                      )
                               (if self
                                   (try
                                     (apply (hash-table-get dispatches
                                                          message
                                                          (lambda ()
                                                            (throw (make-dispatch-exception (cons message params)))))
                                          params)
                                   catch dispatch-exception?
                                     (try
                                       (tryparents message params parents)
                                     catch dispatch-exception?
                                       (tryvparents message params vparents))
                                   ))))))
               )
             )))
      (o-3 'set-self o-3)
      (set-member! o-3 'type? (lambda (val) (eq? val 'iobject)))
      o-3)))

(define create-iobject make-iobject)
(define iobject? (lambda (x) (x 'type? 'iobject)))

The define-iclass macro is as follows:

(define-syntax define-iclass
    (lambda (x)
      (letrec (
               (get-parent-names
                (lambda (x)
                  (cond ((null? x) '())
                        ((eq? (car x) 'static) '())
                        ((eq? (car x) 'members) '())
                        ((eq? (car x) 'nv) (get-parent-names (cdr x)))
                        (else (cons (car x) (get-parent-names (cdr x)))))
                  ))
               (make-parent-lets
                (lambda (gen x)
                  (cond ((null? x) '())
                        ((eq? (car x) 'static) '())
                        ((eq? (car x) 'members) '())
                        ((eq? (car x) 'nv) (cons `(,(car (cdr x)) (,gen 'set-parent!
                                                                    ,(string->symbol
                                                                      (string-append "create-"
                                                                                     (symbol->string (car (cdr x)))))))
                                                 (make-parent-lets gen (cdr (cdr x)))))
                        (else (cons `(,(car x) (,gen 'set-vparent! (quote ,(car x))
                                                                    ,(string->symbol
                                                                      (string-append "create-"
                                                                                     (symbol->string (car x))))))
                                    (make-parent-lets gen (cdr x)))))
                  ))
               (get-statics
                (lambda (x)
                  (cond ((null? x) '())
                        ((eq? (car x) 'static) (car (cdr x)))
                        ((eq? (car x) 'members) '())
                        (else (get-statics (cdr x))))
                  ))
               (after-members
                (lambda (x)
                  (cond ((null? x) '())
                        ((eq? (car x) 'members) (cdr x))
                        (else (after-members (cdr x))))
                  ))
               (names-to-lets
                (lambda (names disp)
                  (if (null? names)
                      '()
                      (cons `(,(string->symbol (string-append
                                                (symbol->string (car names)) ":"
                                                (symbol->string disp)))
                               (if (,(car names) 'Rhas-dispatch? (quote ,disp))
                                   (,(car names) 'Rget-dispatch (quote ,disp))
                                   (lambda x (throw (make-dispatch-exception (quote ,disp))))))
                            (names-to-lets (cdr names) disp)))
                  ))
               (make-members
                (lambda (lst names gen)
                  (if (null? lst)
                      '()
                      (if (eq? (car lst) 'nv)
                          (cons `(let ,(names-to-lets names (car (cdr lst)))
                                   (set-member! ,gen (quote ,(car (cdr lst))) ,(car (cdr (cdr lst)))))
                                (make-members (cdr (cdr (cdr lst))) names gen))
                          (cons `(let ,(names-to-lets names (car lst))
                                   (set-member! ,gen (quote ,(car lst)) ,(car (cdr lst)))
                                   (,gen 'override (quote ,(car lst))))
                                (make-members (cdr (cdr lst)) names gen))
                          ))
                  ))
               (make-body
                (lambda (lst name pnames gen)
                  (cons `(let ,(map (lambda (x) `(,(string->symbol (string-append (symbol->string x) ":type?")) 
                                                   (get-member ,x 'type?))) pnames)
                             (set-member! ,gen 'type?
                                          (lambda (val)
                                            (or (eq? val (quote ,name))
                                                ,@(map (lambda (x)
                                                         `(,(string->symbol (string-append (symbol->string x) ":type?"))
                                                            val))
                                                       pnames)))))
                        (make-members (after-members lst) pnames gen))
                  ))
               (main-transformer
                (lambda (x)
                  (let ((name (car x)) (pnames (get-parent-names (cdr x)))
                        (gen (gensym)) (statics (get-statics x))
                        (vtble (gensym)) (gen2 (gensym)) (gen3 (gensym)))
                    `(begin
                       (define ,(string->symbol (string-append "create-" (symbol->string name)))
                         (letrec ,statics
                           (lambda ,vtble
                             (let ((,gen (apply make-iobject ,vtble)))
                               (let* ,(make-parent-lets gen (cdr x))
                                 ,@(make-body x name pnames gen)
                                 ,gen)))))
                       (define ,(string->symbol (string-append "make-" (symbol->string name)))
                         (let ((,gen2 (,(string->symbol (string-append "create-" (symbol->string name))))))
                           (lambda x
                             (let ((,gen3 (,gen2 'clone)))
                               (if (,gen3 'Rhas-dispatch? 'init)
                                   (apply ,gen3 'init x))
                               ,gen3))))
                       (define ,(string->symbol (string-append (symbol->string name) "?"))
                         (lambda (x) (x 'type? (quote ,name)))
                         )
                       )
                    )))
               )
        (datum->syntax-object x (main-transformer (cdr (syntax-object->datum x)))))))

Whew, finished at last. Next time: who knows! (probably more on strong typing in Scheme)

Single Inheritance, all Macro-ed Up

As of the moment I have only polished the single inheritance (simpler) system into a final (-ish) state. I am still working on the multiple inheritance model, specifically I am adding virtual inheritance, which raises a great number of issues. Also I think these OOP posts are getting old, I would much rather play with new ideas, so after I finish the multiple inheritance model don’t expect much more on this subject for a while. Anyways …

A class is defined as follows:

(define-class classname basename
  [static statics-list]
  member value
  member value
  ...)

Our example with the dogs (with a new little-dog class added) becomes:

(define-class dog object
  bark (lambda () (display "bark!") (newline))
  nap (lambda () (display "zzzzzz") (newline))
  )

(define-class big-dog dog
  bark (lambda () (display "woof!") (newline))
  )

(define-class little-dog dog
  static ((classname "little-dog-class"))
  bark (lambda () (display "yip yip") (newline) (dog:bark))
  name "fido"
  get-name (lambda () (display (get-member self 'name)))
  name-change (lambda (newname) (set-member! self 'name newname))
  get-class-name (lambda () classname)
  init (lambda (x) (display "I am a little dog: ") (display x) (self 'name-change x) (newline))
  )
  
(define d1 (make-dog))
(define d2 (make-big-dog))
(define d3 (make-little-dog "mimi"))

(dog? d3)

Also predicates for each type are defined whenever a new class is created.

Finally if a class has an 'init member that member will be called whenever the object is created, and passed any parameters that are given to the make- function.

The implementation of this macro is as follows:

(define-syntax define-class
    (lambda (x)
      (letrec (
               (get-statics
                (lambda (x)
                  (if (and (> (length x) 2) (eq? (list-ref x 2) 'static))
                      (list-ref x 3)
                      '())))
               (after-statics
                (lambda (x)
                  (if (and (> (length x) 2) (eq? (list-ref x 2) 'static))
                      (cdr (cdr (cdr (cdr x))))
                      (cdr (cdr x)))))
               (make-members
                (lambda (lst base gen)
                  (if (null? lst)
                      '()
                      (cons `(let ((,(string->symbol (string-append (symbol->string base) ":" (symbol->string (car lst))))
                                     (if (has-member? ,gen (quote ,(car lst)))
                                                  (get-member ,gen (quote ,(car lst)))
                                                  (lambda x (throw (make-dispatch-exception (cons (quote ,(car lst)) x)))))))
                               (set-member! ,gen (quote ,(car lst)) ,(car (cdr lst))))
                            (make-members (cdr (cdr lst)) base gen)))))
               (make-body
                (lambda (lst name base gen)
                  (cons `(let ((old-type (get-member ,gen 'type?)))
                           (set-member! ,gen 'type? (lambda (val) (or (eq? val (quote ,name)) (old-type val)))))
                        (make-members (after-statics lst) base gen))))
               (main-transformer
                (lambda (x)
                  (let ((name (car x)) (base (car (cdr x))) (gen (gensym)) (statics (get-statics x)))
                    `(begin
                       (define ,(string->symbol (string-append "make-" (symbol->string name)))
                         (letrec ,statics
                           (let ((,name
                                  (let ((,gen (,(string->symbol (string-append "make-" (symbol->string base))))))
                                    ,@(make-body x name base gen)
                                    ,gen
                                    )))
                             (lambda x (let ((rs (,name 'clone)))
                                         (if (has-member? rs 'init) (apply rs 'init x))
                               rs))
                             )))
                       (define ,(string->symbol (string-append (symbol->string name) "?"))
                         (lambda (x) (x 'type? (quote ,name)))
                         )
                       )
                    )))
               )
        (datum->syntax-object x (main-transformer (cdr (syntax-object->datum x)))))))

Well, thats all for the moment, Peter out.

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.