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.