source: project/tinyclos/tinyclos-examples.scm @ 1373

Last change on this file since 1373 was 1373, checked in by felix winkelmann, 14 years ago

easyffi and tinyclos, s11n fix

File size: 7.9 KB
Line 
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; [felix] Changed to reflect Chicken's syntax
30
31
32(use tinyclos)
33
34(define getl
35    (lambda (initargs name . not-found)
36      (letrec ((scan (lambda (tail)
37                       (cond ((null? tail)
38                              (if (pair? not-found)
39                                  (car not-found)
40                                  (error "GETL couldn't find" name)))
41                             ((eq? (car tail) name) (cadr tail))
42                             (else (scan (cddr tail)))))))
43        (scan initargs))))
44
45(define filter-in
46    (lambda (f l)
47      (cond ((null? l) '())
48            ((f (car l)) (cons (car l) (filter-in f (cdr l))))
49            (else (filter-in f (cdr l))))))
50
51
52;***
53;
54; A simple class, just an instance of <class>.  Note that we are using
55; make and <class> rather than make-class to make it.  See Section 2.4
56; of AMOP for more on this.
57;
58;
59
60(define-class <pos> () (x y))
61
62(define-method (initialize (pos <pos>) initargs)
63  (call-next-method)
64  (initialize-slots pos initargs))
65
66(define p1 (make <pos> 'x 1 'y 2))
67(define p2 (make <pos> 'x 3 'y 5))
68
69
70;***
71;
72; Another way of writing that class definition, that achives better
73; `encapsulation' by using slot names that are unique keys, rather
74; than symbols.
75;
76;
77
78(define <pos> #f)
79
80(let ((x (vector 'x))
81      (y (vector 'y)))
82
83  (set! <pos> (make <class> 'name '<pos> 'direct-supers (list <object>) 'direct-slots (list x y)))
84
85  (define-method (pos-x (pos <pos>)) (slot-ref pos x))
86  (define-method (pos-y (pos <pos>)) (slot-ref pos y))
87
88  (define-method (move (pos <pos>) new-x new-y)
89    (slot-set! pos x new-x)
90    (slot-set! pos y new-y))
91
92  (define-method (initialize (pos <pos>) initargs)
93    (move pos (getl initargs 'x 0) (getl initargs 'y 0)))
94  )
95
96
97(define p3 (make <pos> 'x 1 'y 2))
98(define p4 (make <pos> 'x 3 'y 5))
99
100
101;***
102;
103; Class allocated slots.
104;
105; In Scheme, this extension isn't worth a whole lot, but what the hell.
106;
107;
108
109(define-class <class-slots-class> (<class>) ())
110
111(define-method (compute-getter-and-setter (class <class-slots-class>) slot allocator)
112  (if (not (memq ':class-allocation slot))
113      (call-next-method)
114      (let ((cell '()))
115        (values (lambda (o) cell)
116                (lambda (o new) (set! cell new) new)))))
117
118
119;
120; Here's a silly program that uses class allocated slots.
121;
122;
123(define-class <ship> () (name (all-ships :class-allocation)) <class-slots-class>)
124
125(define-method (initialize (ship <ship>) initargs)
126  (call-next-method)
127  (initialize-slots ship initargs)
128  (slot-set! ship
129             'all-ships
130             (cons ship (slot-ref ship 'all-ships))))
131
132(define-method (siblings (ship <ship>))
133  (remove ship (slot-ref ship 'all-ships)))
134
135(define s1 (make <ship> 'name 's1))
136(define s2 (make <ship> 'name 's2))
137(define s3 (make <ship> 'name 's3))
138
139(assert (= 3 (length (slot-ref s1 'all-ships))))
140
141
142;***
143;
144; Here's a class of class that allocates some slots dynamically.
145;
146; It has a layered protocol (dynamic-slot?) that decides whether a given
147; slot should be dynamically allocated.  This makes it easy to define a
148; subclass that allocates all its slots dynamically.
149;
150;
151(define-class <dynamic-class> (<class>) (alist-g-n-s))
152
153(define-method (dynamic-slot? (class <dynamic-class>) slot)
154  (memq ':dynamic-allocation (cdr slot)))
155
156(define alist-getter-and-setter
157  (lambda (dynamic-class allocator)
158    (let ((old (slot-ref dynamic-class 'alist-g-n-s)))
159      (if (eq? old (void))
160          (let ([new (call-with-values (lambda () (allocator (lambda () (void)))) cons)])
161            (slot-set! dynamic-class 'alist-g-n-s new)
162            new)
163          old))))
164
165(define-method (compute-getter-and-setter (class <dynamic-class>) slot allocator)
166  (if (not (dynamic-slot? class slot))
167      (call-next-method)
168      (let* ((name (car slot))
169             (g-n-s (alist-getter-and-setter class allocator))
170             (alist-getter (car g-n-s))
171             (alist-setter (cdr g-n-s)))
172        (values (lambda (o)
173                  (let ((entry (assq name  (alist-getter o))))
174                    (if (not entry)
175                        #f
176                        (cdr entry))))
177                (lambda (o new)
178                  (let* ((alist (alist-getter o))
179                         (entry (assq name alist)))
180                    (if (not entry)
181                        (alist-setter o
182                                      (cons (cons name new) alist))
183                        (set-cdr! entry new))
184                    new))))))
185
186(define-class <all-dynamic-class> (<dynamic-class>) ())
187
188(define-method (dynamic-slot? (class <all-dynamic-class>) slot) #t)
189           
190
191
192;
193; A silly program that uses this.
194;
195;
196
197(define-class <person> () (name age address) <all-dynamic-class>)
198
199(define-method (initialize (person <person>) initargs)
200  (initialize-slots person initargs))
201
202(define person1 (make <person> 'name 'sally))
203(define person2 (make <person> 'name 'betty))
204(define person3 (make <person> 'name 'sue))
205
206
207;***
208;
209; A ``database'' class that stores slots externally.
210;
211;
212
213(define-class <db-class> (<class>) (id-g-n-s))
214
215(define id-getter-and-setter
216  (lambda (db-class allocator)
217    (let ((old (slot-ref db-class 'id-g-n-s)))
218      (if (eq? old (void))
219          (let ((new (call-with-values (lambda () (allocator db-allocate-id)) cons)))
220            (slot-set! class 'id-g-n-s new)
221            new)
222          old))))
223
224(define-method (compute-getter-and-setter (class <db-class>) slot allocator)
225  (let* ((id-g-n-s (id-getter-and-setter class allocator))
226         (id-getter (car id-g-n-s))
227         (id-setter (cdr id-g-n-s))
228         (slot-name (car slot)))
229    (values (lambda (o)
230              (db-lookup (id-getter o) slot-name)) 
231            (lambda (o new)
232              (db-store  (id-getter o) slot-name new)))))
233
234
235;***
236;
237; A kind of generic that supports around methods.
238;
239;
240(define make-around-generic
241    (lambda () (make <around-generic>)))
242
243(define make-around-method
244    (lambda (specializers procedure)
245      (make <around-method>
246            'specializers specializers
247            'procedure procedure)))
248
249
250(define <around-generic> (make <entity-class>
251                           'direct-supers (list <generic>)))
252
253(define <around-method> (make <class>
254                          'direct-supers (list <method>)))
255
256
257(define-method (around-method? (x <method>)) #f)
258(define-method (around-method? (x <around-method>)) #t)
259
260(define-method (compute-methods (generic <around-generic>))
261  (let ((normal-compute-methods (call-next-method)))
262    (lambda (args)
263      (let ((normal-methods (normal-compute-methods args)))
264        (append
265         (filter-in around-method?
266                    normal-methods)
267         (filter-in (lambda (m) (not (around-method? m)))
268                    normal-methods))))))
269
270
271;
272; And a simple example of using it.
273;
274;
275
276(define-class <baz> () ())
277(define-class <bar> (<baz>) ())
278(define-class <foo> (<bar>) ())
279
280(define test-around
281  (lambda (generic)
282    (add-method generic
283      (make-method        (list <foo>)
284        (lambda (cnm x) (cons 'foo (cnm)))))
285
286    (add-method generic
287      (make-around-method (list <bar>)
288                          (lambda (cnm x) (cons 'bar (cnm)))))
289
290    (add-method generic
291      (make-method        (list <baz>)
292        (lambda (cnm x) '(baz))))
293
294    (generic (make <foo>))))
295
296(assert (equal? (test-around (make-generic))        '(foo bar baz)))
297(assert (equal? (test-around (make-around-generic)) '(bar foo baz)))
Note: See TracBrowser for help on using the repository browser.