source: project/release/5/yasos/trunk/yasos.scm @ 37736

Last change on this file since 37736 was 36326, checked in by Ivan Raikov, 20 months ago

ported yasos to C5

File size: 11.8 KB
Line 
1;; FILE          "yasos.scm"
2;; IMPLEMENTS    YASOS: Yet Another Scheme Object System
3;; AUTHOR        Ken [dot] Dickey [at] Whidbey [dot] Com
4;; DATE          1992 March 1
5;; LAST UPDATED  1992 March 5
6;; CHICKEN-PORT  2008 February 7
7;; MAINTAINER    ju(at)jugilo(dot)de
8;; LAST UPDATED  2013 October 5
9;;
10
11;;; AUTHOR: Ken Dickey, Ken(dot)Dickey(at)Whidbey(dot)Com
12;;; ported to Chicken and enhanced by Juergen Lorenz, ju(at)jugilo(dot)de
13;;;
14;;; COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
15;;;
16;;;Permission is hereby granted, free of charge, to any person
17;;;obtaining a copy of this software and associated documentation
18;;;files (the "Software"), to deal in the Software without
19;;;restriction, including without limitation the rights to use,
20;;;copy, modify, merge, publish, distribute, sublicense, and/or
21;;;sell copies of the Software, and to permit persons to whom
22;;;the Software is furnished to do so, subject to the following
23;;;conditions:
24;;;
25;;;The above copyright notice and this permission notice shall
26;;;be included in all copies or substantial portions of the Software.
27;;;
28;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
29;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
30;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
31;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
32;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
33;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
34;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
35;;;OTHER DEALINGS IN THE SOFTWARE.
36
37;; NOTES: An object system for Scheme based on the paper by
38;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
39;; Scheme", Proceedings of the 1988 ACM Conference on LISP and
40;; Functional Programming, July 1988 [ACM #552880].
41
42(module yasos
43
44(yasos
45 size
46 protocol
47 show
48 define-predicate
49 (object make-instance)
50 (define-operation instance? instance-dispatcher)
51 (object-with-ancestors make-instance instance-dispatcher)
52 (operations instance? make-instance instance-dispatcher)
53 (operate-as instance-dispatcher))
54
55(import scheme (chicken base) (chicken format))
56
57;; INSTANCE? MAKE-INSTANCE INSTANCE-DISPATCHER
58
59;; original version
60
61;(define make-instance 'bogus)  ;; defined below
62;(define instance?     'bogus)
63;
64;(let ((instance-tag "instance"))
65;      ;; Make a unique tag within a local scope.
66;      ;; No other data object is EQ? to this tag.
67;  (set! make-instance
68;  (lambda (dispatcher) (cons instance-tag dispatcher)))
69;  (set! instance?
70;  (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
71;     
72;(define-syntax instance-dispatcher
73;  (syntax-rules ()
74;    ((_ <inst>) (cdr <inst>))))
75
76;; internal
77(define-record-type instance
78  (make-instance dispatcher)
79  instance?
80  (dispatcher instance-dispatcher))
81
82;; DEFINE-OPERATION
83
84;; original version
85;(define-syntax define-operation
86;  (syntax-rules ()
87;    ((_ (<name> <inst> <arg> ...) <exp1> <exp2> ...) ;; with body
88;     (define <name>
89;       (letrec ((self
90;                  (lambda (<inst> <arg> ...)
91;                    (cond
92;                      ((and (instance? <inst>)
93;                            ((instance-dispatcher <inst>) self))
94;                         => (lambda (operation) (operation <inst> <arg> ...)))
95;                      (else <exp1> <exp2> ...)))))
96;         self)))
97;    ((_ (<name> <inst> <arg> ...)) ;; no body
98;     (define-operation (<name> <inst> <arg> ...)
99;       (error "Operation not handled" '<name>
100;              (format #f (if (instance? <inst>) "#<INSTANCE>" "~s") <inst>))))))
101
102;; the following version handles arbitrary lambda-lists as args
103(define-syntax define-operation
104  (syntax-rules ()
105    ((_ (name inst arg ...) xpr . xprs) ; ordinary argument list
106     (define name
107       (letrec (
108         (self
109           (lambda (inst arg ...)
110             (cond
111               ((and (instance? inst) 
112                     ((instance-dispatcher inst) self))
113                => (lambda (operation) (operation inst arg ...)))
114               (else xpr . xprs))))
115         )
116         self)))
117    ((_ (name inst . args) xpr . xprs) ; dotted argument list
118     (define name
119       (letrec (
120         (self
121           (lambda (inst . args)
122             (cond
123               ((and (instance? inst) 
124                     ((instance-dispatcher inst) self))
125                => (lambda (operation)
126                     (apply operation inst args)))
127               (else xpr . xprs))))
128         )
129         self)))
130    ((_ (name inst . args)) ;; no body
131     (define-operation (name inst . args)
132       (error "Operation not handled" 'name
133              (format #f
134                      (if (instance? inst) "#YASOS-INSTANCE" "~s")
135                      inst))))))
136
137;; DEFINE-PREDICATE
138(define-syntax define-predicate
139  (syntax-rules ()
140    ((_ name)
141     (define-operation (name obj) #f))))
142
143;; OBJECT (deprecated, use operations instead)
144
145;; original version
146;(define-syntax object
147;  (syntax-rules ()
148;    ((_ ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
149;     (let ((table
150;             (list (cons <name>
151;                   (lambda (<self> <arg> ...) <exp1> <exp2> ...)) ...)))
152;       (make-instance
153;         (lambda (op)
154;           (cond ((assq op table) => cdr)
155;                 (else #f))))))))
156
157(define-syntax object
158  (syntax-rules ()
159    ((_ ((name inst . args) xpr . xprs) ...)
160     (let ((table
161             (list (cons name
162                         (lambda (inst . args) xpr . xprs)) ...)))
163       (make-instance
164         (lambda (op)
165           (cond
166             ((assq op table) => cdr)
167             ((eq? op protocol)
168              (lambda (obj . optional-sym)
169                (if (null? optional-sym)
170                  '(name ...)
171                  (assq (car optional-sym)
172                        '((name inst . args) ...)))))
173             (else #f))))))))
174
175;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}
176;; (deprecated, use operations instead)
177
178;; original version
179;(define-syntax object-with-ancestors
180;  (syntax-rules ()
181;    ((_ ((<ancestor1> <init1>) ...) <operation> ...)
182;     (let ((<ancestor1> <init1>) ... )
183;       (let ((child (object <operation> ...)))
184;         (make-instance
185;           (lambda (op)
186;             (or ((instance-dispatcher child) op)
187;                 ((instance-dispatcher <ancestor1>) op) ...))))))))
188
189(define-syntax object-with-ancestors
190  (syntax-rules ()
191    ((_ ((ancestor init) ...) operation ...)
192     (let ((ancestor init) ...)
193       (let ((child (object operation ...)))
194         (make-instance
195           (lambda (op) 
196             (if (eq? op protocol)
197               (lambda (obj . optional-sym)
198                 (if (null? optional-sym)
199                   (append (protocol child)
200                           (list (protocol ancestor))
201                           ...)
202                   (let ((sym (car optional-sym)))
203                     (or (protocol child sym)
204                         (protocol ancestor sym)
205                         ...))))
206               (or ((instance-dispatcher child) op)
207                 ((instance-dispatcher ancestor) op)
208                 ...)))))))))
209
210;; OPERATIONS
211(define-syntax operations
212  (syntax-rules ()
213    ((_ () ((name inst . args) xpr . xprs) ...)
214     (let ((table
215             (list (cons name
216                         (lambda (inst . args) xpr . xprs)) ...)))
217       (make-instance
218         (lambda (op)
219           (cond
220             ((assq op table) => cdr)
221             ((eq? op protocol)
222              (lambda (obj . optional-sym)
223                (if (null? optional-sym)
224                  '(name ...)
225                  (assq (car optional-sym)
226                        '((name inst . args) ...)))))
227             (else #f))))))
228    ((_ ((ancestor0 init0) (ancestor1 init1) ...) operation ...)
229     (let ((ancestor0 init0) (ancestor1 init1) ...)
230       (let ((child (operations () operation ...)))
231         (make-instance
232           (lambda (op) 
233             (if (eq? op protocol)
234               (lambda (obj . optional-sym)
235                 (if (null? optional-sym)
236                   (append (protocol child)
237                           (list (protocol ancestor0))
238                           (list (protocol ancestor1))
239                           ...)
240                   (let ((sym (car optional-sym)))
241                     (or (protocol child sym)
242                         (protocol ancestor0 sym)
243                         (protocol ancestor1 sym)
244                         ...))))
245               (or ((instance-dispatcher child) op)
246                 ((instance-dispatcher ancestor0) op)
247                 ((instance-dispatcher ancestor1) op)
248                 ...)))))))))
249
250   
251;; OPERATE-AS  {a.k.a. send-to-super}
252;; used in operations/methods
253(define-syntax operate-as
254  (syntax-rules ()
255    ((_ super op)
256     ((instance-dispatcher super) op))
257    ((_ super op self arg ...)
258     (((instance-dispatcher super) op) self arg ...))))
259
260(define-operation (show obj . optional-arg)
261  (if (null? optional-arg)
262    (show obj #t)
263    (if (instance? obj)
264       (format (car optional-arg) "<yasos-instance: ~s>~%" obj)
265       (format (car optional-arg) "<not-a-yasos-instance: ~s>~%" obj))))
266 
267(define-operation (size obj)
268  ;; default behaviour
269  (cond
270    ((vector? obj) (vector-length obj))
271    ((list? obj) (length obj))
272    ((string? obj) (string-length obj))
273    ((pair? obj) 2)
274    ((char? obj) 1)
275    (else (error 'size
276                 (format #f "~s doesn't accept operation" obj)))))
277
278(define-operation (protocol obj . args) #f)
279
280(define yasos
281  (let ((lst '(define-predicate define-operation operations
282               object object-with-ancestors operate-as protocol size
283               show)))
284    (case-lambda
285      (() lst)
286      ((arg)
287       (case arg
288         ((show)
289          '(procedure
290             ((_ obj)
291              "prints obj with format to stdout")
292             ((_ obj arg)
293              "prints obj with format to arg")))
294         ((size)
295          '(procedure (result)
296             ((_ obj)
297              #t
298              (and (fixnum result) (fx>= result 0)))))
299         ((protocol)
300          '(procedure (result)
301             ((_ obj)
302              (instance? obj)
303              (and (list? result) "the names of operations obj accepts"))
304             ((_ obj sym)
305              (and (instance? obj) (symbol? sym))
306              (and (list? result) "signature of exported operation sym"))))
307         ((define-predicate)
308          '(macro ()
309                  ((_ name)
310                   (identifier? name)
311                   (procedure? result))))
312         ((define-operation)
313          '(macro ()
314                  ((_ (name inst . args) . xprs)
315                   (and (instance? inst) (identifier? name))
316                   (procedure? result))))
317         ((operations)
318          '(macro ()
319                  ((_ () ((name self . args) xpr . xprs) ...)
320                   (and (identifier? name) (instance? self))
321                   "multiple operations named name ... with given signature")
322                  ((_ ((ancestor init) ...) op . ops))
323                  (and (instance? ancestor) ... (operation? op) ...)
324                  "new or overridden operaions op . ops"))
325         ((object)
326          '(macro ()
327                  ((_ ((name self . args) xpr . xprs) ...)
328                   (and (identifier? name) (instance? self))
329                   "multiple operations named name ... with given signature")))
330         ((object-with-ancestors)
331          '(macro ()
332                  ((_ ((ancestor init) ...) op . ops))
333                  (and (instance? ancestor) ... (operation? op) ...)
334                  "new or overridden operaions op . ops"))
335         ((operate-as)
336          '(macro ()
337                  ((_ super op self . args)
338                   (and (instance? super)
339                        (instance? self)
340                        (operation? op))
341                   "send to super")))
342         (else
343           (error 'yasos "choose one of" lst)))))))
344
345) ;module yasos
346
Note: See TracBrowser for help on using the repository browser.