On Scheme

Thoughts on Scheme and teaching Scheme

Archive for March 23rd, 2006

Multiple Inheritance, Finally

Posted by Peter on March 23, 2006

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)

Advertisements

Posted in Exploring Scheme, OOP | Leave a Comment »