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

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
#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>))))
 
(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))

Leave a Reply

Your email address will not be published. Required fields are marked *


*