A Scheme implementation of the object model as described in their paper:
http://piumarta.com/software/cola/objmodel2.pdf
An R6RS version with more examples is located here:
https://github.com/kstephens/open-object-lab
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | #lang r5rs ;;; Piumarta and Warth's Open Objects in Scheme. (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:with-parent self parent) (let ((child (vtable:alloc self 2))) (object:vt= child (and self (vtable self))) (vtable:parent= child parent) (vtable:methods= child '()) child)) (define (vtable:delegated self) (vtable:with-parent self #f)) (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> 'delegated vtable:delegated) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Additional vtables for Scheme types: (send 'add-method <vtable> 'with-parent vtable:with-parent) (define <number> (send 'with-parent <vtable> <object>)) (define <real> (send 'with-parent <vtable> <number>)) (define <integer> (send 'with-parent <vtable> <real>)) (define <symbol> (send 'with-parent <vtable> <object>)) ;; Extend vtable determination into Scheme types: (set! vtable (lambda (self) (cond ((integer? self) <integer>) ((real? self) <real>) ((number? self) <number>) ((symbol? self) <symbol>) ((object? self) (object:vt self)) (else <object>)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Example: (send 'add-method <object> 'print (lambda (self) (write `(object ,self)) (newline))) (send 'add-method <vtable> 'print (lambda (self) (write `(vtable ...)) (newline))) (send 'add-method <number> 'print (lambda (self) (write `(number ,self)) (newline))) (send 'add-method <real> 'print (lambda (self) (write `(real ,self)) (newline))) (send 'add-method <integer> 'print (lambda (self) (write `(integer ,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 1/23) (send 'print '(a cons)) |