source: project/release/4/operations/t-s48.scm @ 12312

Last change on this file since 12312 was 12312, checked in by felix winkelmann, 12 years ago

ported to chicken-4

File size: 11.3 KB
Line 
1;;; -*- Mode: Scheme -*-
2
3;;;; T Objects & Operations for Scheme48
4
5;;; This code is written by Taylor Campbell and placed in the Public
6;;; Domain.  All warranties are disclaimed.
7
8; ,open assembler closures receiving templates signals
9; ,for-syntax ,open destructuring
10
11(define (make-object proc dispatcher)
12  (cond ((closure? proc)
13         (%make-object (closure-template proc)
14                       (closure-env      proc)
15                       dispatcher
16                       object-tag))
17        ((not proc)
18         (%make-object inapplicable-object-template
19                       #f               ; null environment
20                       dispatcher
21                       object-tag))
22        (else
23         (error "invalid object procedure"
24                proc))))
25
26(define object-tag (list 'object))
27
28;; (define (%make-object template env dispatcher tag)
29;;   ;; Think of a CLOSURE procedure like the VECTOR procedure.
30;;   (closure template env dispatcher tag))
31
32(define %make-object
33  (lap %make-object ()
34       (protocol 4)
35       (pop)
36       (make-stored-object 4 closure)
37       (return)))
38
39;; (define (inapplicable-object . args)
40;;   (error "inapplicable object" (current-procedure) args))
41
42(define inapplicable-object
43  (lap inapplicable-object ()
44       (protocol 0 + (push template))
45       (push)
46       (stack-ref 2)
47       (make-stored-object 2 pair)
48       (push+stack-indirect 1 4)        ; literal ()
49       (make-stored-object 2 pair)
50       (push+stack-indirect 1 5)        ; literal "inapplicable object"
51       (push+stack-ref 1)
52       (make-stored-object 2 pair)
53       (push+stack-indirect 2 6)        ; literal ERROR
54       (push+stack-ref 1)
55       (make-stored-object 2 pair)
56       (trap)
57       (return)))
58
59(define inapplicable-object-template
60  (let* ((old (closure-template inapplicable-object))
61         (new (make-template 7 #f))
62         (copy (lambda (i)
63                 (template-set! new i (template-ref old i)))))
64    (copy 0) (copy 1) (copy 2) (copy 3)
65    (template-set! new 4 '())
66    (template-set! new 5 "inapplicable object")
67    (template-set! new 6 'error)
68    new))
69
70(define (object-dispatcher obj)
71  (%object-dispatcher object-tag obj))
72
73;; (define (%object-dispatcher object-tag obj)
74;;   (and (closure? obj)
75;;        (= 4 (closure-length obj))
76;;        (eq? object-tag (closure-ref obj 3))
77;;        (closure-ref obj 2)))
78
79(define %object-dispatcher
80  (lap object-dispatcher ()
81       (protocol 2)
82       (stack-ref 0)
83       (stored-object-has-type? closure)
84       (jump-if-false return)
85       (stack-ref 0)
86       (stored-object-length closure)
87       (push)
88       (literal 4)
89       (=)
90       (jump-if-false return)
91       (stack-indirect 0 3)
92       (stack-ref+push 1)
93       (eq?)
94       (jump-if-false return)
95       (stack-indirect 0 2)
96return (return)))
97
98;;; Predicate for possible integration of Scheme48's generic dispatch
99;;; system:
100;;;
101;;;   (define-simple-type :bogus-entity (:value) bogus-entity?)
102;;;
103;;;   (define-method &disclose ((obj :bogus-entity))
104;;;     (disclose obj))
105;;;
106;;;   &c.
107
108(define (bogus-entity? obj)
109  (%bogus-entity? object-tag obj))
110
111;; (define (%bogus-entity? object-tag obj)
112;;   (and (closure? obj)
113;;        (= 4 (closure-length obj))
114;;        (eq? object-tag (closure-ref obj 3))))
115
116(define %bogus-entity?
117  (lap %bogus-entity? ()
118       (protocol 2)
119       (stack-ref 0)
120       (stored-object-has-type? closure)
121       (jump-if-false return)
122       (stack-ref 0)
123       (stored-object-length closure)
124       (push)
125       (literal 4)
126       (=)
127       (jump-if-false return)
128       (stack-indirect 0 3)
129       (stack-ref+push 1)
130       (eq?)
131return (return)))
132
133;;;; OBJECT Syntax
134
135(define-syntax object
136  (syntax-rules ()
137    ((OBJECT proc
138       ((op self . args) body0 body1 ...)
139       ...)
140     (MAKE-OBJECT proc
141                  (*DISPATCHER ((op self . args) body0 body1 ...)
142                               ...)))))
143
144;;; Rough definition.  The real one doesn't cons a closure for every
145;;; dispatch.
146
147; (define-syntax *dispatcher
148;   (syntax-rules ()
149;     ((*DISPATCHER ((op self . args) body0 body1 ...)
150;                   ...)
151;      (LAMBDA (OPERATION)
152;        (VALUES (COND ((EQ? OPERATION op)
153;                       (METHOD-LAMBDA self args body0 body1 ...))
154;                      ...
155;                      (ELSE #F))
156;                NO-MORE-JOIN-LINKS)))))
157
158(define-syntax *dispatcher
159  (lambda (form rename compare)
160    (let ((method-vars
161           (let ((n 0))
162             (map (lambda (method)
163                    (set! n (+ n 1))
164                    (rename (string->symbol
165                             (string-append "method"
166                                            (number->string n)))))
167                  (cdr form))))
168          (%let (rename 'LET))
169          (%method-lambda (rename 'METHOD-LAMBDA))
170          (%lambda (rename 'LAMBDA))
171          (%operation (rename 'OPERATION))
172          (%values (rename 'VALUES))
173          (%cond (rename 'COND))
174          (%eq? (rename 'EQ?))
175          (%else (rename 'ELSE)))
176      `(,%let ,(map (lambda (var method)
177                      (destructure (( ((op self . args) . body)
178                                      method))
179                        `(,var (,%method-lambda ,self ,args ,@body))))
180                    method-vars (cdr form))
181         (,%lambda (,%operation)
182           (,%values (,%cond ,@(map (lambda (var method)
183                                      `((,%eq? ,%operation
184                                               ,(caar method))
185                                        ,var))
186                                    method-vars (cdr form))
187                             (,%else #F))
188                     ,(rename 'NO-MORE-JOIN-LINKS))))))
189  (let method-lambda lambda values cond eq? else no-more-join-links))
190
191;;; (METHOD-LAMBDA self args body)
192;;; (METHOD-LAMBDA (true-self [self [next [op]]]) args body)
193
194(define-syntax method-lambda
195  (syntax-rules ()
196    ((METHOD-LAMBDA (true-self) args body0 body1 ...)
197     (LAMBDA (true-self SELF NEXT OP . args)
198       SELF NEXT OP          ; ignored
199       body0 body1 ...))
200    ((METHOD-LAMBDA (true-self self) args body0 body1 ...)
201     (LAMBDA (true-self self NEXT OP . args)
202       NEXT OP               ; ignored
203       body0 body1 ...))
204    ((METHOD-LAMBDA (true-self self next) args body0 body1 ...)
205     (LAMBDA (true-self self next OP . args)
206       OP                    ; ignored
207       body0 body1 ...))
208    ((METHOD-LAMBDA (true-self self next op) args body0 body1 ...)
209     (LAMBDA (true-self self next op . args)
210       body0 body1 ...))
211    ((METHOD-LAMBDA self args body0 body1 ...)
212     (LAMBDA (TRUE-SELF self NEXT OP . args)
213       TRUE-SELF NEXT OP     ; ignored
214       body0 body1 ...))))
215
216;;;; Operations
217
218(define (operate operation obj . args)
219  (apply operate-as operation obj obj args))
220
221(define (operate-as operation obj other . args)
222  (receive (method next)
223           (dispatch obj operation)
224    (if method
225        (apply method obj other next operation args)
226        (apply run-default-method operation other args))))
227
228(define (dispatch obj operation)
229  (cond ((object-dispatcher obj)
230         => (lambda (dispatcher)
231              (dispatcher operation)))
232        (else
233         (primitive-dispatch obj operation))))
234
235(define (primitive-dispatch obj op)
236  (values #f no-more-join-links))
237
238(define-syntax operation
239  (syntax-rules ()
240    ((OPERATION default method-clause ...)
241     (LETREC ((DEFAULT-METHOD default)
242              (OP
243               (OBJECT (LAMBDA (OBJ . ARGS)
244                         (RECEIVE (METHOD NEXT)
245                                  (DISPATCH OBJ OP)
246                           (COND (METHOD
247                                  (APPLY METHOD OBJ OBJ NEXT OP ARGS))
248                                 (DEFAULT-METHOD
249                                  (APPLY DEFAULT-METHOD OBJ ARGS))
250                                 (ELSE
251                                  (ERROR "no default method"
252                                         OP OBJ ARGS)))))
253                 ((RUN-DEFAULT-METHOD SELF OBJ . ARGS)
254                  (IF DEFAULT-METHOD
255                      (APPLY DEFAULT-METHOD OBJ ARGS)
256                      (ERROR "no default method"
257                             OP OBJ ARGS)))
258                 ((OPERATION? SELF) #T)
259                 method-clause ...
260                 ((DISCLOSE SELF)
261                  `(OPERATION ,@(COND ((IDENTIFICATION OP) => LIST)
262                                      (ELSE '())))))))
263       OP))))
264
265(define-syntax define-operation
266  (syntax-rules ()
267    ((DEFINE-OPERATION (name . args))
268     (DEFINE name (OPERATION #F ((IDENTIFICATION SELF) 'name))))
269    ((DEFINE-OPERATION (name . args) body0 body1 ...)
270     (DEFINE name
271             (OPERATION (LAMBDA args body0 body1 ...)
272               ((IDENTIFICATION SELF) 'name))))))
273
274(define-syntax define-predicate
275  (syntax-rules ()
276    ((DEFINE-PREDICATE name)
277     (DEFINE-OPERATION (name OBJ) #F))))
278
279(define-predicate operation?)
280(define-operation (run-default-method op obj . args))
281(define-operation (identification obj) #f)
282(define-operation (disclose obj) #f)
283(define-operation (setter op))
284
285(define-syntax define-settable-operation
286  (syntax-rules ()
287    ((DEFINE-SETTABLE-OPERATION (name . args) body0 body1 ...)
288     (DEFINE name
289       (LET ((THE-SETTER (OPERATION #F
290                           ((IDENTIFICATION SELF)
291                            `(SETTER ,name)))))
292         (OPERATION (LAMBDA args body0 body1 ...)
293           ((SETTER SELF) THE-SETTER)
294           ((IDENTIFICATION SELF) 'name)))))))
295
296;;;; Joined Objects
297
298(define (join obj . objs)
299  (if (null? objs)
300      obj
301      (join2 obj (apply join objs))))
302
303(define (join2 a b)
304  (if (joined? a joined-tag)
305      (join2 (joined-lhs a)
306             (join2 (joined-rhs a) b))
307      (make-object (if (eq? (closure-template a)
308                            inapplicable-object-template)
309                       b
310                       a)
311                   (make-closure join-dispatcher-template
312                                 (vector a b joined-tag)))))
313
314(define join-dispatcher-template
315        (closure-template
316         (let ((a #f) (b #f))
317           (lambda (op)
318             ;; A is guaranteed to be a non-joined object, so NEXT is
319             ;; guaranteed to be NO-MORE-JOIN-LINKS.
320             (receive (method next) (dispatch a op)
321               (if method
322                   (values method b)
323                   (dispatch b op)))))))
324
325(define joined-tag (list 'joined))
326
327;; (define (joined? obj joined-tag)
328;;   (and (closure? obj)
329;;        (= 3 (closure-length obj))
330;;        (= 3 (vector-length
331;;              (closure-ref obj 1)))      ;(closure-env obj)
332;;        (eq? joined-tag (closure-ref obj 3))))
333
334(define joined?
335  (lap joined? ()
336       (protocol 2)
337       (stack-ref 1)
338       (stored-object-has-type? closure)
339       (jump-if-false lose)
340       (stack-ref 1)
341       (stored-object-length closure)
342       (push)
343       (literal 3)
344       (=)
345       (jump-if-false lose)
346       (stack-indirect+push 1 1)
347       (stored-object-length vector)
348       (push)
349       (literal 3)
350       (=)
351       (jump-if-false lose)
352       (stack-indirect 0 2)
353       (stack-ref+push 2)
354       (eq?)
355lose   (return)))
356
357(define (joined-lhs joined)
358  (vector-ref (closure-env joined) 0))
359
360(define (joined-rhs joined)
361  (vector-ref (closure-env joined) 1))
362
363(define no-more-join-links
364        (make-object #f (lambda (op)
365                          (values #f no-more-join-links))))
Note: See TracBrowser for help on using the repository browser.