author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Wed, 16 Jan 2019 17:15:58 +0000 | |
changeset 438 | 1fe179d53161 |
parent 328 | 9c75f3b739d5 |
permissions | -rw-r--r-- |
327
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1 |
#lang racket/base |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
2 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
3 |
;; Implementation of Piumarta/Warth-style "Open, Reusable Object |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
4 |
;; Models" for Racket. |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
5 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
6 |
;; Objects: have private state of their own, and a vtable for giving |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
7 |
;; them behaviour. |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
8 |
;; |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
9 |
;; VTables: map method names to closures. Include simple parent-style |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
10 |
;; delegation. Are also objects. |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
11 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
12 |
(provide (all-defined-out)) ;; TODO |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
13 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
14 |
(define-values (prop:vtable vtable? vtable-getter) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
15 |
(make-struct-type-property 'vtable)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
16 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
17 |
(struct simple-vtable (methods parent) #:prefab) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
18 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
19 |
(define (vtable-of o) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
20 |
(cond |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
21 |
((vtable? o) ((vtable-getter o) o)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
22 |
((simple-vtable? o) vtable-vt) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
23 |
(else (error 'vtable-of "Cannot compute vtable for ~v" o)))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
24 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
25 |
(define (bind o name) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
26 |
(let ((vt (vtable-of o))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
27 |
(if (and (eq? name 'lookup) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
28 |
(eq? vt vtable-vt)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
29 |
(vtable-lookup vt name) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
30 |
(send vt 'lookup name)))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
31 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
32 |
(define (send o name . args) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
33 |
(let ((closure (bind o name))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
34 |
(apply closure o args))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
35 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
36 |
(define (vtable-lookup self name) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
37 |
(hash-ref (simple-vtable-methods self) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
38 |
name |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
39 |
(lambda () |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
40 |
(let ((parent (simple-vtable-parent self))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
41 |
(if parent |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
42 |
(send parent 'lookup name) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
43 |
(error 'vtable-lookup "No method called ~v" name)))))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
44 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
45 |
(define (vtable-add-method! self name method) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
46 |
(hash-set! (simple-vtable-methods self) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
47 |
name |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
48 |
method)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
49 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
50 |
(define vtable-vt (simple-vtable (make-hash) #f)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
51 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
52 |
(vtable-add-method! vtable-vt 'lookup vtable-lookup) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
53 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
54 |
(vtable-add-method! vtable-vt 'add-method! |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
55 |
(lambda (self name method) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
56 |
(hash-set! (simple-vtable-methods self) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
57 |
name |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
58 |
method))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
59 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
60 |
(send vtable-vt 'add-method! 'delegated |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
61 |
(lambda (self) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
62 |
(simple-vtable (make-hash) self))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
63 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
64 |
;;--------------------------------------------------------------------------- |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
65 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
66 |
(struct object (vtable fields) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
67 |
#:transparent |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
68 |
#:property prop:vtable (lambda (o) (object-vtable o))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
69 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
70 |
(define object-vt (send vtable-vt 'delegated)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
71 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
72 |
(send vtable-vt 'add-method! 'allocate |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
73 |
(lambda (self field-count) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
74 |
(object self (make-vector field-count (void))))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
75 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
76 |
(send object-vt 'add-method! 'get-field |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
77 |
(lambda (self field-index) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
78 |
(vector-ref (object-fields self) field-index))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
79 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
80 |
(send object-vt 'add-method! 'set-field! |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
81 |
(lambda (self field-index new-value) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
82 |
(vector-set! (object-fields self) field-index new-value))) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
83 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
84 |
(define o (send object-vt 'allocate 1)) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
85 |
(send o 'set-field! 0 'hello) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
86 |
(send o 'get-field 0) |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
87 |
o |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
88 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
89 |
;; Now object-vt and objects are *applications* of vtables, rather |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
90 |
;; than being in a cycle with them, so vtables do not inherit any |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
91 |
;; protocol of objects. This is getting closer to Smalltalk-like |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
92 |
;; subclassing-of-nil. |
328
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
93 |
|
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
94 |
;; However, we have gone too far: in the step from cola.rkt to |
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
95 |
;; cola2.rkt, I removed simple-vtable-vtable. This means that all |
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
96 |
;; simple-vtable instances have the same behaviour, which is why |
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
97 |
;; adding 'allocate to vtable-vt seems to work. Better would be to |
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
98 |
;; have some object-specific vt that we could add 'allocate to, but |
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
99 |
;; without simple-vtable-vtable there is no way to do that without |
9c75f3b739d5
Add missing 'allocate metaprotocol.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
327
diff
changeset
|
100 |
;; constructing a new kind of vtable. |