author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Wed, 16 Jan 2019 17:15:58 +0000 | |
changeset 438 | 1fe179d53161 |
parent 327 | e64c8e1fd9d8 |
permissions | -rw-r--r-- |
319
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1 |
#lang racket/base |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
2 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
3 |
;; Implementation of Piumarta/Warth-style "Open, Reusable Object |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
4 |
;; Models" for Racket. |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
5 |
|
320
f07ee06a83f7
vau-cps, and tweaks
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
319
diff
changeset
|
6 |
;; Objects: have private state of their own, and a vtable for giving |
f07ee06a83f7
vau-cps, and tweaks
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
319
diff
changeset
|
7 |
;; them behaviour. |
f07ee06a83f7
vau-cps, and tweaks
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
319
diff
changeset
|
8 |
;; |
f07ee06a83f7
vau-cps, and tweaks
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
319
diff
changeset
|
9 |
;; VTables: map method names to closures. Include simple parent-style |
f07ee06a83f7
vau-cps, and tweaks
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
319
diff
changeset
|
10 |
;; delegation. Are also objects. |
f07ee06a83f7
vau-cps, and tweaks
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
319
diff
changeset
|
11 |
|
319
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
12 |
(provide (all-defined-out)) ;; TODO |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
13 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
14 |
(define-values (prop:vtable vtable? vtable-getter) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
15 |
(make-struct-type-property 'vtable)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
16 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
17 |
(struct simple-vtable (methods parent vtable) #:prefab) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
18 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
19 |
(define (vtable-of o) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
20 |
(cond |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
21 |
((vtable? o) ((vtable-getter o) o)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
22 |
((simple-vtable? o) (simple-vtable-vtable o)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
23 |
(else (error 'vtable-of "Cannot compute vtable for ~v" o)))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
24 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
25 |
(define (bind o name) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
26 |
(let ((vt (vtable-of o))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
27 |
(if (and (eq? name 'lookup) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
28 |
(eq? vt vtable-vt)) |
325
f808f71be4b4
Fix long-standing bug in cola.rkt.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
320
diff
changeset
|
29 |
(vtable-lookup vt name) |
319
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
30 |
(send vt 'lookup name)))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
31 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
32 |
(define (send o name . args) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
33 |
(let ((closure (bind o name))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
34 |
(apply closure o args))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
35 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
36 |
(define (vtable-lookup self name) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
37 |
(hash-ref (simple-vtable-methods self) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
38 |
name |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
39 |
(lambda () |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
40 |
(let ((parent (simple-vtable-parent self))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
41 |
(if parent |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
42 |
(send parent 'lookup name) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
43 |
(error 'vtable-lookup "No method called ~v" name)))))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
44 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
45 |
(define (vtable-add-method! self name method) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
46 |
(hash-set! (simple-vtable-methods self) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
47 |
name |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
48 |
method)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
49 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
50 |
(define object-vt (let* ((ovt-ph (make-placeholder #f)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
51 |
(vvt-ph (make-placeholder #f)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
52 |
(ovt (simple-vtable (make-hash) #f vvt-ph)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
53 |
(vvt (simple-vtable (make-hash) ovt-ph vvt-ph))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
54 |
(placeholder-set! ovt-ph ovt) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
55 |
(placeholder-set! vvt-ph vvt) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
56 |
(make-reader-graph ovt))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
57 |
(define vtable-vt (simple-vtable-vtable object-vt)) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
58 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
59 |
(vtable-add-method! vtable-vt 'lookup vtable-lookup) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
60 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
61 |
(vtable-add-method! vtable-vt 'add-method! |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
62 |
(lambda (self name method) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
63 |
(hash-set! (simple-vtable-methods self) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
64 |
name |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
65 |
method))) |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
66 |
|
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
67 |
(send vtable-vt 'add-method! 'delegated |
d07e7e900380
First sketch of a COLA-style object model in Racket
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
68 |
(lambda (self) |
326
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
69 |
(simple-vtable (make-hash) self (vtable-of self)))) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
70 |
|
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
71 |
;;--------------------------------------------------------------------------- |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
72 |
|
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
73 |
(struct object (vtable fields) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
74 |
#:transparent |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
75 |
#:property prop:vtable (lambda (o) (object-vtable o))) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
76 |
|
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
77 |
(send vtable-vt 'add-method! 'allocate |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
78 |
(lambda (self field-count) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
79 |
(object self (make-vector field-count (void))))) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
80 |
|
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
81 |
(send object-vt 'add-method! 'get-field |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
82 |
(lambda (self field-index) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
83 |
(vector-ref (object-fields self) field-index))) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
84 |
|
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
85 |
(send object-vt 'add-method! 'set-field! |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
86 |
(lambda (self field-index new-value) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
87 |
(vector-set! (object-fields self) field-index new-value))) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
88 |
|
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
89 |
(define o (send object-vt 'allocate 1)) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
90 |
(send o 'set-field! 0 'hello) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
91 |
(send o 'get-field 0) |
7be8b8dafdbf
Slight tweak to 'delegated; simple exercise of cola.rkt structures
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
325
diff
changeset
|
92 |
o |
327
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
326
diff
changeset
|
93 |
|
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
326
diff
changeset
|
94 |
;; Awkward: simple-vtable-vtable seems redundant (though does make the |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
326
diff
changeset
|
95 |
;; recursion in the object graph explicit); and vtables extend object, |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
326
diff
changeset
|
96 |
;; which means they get all object behaviours, including get-field, |
e64c8e1fd9d8
Variations on cola.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
326
diff
changeset
|
97 |
;; which doesn't make sense. |