;;; Piumarta and Warth's Open Objects in Scheme.
;;; A Scheme implementation of the object model as described in their paper:
;;; http://piumarta.com/software/cola/objmodel2.pdf
(define object-tag '(OBJECT))
(define <vtable> #f)
(define <object> #f)
(define (object-vt self)
(vector-ref self 1))
(define (object-vt= self value)
(vector-set! self 1 value))
(define (vtable-alloc self size)
(let ((obj (make-vector (+ size 2))))
(vector-set! obj 0 object-tag)
(object-vt= obj self)
obj))
(define (object? self)
(and (vector? self)
(>= (vector-length self) 2)
(eq? (vector-ref self 0) object-tag)))
(define (vtable self)
(cond
((object? self) (object-vt self))
(else <object>)))
(define (vtable-parent self)
(vector-ref self 2))
(define (vtable-parent= self value)
(vector-set! self 2 value))
(define (vtable-methods self)
(vector-ref self 3))
(define (vtable-methods= self value)
(vector-set! self 3 value))
(define (vtable-delegated self)
(let ((child (vtable-alloc self 2)))
(object-vt= child (and self (vtable self)))
(vtable-parent= child #f)
(vtable-methods= child '())
child))
(define (vtable-add-method self key value)
(let* ( (methods (vtable-methods self))
(slot (assq key methods)))
(if slot
(set-cdr! slot value)
(vtable-methods= self (cons (cons key value) methods)))))
(define (vtable-lookup self key)
(let* ((slot (assq key (vtable-methods self))))
(if slot (cdr slot)
(if (vtable-parent self)
(send 'lookup (vtable-parent self) key)))))
(define (bind op rcvr)
(let ((vt (vtable rcvr)))
(if (and (eq? op 'lookup) (eq? vt <vtable>))
(vtable-lookup vt op)
(send 'lookup vt op))))
(define (send op self . args)
(apply (bind op self) self args))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bootstrap vtables:
(set! <vtable> (vtable-delegated #f))
(object-vt= <vtable> <vtable>)
(set! <object> (vtable-delegated #f))
(object-vt= <object> <vtable>)
(vtable-parent= <vtable> <object>)
(vtable-add-method <vtable> 'lookup vtable-lookup)
(vtable-add-method <vtable> 'add-method vtable-add-method)
(send 'add-method <vtable> 'alloc vtable-alloc)
(send 'add-method <vtable> 'parent= vtable-parent=)
(send 'add-method <vtable> 'delegated vtable-delegated)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Additional vtables for Scheme types:
(define <number> (send 'delegated <object>))
(define <real> (send 'delegated <number>))
(define <integer> (send 'delegated <real>))
(define <symbol> (send 'delegated <object>))
;; Extend vtable determination into Scheme types;
(define (vtable self)
(cond
((integer? self) <integer>)
((real? self) <real>)
((symbol? self) <symbol>)
((object? self) (object-vt self))
(else <object>)))
(send 'add-method <object> 'print
(lambda (self) (write `(object ,self)) (newline)))
(send 'add-method <vtable> 'print
(lambda (self) (write `(vtable ...)) (newline)))
(send 'add-method <integer> 'print
(lambda (self) (write `(integer ,self)) (newline)))
(send 'add-method <real> 'print
(lambda (self) (write `(real ,self)) (newline)))
(send 'add-method <symbol> 'print
(lambda (self) (write `(symbol ,self)) (newline)))
(send 'print <vtable>)
(send 'print <object>)
(send 'print 'a-symbol)
(send 'print 123)
(send 'print 1234.56)
(send 'print '(a cons))
De : fonc-***@vpri.org [mailto:fonc-***@vpri.org] De la part de Julian Leviston
Envoyé : mercredi 29 octobre 2014 09:12
À : Fundamentals of New Computing
Objet : Re: [fonc] Piumarta and Warth’s Open Objects in Scheme
Link broken.
Julian
http://www.getcontented.com.au/ - You Need GetContented - Make Websites, Not War!
On 29 Oct 2014, at 5:55 pm, Kurt Stephens <***@kurtstephens.com> wrote:
Something I threw together. :)
http://devdriven.com/2014/10/piumarta-and-warths-open-objects-in-scheme/
-- KAS