1 | ; Mode: Scheme |
---|
2 | ; |
---|
3 | ; |
---|
4 | ; ********************************************************************** |
---|
5 | ; Copyright (c) 1992 Xerox Corporation. |
---|
6 | ; All Rights Reserved. |
---|
7 | ; |
---|
8 | ; Use, reproduction, and preparation of derivative works are permitted. |
---|
9 | ; Any copy of this software or of any derivative work must include the |
---|
10 | ; above copyright notice of Xerox Corporation, this paragraph and the |
---|
11 | ; one after it. Any distribution of this software or derivative works |
---|
12 | ; must comply with all applicable United States export control laws. |
---|
13 | ; |
---|
14 | ; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS |
---|
15 | ; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE |
---|
16 | ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR |
---|
17 | ; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY |
---|
18 | ; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS |
---|
19 | ; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING |
---|
20 | ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED |
---|
21 | ; OF THE POSSIBILITY OF SUCH DAMAGES. |
---|
22 | ; ********************************************************************** |
---|
23 | ; |
---|
24 | ; Some simple examples of using Tiny CLOS and its MOP. |
---|
25 | ; |
---|
26 | ; Much of this stuff corresponds to stuff in AMOP (The Art of the |
---|
27 | ; Metaobject Protocol). |
---|
28 | ; |
---|
29 | |
---|
30 | (define-syntax test-pp |
---|
31 | (syntax-rules() |
---|
32 | ((_ x) (begin (newline)(pp 'x)(pp x))))) |
---|
33 | |
---|
34 | ;*** |
---|
35 | ; |
---|
36 | ; This is a useful sort of helper function. Note how it uses the |
---|
37 | ; introspective part of the MOP. The first few pages of chapter |
---|
38 | ; two of the AMOP discuss this. |
---|
39 | ; |
---|
40 | ; Note that this introspective MOP doesn't support back-links from |
---|
41 | ; the classes to methods and generic functions. Is that worth adding? |
---|
42 | ; |
---|
43 | ; |
---|
44 | (define initialize-slots |
---|
45 | (lambda (object initargs) |
---|
46 | (let ((not-there (list 'shes-not-there))) |
---|
47 | (for-each (lambda (slot) |
---|
48 | (let ((name (car slot))) |
---|
49 | (let ((value (getl initargs name not-there))) |
---|
50 | (if (eq? value not-there) |
---|
51 | 'do-nothing |
---|
52 | (slot-set! object name value))))) |
---|
53 | (class-slots (class-of object)))))) |
---|
54 | |
---|
55 | |
---|
56 | |
---|
57 | ;*** |
---|
58 | ; |
---|
59 | ; A simple class, just an instance of <class>. Note that we are using |
---|
60 | ; make and <class> rather than make-class to make it. See Section 2.4 |
---|
61 | ; of AMOP for more on this. |
---|
62 | ; |
---|
63 | ; |
---|
64 | |
---|
65 | (define <pos> (make <class> ;[make-class |
---|
66 | 'direct-supers (list <object>) ; (list <object>) |
---|
67 | 'direct-slots (list 'x 'y))) ; (list 'x 'y)] |
---|
68 | |
---|
69 | (add-method initialize |
---|
70 | (make-method (list <pos>) |
---|
71 | (lambda (call-next-method pos initargs) |
---|
72 | (call-next-method) |
---|
73 | (initialize-slots pos initargs)))) |
---|
74 | |
---|
75 | (define p1 (make <pos> 'x 1 'y 2)) |
---|
76 | (define p2 (make <pos> 'x 3 'y 5)) |
---|
77 | |
---|
78 | (test-pp p1) |
---|
79 | (test-pp (slot-ref p1 'x)) |
---|
80 | (test-pp (slot-ref p1 'y)) |
---|
81 | |
---|
82 | |
---|
83 | (test-pp p2) |
---|
84 | (test-pp (slot-ref p2 'x)) |
---|
85 | (test-pp (slot-ref p2 'y)) |
---|
86 | |
---|
87 | |
---|
88 | ;*** |
---|
89 | ; |
---|
90 | ; Another way of writing that class definition, that achives better |
---|
91 | ; `encapsulation' by using slot names that are unique keys, rather |
---|
92 | ; than symbols. |
---|
93 | ; |
---|
94 | ; |
---|
95 | |
---|
96 | (define <pos>) |
---|
97 | (define pos-x (make-generic)) |
---|
98 | (define pos-y (make-generic)) |
---|
99 | (define move (make-generic)) |
---|
100 | |
---|
101 | (let ((x (vector 'x)) |
---|
102 | (y (vector 'y))) |
---|
103 | |
---|
104 | (set! <pos> (make <class> |
---|
105 | 'direct-supers (list <object>) |
---|
106 | 'direct-slots (list x y))) |
---|
107 | |
---|
108 | (add-method pos-x |
---|
109 | (make-method (list <pos>) |
---|
110 | (lambda (call-next-method pos) (slot-ref pos x)))) |
---|
111 | (add-method pos-y |
---|
112 | (make-method (list <pos>) |
---|
113 | (lambda (call-next-method pos) (slot-ref pos y)))) |
---|
114 | |
---|
115 | (add-method move |
---|
116 | (make-method (list <pos>) |
---|
117 | (lambda (call-next-method pos new-x new-y) |
---|
118 | (slot-set! pos x new-x) |
---|
119 | (slot-set! pos y new-y)))) |
---|
120 | |
---|
121 | (add-method initialize |
---|
122 | (make-method (list <pos>) |
---|
123 | (lambda (call-next-method pos initargs) |
---|
124 | (move pos (getl initargs 'x 0) (getl initargs 'y 0))))) |
---|
125 | ) |
---|
126 | |
---|
127 | |
---|
128 | (define p3 (make <pos> 'x 1 'y 2)) |
---|
129 | (define p4 (make <pos> 'x 3 'y 5)) |
---|
130 | |
---|
131 | |
---|
132 | (test-pp p3) |
---|
133 | (test-pp (pos-x p3)) |
---|
134 | (test-pp (pos-y p3)) |
---|
135 | |
---|
136 | (test-pp p4) |
---|
137 | (test-pp (pos-x p4)) |
---|
138 | (test-pp (pos-y p4)) |
---|
139 | |
---|
140 | (move p4 10 11) |
---|
141 | |
---|
142 | (test-pp p4) |
---|
143 | (test-pp (pos-x p4)) |
---|
144 | (test-pp (pos-y p4)) |
---|
145 | |
---|
146 | |
---|
147 | ;*** |
---|
148 | ; |
---|
149 | ; Class allocated slots. |
---|
150 | ; |
---|
151 | ; In Scheme, this extension isn't worth a whole lot, but what the hell. |
---|
152 | ; |
---|
153 | ; |
---|
154 | |
---|
155 | (define <class-slots-class> |
---|
156 | (make-class (list <class>) |
---|
157 | (list))) |
---|
158 | |
---|
159 | (add-method compute-getter-and-setter |
---|
160 | (make-method (list <class-slots-class>) |
---|
161 | (lambda (call-next-method class slot allocator) |
---|
162 | (if (not (memq ':class-allocation slot)) |
---|
163 | (call-next-method) |
---|
164 | (let ((cell '())) |
---|
165 | (list (lambda (o) cell) |
---|
166 | (lambda (o new) (set! cell new) new))))))) |
---|
167 | |
---|
168 | |
---|
169 | ; |
---|
170 | ; Here's a silly program that uses class allocated slots. |
---|
171 | ; |
---|
172 | ; |
---|
173 | (define <ship> |
---|
174 | (make <class-slots-class> |
---|
175 | 'direct-supers (list <object>) |
---|
176 | 'direct-slots (list 'name |
---|
177 | '(all-ships :class-allocation)))) |
---|
178 | |
---|
179 | (add-method initialize |
---|
180 | (make-method (list <ship>) |
---|
181 | (lambda (call-next-method ship initargs) |
---|
182 | (call-next-method) |
---|
183 | (initialize-slots ship initargs) |
---|
184 | (slot-set! ship |
---|
185 | 'all-ships |
---|
186 | (cons ship (slot-ref ship 'all-ships)))))) |
---|
187 | |
---|
188 | (define siblings (make-generic)) |
---|
189 | (add-method siblings |
---|
190 | (make-method (list <ship>) |
---|
191 | (lambda (call-next-method ship) |
---|
192 | (remove ship (slot-ref ship 'all-ships))))) |
---|
193 | |
---|
194 | (define s1 (make <ship> 'name 's1)) |
---|
195 | (define s2 (make <ship> 'name 's2)) |
---|
196 | (test-pp s2) |
---|
197 | (test-pp (slot-ref s2 'name)) |
---|
198 | (define s3 (make <ship> 'name 's3)) |
---|
199 | |
---|
200 | (test-pp s1) |
---|
201 | (test-pp (slot-ref s1 'name)) |
---|
202 | |
---|
203 | (test-pp s2) |
---|
204 | (test-pp (slot-ref s2 'name)) |
---|
205 | |
---|
206 | (test-pp s3) |
---|
207 | (test-pp (slot-ref s3 'name)) |
---|
208 | |
---|
209 | (test-pp <ship>) |
---|
210 | (test-pp (class-direct-slots <ship>)) |
---|
211 | |
---|
212 | (test-pp (map (lambda(x) (cons x (slot-ref x 'name))) (siblings s1))) |
---|
213 | |
---|
214 | |
---|
215 | ;*** |
---|
216 | ; |
---|
217 | ; Here's a class of class that allocates some slots dynamically. |
---|
218 | ; |
---|
219 | ; It has a layered protocol (dynamic-slot?) that decides whether a given |
---|
220 | ; slot should be dynamically allocated. This makes it easy to define a |
---|
221 | ; subclass that allocates all its slots dynamically. |
---|
222 | ; |
---|
223 | ; |
---|
224 | (define <dynamic-class> |
---|
225 | (make-class (list <class>) |
---|
226 | (list 'alist-g-n-s))) |
---|
227 | |
---|
228 | |
---|
229 | (define dynamic-slot? (make-generic)) |
---|
230 | |
---|
231 | (add-method dynamic-slot? |
---|
232 | (make-method (list <dynamic-class>) |
---|
233 | (lambda (call-next-method class slot) |
---|
234 | (memq :dynamic-allocation (cdr slot))))) |
---|
235 | |
---|
236 | |
---|
237 | |
---|
238 | (define alist-getter-and-setter |
---|
239 | (lambda (dynamic-class allocator) |
---|
240 | (let ((old (slot-ref dynamic-class 'alist-g-n-s))) |
---|
241 | (if (null? old) |
---|
242 | (let ((new (allocator (lambda () '())))) |
---|
243 | (slot-set! dynamic-class 'alist-g-n-s new) |
---|
244 | new) |
---|
245 | old)))) |
---|
246 | |
---|
247 | |
---|
248 | (add-method compute-getter-and-setter |
---|
249 | (make-method (list <dynamic-class>) |
---|
250 | (lambda (call-next-method class slot allocator) |
---|
251 | (if (null? (dynamic-slot? class slot)) |
---|
252 | (call-next-method) |
---|
253 | (let* ((name (car slot)) |
---|
254 | (g-n-s (alist-getter-and-setter class allocator)) |
---|
255 | (alist-getter (car g-n-s)) |
---|
256 | (alist-setter (cadr g-n-s))) |
---|
257 | (list (lambda (o) |
---|
258 | (let ((entry (assq name (alist-getter o)))) |
---|
259 | (if (not entry) |
---|
260 | '() |
---|
261 | (cdr entry)))) |
---|
262 | (lambda (o new) |
---|
263 | (let* ((alist (alist-getter o)) |
---|
264 | (entry (assq name alist))) |
---|
265 | (if (not entry) |
---|
266 | (alist-setter o |
---|
267 | (cons (cons name new) alist)) |
---|
268 | (set-cdr! entry new)) |
---|
269 | new)))))))) |
---|
270 | |
---|
271 | |
---|
272 | (define <all-dynamic-class> |
---|
273 | (make-class (list <dynamic-class>) |
---|
274 | (list))) |
---|
275 | |
---|
276 | (add-method dynamic-slot? |
---|
277 | (make-method (list <all-dynamic-class>) |
---|
278 | (lambda (call-next-method class slot) #t))) |
---|
279 | |
---|
280 | |
---|
281 | |
---|
282 | ; |
---|
283 | ; A silly program that uses this. |
---|
284 | ; |
---|
285 | ; |
---|
286 | (define <person> (make <all-dynamic-class> |
---|
287 | 'direct-supers (list <object>) |
---|
288 | 'direct-slots (list 'name 'age 'address))) |
---|
289 | |
---|
290 | (add-method initialize |
---|
291 | (make-method (list <person>) |
---|
292 | (lambda (call-next-method person initargs) |
---|
293 | (initialize-slots person initargs)))) |
---|
294 | |
---|
295 | |
---|
296 | (define person1 (make <person> 'name 'sally)) |
---|
297 | (define person2 (make <person> 'name 'betty)) |
---|
298 | (define person3 (make <person> 'name 'sue)) |
---|
299 | |
---|
300 | (test-pp (slot-ref person1 'name)) |
---|
301 | |
---|
302 | (slot-set! person1 'age 20) |
---|
303 | (test-pp (slot-ref person1 'age)) |
---|
304 | |
---|
305 | |
---|
306 | ;*** |
---|
307 | ; |
---|
308 | ; A ``database'' class that stores slots externally. |
---|
309 | ; |
---|
310 | ; |
---|
311 | |
---|
312 | (define <db-class> |
---|
313 | (make-class (list <class>) |
---|
314 | (list 'id-g-n-s))) |
---|
315 | |
---|
316 | (define id-getter-and-setter |
---|
317 | (lambda (db-class allocator) |
---|
318 | (let ((old (slot-ref db-class 'id-g-n-s))) |
---|
319 | (if (null? old) |
---|
320 | (let ((new (allocator db-allocate-id))) |
---|
321 | (slot-set! class 'id-g-n-s new) |
---|
322 | new) |
---|
323 | old)))) |
---|
324 | |
---|
325 | (add-method compute-getter-and-setter |
---|
326 | (make-method (list <db-class>) |
---|
327 | (lambda (call-next-method class slot allocator) |
---|
328 | (let* ((id-g-n-s (id-getter-and-setter class allocator)) |
---|
329 | (id-getter (car id-g-n-s)) |
---|
330 | (id-setter (cadr id-g-n-s)) |
---|
331 | (slot-name (car slot))) |
---|
332 | (list (lambda (o) |
---|
333 | (db-lookup (id-getter o) slot-name)) |
---|
334 | (lambda (o new) |
---|
335 | (db-store (id-getter o) slot-name new))))))) |
---|
336 | |
---|
337 | |
---|
338 | ;*** |
---|
339 | ; |
---|
340 | ; A kind of generic that supports around methods. |
---|
341 | ; |
---|
342 | ; |
---|
343 | (define make-around-generic |
---|
344 | (lambda () (make <around-generic>))) |
---|
345 | |
---|
346 | (define make-around-method |
---|
347 | (lambda (specializers procedure) |
---|
348 | (make <around-method> |
---|
349 | 'specializers specializers |
---|
350 | 'procedure procedure))) |
---|
351 | |
---|
352 | |
---|
353 | (define <around-generic> (make <entity-class> |
---|
354 | 'direct-supers (list <generic>))) |
---|
355 | (define <around-method> (make <class> |
---|
356 | 'direct-supers (list <method>))) |
---|
357 | |
---|
358 | |
---|
359 | (define around-method? (make-generic)) |
---|
360 | |
---|
361 | (add-method around-method? |
---|
362 | (make-method (list <method>) |
---|
363 | (lambda (call-next-method x) #f))) |
---|
364 | (add-method around-method? |
---|
365 | (make-method (list <around-method>) |
---|
366 | (lambda (call-next-method x) #t))) |
---|
367 | |
---|
368 | |
---|
369 | (add-method compute-methods |
---|
370 | (make-method (list <around-generic>) |
---|
371 | (lambda (call-next-method generic) |
---|
372 | (let ((normal-compute-methods (call-next-method))) |
---|
373 | (lambda (args) |
---|
374 | (let ((normal-methods (normal-compute-methods args))) |
---|
375 | (append |
---|
376 | (filter-in around-method? |
---|
377 | normal-methods) |
---|
378 | (filter-in (lambda (m) (not (around-method? m))) |
---|
379 | normal-methods)))))))) |
---|
380 | |
---|
381 | |
---|
382 | ; |
---|
383 | ; And a simple example of using it. |
---|
384 | ; |
---|
385 | ; |
---|
386 | (define <baz> (make-class (list <object>) (list))) |
---|
387 | (define <bar> (make-class (list <baz>) (list))) |
---|
388 | (define <foo> (make-class (list <bar>) (list))) |
---|
389 | |
---|
390 | |
---|
391 | (define test-around |
---|
392 | (lambda (generic) |
---|
393 | (add-method generic |
---|
394 | (make-method (list <foo>) |
---|
395 | (lambda (cnm x) (cons 'foo (cnm))))) |
---|
396 | |
---|
397 | (add-method generic |
---|
398 | (make-around-method (list <bar>) |
---|
399 | (lambda (cnm x) (cons 'bar (cnm))))) |
---|
400 | |
---|
401 | (add-method generic |
---|
402 | (make-method (list <baz>) |
---|
403 | (lambda (cnm x) '(baz)))) |
---|
404 | |
---|
405 | (generic (make <foo>)))) |
---|
406 | |
---|
407 | (test-pp (equal? (test-around (make-generic)) '(foo bar baz))) |
---|
408 | |
---|
409 | (test-pp (equal? (test-around (make-around-generic)) '(bar foo baz))) |
---|
410 | |
---|
411 | 'examples_all_done |
---|