[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: r^2 vs. r^3
Here is a small objected oriented system which I wrote one day
to see how small I could make it. It does single inheritence.
Objects and classes are procedures. New instances are
created by send a class object the message NEW. SUPER
is a smalltalk style pseudo instance which calls the method
dispatcher for the class one higher in the heirarchy. The
DEFINE-METHOD macro walks the code for the message and replaces
varaible references and sets with VECTOR-REFs and VECTOR-SET!s
for a vector of instance variables. This code was written
using a library of utility functions I use. I have attempted
to remove all those references.
Sorry for the lack of comments, this is almost a pedagogical example.
(define *metamethod-offset* 0)
(define *method-offset* 1)
(define *parent-offset* 2)
(define *ivs-offset* 3)
(macro define-class
(lambda (dummy class parent ivs cvs)
(set! ivs (combine-var-lists
(if parent (property parent 'ivs) nil) ivs))
(set! cvs (combine-var-lists
(if parent (property parent 'cvs) nil)
(append '(metamethods methods parent ivs) cvs)))
`(set! ,class
(begin
(set-property! ',class 'ivs ',ivs)
(set-property! ',class 'cvs ',cvs)
(make-class-object ,parent ',ivs ',cvs)))
(define (combine-var-lists l1 l2)
(letrec
((combine
(lambda (l1 l2)
(if (null? l2)
(reverse l1)
(if (memq (car l2) l1)
(combine l1 (cdr l2))
(combine (cons (car l2) l1) (cdr l2)))))))
(combine (reverse l1) l2)))
(macro define-metamethod
(lambd (dummy class spec . body)
(let ((message (car spec))
(arg-spec (cdr spec)))
`(add-metamethod-to-class-object ,class ',message
(lambda (self class %%method-object %%var-vector ,@arg-spec)
,@(walk-code-and-replace-variables
body (property class 'cvs))))))
(define (make-class-object parent ivs cvs)
(let ((cv-vector (make-vector (length cvs)))
(class-object nil))
(vector-set! cv-vector *metamethods-offset* (list 'metamethods))
(vector-set! cv-vector *methods-offset* (list 'methods))
(vector-set! cv-vector *parent-offset* parent)
(vector-set! cv-vector *ivs-offset* ivs)
(set! class-object
(lambda (message . args)
(cond ((eq? message 'cv-vector) cv-vector)
((eq? message 'class-object?) t)
(T (dispatch-metamethod
class-object class-object message args
cv-vector)))))))
(define (add-metamethod-to-class-object class-object message func)
(let* ((a-list (vector-ref (class-object 'cv-vector)
*metamethod-offset*))
(pair (assq message (cdr a-list))))
(if pair
(set-cdr! pair func)
(set-cdr! a-list (cons (cons message func) (cdr a-list))))))
(define (dispatch-metamethod class-object method-object message args
cv-vector)
(let* ((method-vector (if (null? method-object)
(cerror "No metamethod" message args)
(method-object 'cv-vector)))
(pair (assq message (cdr (vector-ref method-vector
*metamethod-offset*)))))
(if pair
(apply (cdr pair)
(cons class-object
(cons ()
(cons method-object
(cons cv-vector args)))))
(dispatch-metamethod class-object
(vector-ref method-vector *parent-offset*)
message args cv-vector))))
(define (walk-code-and-replace-variables expr vars)
(cond ((symbol? expr)
(if (memq expr vars)
`(vector-ref %%var-vector ,(nth-inv vars expr))
expr))
((atom? expr) expr)
((pair? expr)
(cond ((eq? (car expr) 'quote)
expr)
((eq? (car expr) 'set!)
(if (memq (cadr expr) vars)
`(vector-set! %%var-vector
,(nth-inv vars (cadr expr))
,(walk-code-and-replace-variables
(caddr expr) vars))
expr))
(T (cons
(walk-code-and-replace-variables (car expr) vars)
(walk-code-and-replace-variables (cdr expr) vars)))))))
(macro define-method
(lambda (dummy class spec . body)
(let ((message (car spec))
(arg-spec (cdr spec)))
`(add-method-to-class-object ,class ',message
(lambda (self class %%method-object %%var-vector ,@arg-spec)
,@(walk-code-and-replace-variables
body (property class 'ivs))))))
(define (add-method-to-class-object class-object message func)
(let* ((a-list (vector-ref (class-object 'cv-vector) 1))
(pair (assq message (cdr a-list))))
(if pair
(set-cdr! pair func)
(set-cdr! a-list (cons (cons message func) (cdr a-list))))))
(define (make-instance-object class-object)
(let ((iv-vector (make-vector
(length (vector-ref (class-object 'cv-vector)
*iv-offset*))))
(instance-object nil))
(set! instance-object
(lambda (message . args)
(cond ((eq? message 'iv-vector) iv-vector)
((eq? message 'class-object?) nil)
(T (dispatch-method class-object class-object
message args
instance-object iv-vector)))))
instance-object))
(define (dispatch-method class-object method-object message args
instance-object iv-vector)
(let* ((cv-vector (if (null? method-object)
(cerror "No method" message args)
(method-object 'cv-vector)))
(pair (assq message
(cdr (vector-ref cv-vector *methods-offset*)))))
(if pair
(apply (cdr pair)
(cons instance-object
(cons class-object
(cons method-object
(cons iv-vector args)))))
(dispatch-method class-object
(vector-ref cv-vector *parent-offset*)
message args
instance-object iv-vector))))
(macro super
(lambda (dummy message . args)
`(dispatch-super class %%method-object
,message (list ,@args)
self %%var-vector))
(define (dispatch-super class-object method-object message args
instance-object iv-vector)
(let ((parent (vector-ref (method-object 'cv-vector) *parent-offset*)))
(if (null? parent)
(cerror "No super-method or super-metamethod" message args)
(if (null? (instance-object 'class-object?))
(dispatch-method class-object parent message args
instance-object iv-vector)
(dispatch-metamethod instance-object parent message args
iv-vector)))))
; A little documentation
;
; (DEFINE-CLASS class-name parent instance-variables class-variables)
; (DEFINE-METHOD class-name (method-name . args) . body)
; (DEFINE-METAMETHOD class-name (method-name . args) . body)
;
; Here is a small example
;
; (DEFINE-CLASS NEW-CLASS () (NAME) (INSTANCE-COUNT))
;
; (DEFINE-METAMETHOD NEW-CLASS (NEW)
; (LET ((NEW-OBJECT (SUPER 'NEW)))
; (SET! INSTANCE-COUNT (1+ INSTANCE-COUNT))
; OBJECT))
;
; (DEFINE-METAMETHOD NEW-CLASS (GET-INSTANCE-COUNT)
; INSTANCE-COUNT)
;
; (DEFINE-METHOD NEW-CLASS (SET-NAME NEW-NAME)
; (SET! NAME NEW-NAME))
;
; (DEFINE-CLASS ANOTHER-NEW-CLASS (NEW-CLASS () ())
;
; (DEFINE-METHOD ANOTHER-NEW-CLASS (SET-NAME NEW-NAME)
; (SUPER 'SET-NAME NEW-NAME)
; (DISPLAY NEW-NAME)
; (NEWLINE))
Enjoy, comments welcome, flame to yourself.
-Charlie Dolan