smalltalk-tng
view r6f/cola.rkt @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | d07e7e900380 |
| children |
line source
1 #lang racket/base
3 ;; Implementation of Piumarta/Warth-style "Open, Reusable Object
4 ;; Models" for Racket.
6 ;; Objects: have private state of their own, and a vtable for giving
7 ;; them behaviour.
8 ;;
9 ;; VTables: map method names to closures. Include simple parent-style
10 ;; delegation. Are also objects.
12 (provide (all-defined-out)) ;; TODO
14 (define-values (prop:vtable vtable? vtable-getter)
15 (make-struct-type-property 'vtable))
17 (struct simple-vtable (methods parent vtable) #:prefab)
19 (define (vtable-of o)
20 (cond
21 ((vtable? o) ((vtable-getter o) o))
22 ((simple-vtable? o) (simple-vtable-vtable o))
23 (else (error 'vtable-of "Cannot compute vtable for ~v" o))))
25 (define (bind o name)
26 (let ((vt (vtable-of o)))
27 (if (and (eq? name 'lookup)
28 (eq? vt vtable-vt))
29 (vtable-lookup o name)
30 (send vt 'lookup name))))
32 (define (send o name . args)
33 (let ((closure (bind o name)))
34 (apply closure o args)))
36 (define (vtable-lookup self name)
37 (hash-ref (simple-vtable-methods self)
38 name
39 (lambda ()
40 (let ((parent (simple-vtable-parent self)))
41 (if parent
42 (send parent 'lookup name)
43 (error 'vtable-lookup "No method called ~v" name))))))
45 (define (vtable-add-method! self name method)
46 (hash-set! (simple-vtable-methods self)
47 name
48 method))
50 (define object-vt (let* ((ovt-ph (make-placeholder #f))
51 (vvt-ph (make-placeholder #f))
52 (ovt (simple-vtable (make-hash) #f vvt-ph))
53 (vvt (simple-vtable (make-hash) ovt-ph vvt-ph)))
54 (placeholder-set! ovt-ph ovt)
55 (placeholder-set! vvt-ph vvt)
56 (make-reader-graph ovt)))
57 (define vtable-vt (simple-vtable-vtable object-vt))
59 (vtable-add-method! vtable-vt 'lookup vtable-lookup)
61 (vtable-add-method! vtable-vt 'add-method!
62 (lambda (self name method)
63 (hash-set! (simple-vtable-methods self)
64 name
65 method)))
67 (send vtable-vt 'add-method! 'delegated
68 (lambda (self)
69 (simple-vtable (make-hash) self vtable-vt)))