1 | ; From '@' by Dan Muresan |
---|
2 | (define-syntax slot@ |
---|
3 | (syntax-rules (=) |
---|
4 | ((_ o) o) |
---|
5 | ((_ o slot = v) (slot-set! o 'slot v)) |
---|
6 | ((_ o slot . slots) (slot@ (slot-ref o 'slot) . slots)))) |
---|
7 | |
---|
8 | (define-syntax define-class |
---|
9 | (syntax-rules () |
---|
10 | [(_ name () slots) |
---|
11 | (define-class name (<object>) slots) ] |
---|
12 | [(_ name supers slots) |
---|
13 | (define-class name supers slots <class>) ] |
---|
14 | [(_ name () slots meta) |
---|
15 | (define-class name (<object>) slots meta) ] |
---|
16 | [(_ cname (supers ...) (slots ...) meta) |
---|
17 | (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) ) |
---|
18 | |
---|
19 | (define-syntax define-generic |
---|
20 | (syntax-rules () |
---|
21 | [(_ n class) (define n (make class 'name 'n))] |
---|
22 | [(_ n) (define n (make-generic 'n))] ) ) |
---|
23 | |
---|
24 | (define-syntax (define-method x r c) |
---|
25 | (let ((head (cadr x)) |
---|
26 | (body (cddr x)) |
---|
27 | (%add-global-method (r 'add-global-method)) |
---|
28 | (%make-method (r 'make-method)) |
---|
29 | (%lambda (r 'lambda)) |
---|
30 | (%list (r 'list)) |
---|
31 | (%<top> (r '<top>))) |
---|
32 | (##sys#check-syntax 'define-method head '(symbol . _)) |
---|
33 | (##sys#check-syntax 'define-method body '#(_ 1)) |
---|
34 | (let gather ([args (##sys#slot head 1)] |
---|
35 | [specs '()] |
---|
36 | [vars '()] ) |
---|
37 | (if (or (not (pair? args)) |
---|
38 | (memq (car args) '(#!optional #!key #!rest)) ) |
---|
39 | (let ([name (##sys#slot head 0)]) |
---|
40 | `(set! ,name |
---|
41 | (,%add-global-method |
---|
42 | (##core#global-ref ,name) |
---|
43 | ',name |
---|
44 | (,%list ,@(reverse specs)) |
---|
45 | ;; `call-next-method' not renamed: |
---|
46 | (,%lambda (call-next-method ,@(reverse vars) ,@args) ,@body) ) ) ) |
---|
47 | (let ([arg (##sys#slot args 0)]) |
---|
48 | (gather (##sys#slot args 1) |
---|
49 | (cons (if (pair? arg) (cadr arg) %<top>) specs) |
---|
50 | (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) ) ) |
---|
51 | |
---|
52 | ;; For system use in extending the set of "builtin" classes. |
---|
53 | |
---|
54 | (define-for-syntax (##tinyclos#make-classname-symbol str) |
---|
55 | (string->symbol (string-append "<" (##sys#strip-syntax str) ">")) ) |
---|
56 | |
---|
57 | (define-syntax (define-primitive-class x r c) |
---|
58 | (let ((name (cadr x)) |
---|
59 | (pred (caddr x)) |
---|
60 | (sclasses (cdddr x))) |
---|
61 | `(,(r 'define) ,(##tinyclos#make-classname-symbol name) |
---|
62 | (,(r 'new-primitive-class) ,name ,pred ,@sclasses)) )) |
---|
63 | |
---|
64 | (define-syntax (define-structure-class x r c) |
---|
65 | (let ((name (cadr x)) |
---|
66 | (tag (caddr x))) |
---|
67 | `(,(r 'define) ,(##tinyclos#make-classname-symbol name) |
---|
68 | (,(r 'new-structure-class) name (,(r 'quote) ,tag)) ))) |
---|
69 | |
---|
70 | (define-syntax (define-tagged-pointer-class x r c) |
---|
71 | (let ((name (cadr x)) |
---|
72 | (pred (caddr x))) |
---|
73 | `(,(r 'define) ,(##tinyclos#make-classname-symbol name) |
---|
74 | (,(r 'new-tagged-pointer-class) name (,(r 'quote) ,pred)) ))) |
---|
75 | |
---|
76 | (define-syntax (define-extended-procedure-class x r c) |
---|
77 | (let ((name (cadr x)) |
---|
78 | (pred (caddr x))) |
---|
79 | `(,(r 'define) ,(##tinyclos#make-classname-symbol name) |
---|
80 | (,(r 'new-extended-procedure-class) name (,(r 'quote) ,pred)) ))) |
---|
81 | |
---|
82 | ; |
---|
83 | ; A very simple CLOS-like language, embedded in Scheme, with a simple |
---|
84 | ; MOP. The features of the default base language are: |
---|
85 | ; |
---|
86 | ; * Classes, with instance slots, but no slot options. |
---|
87 | ; * Multiple-inheritance. |
---|
88 | ; * Generic functions with multi-methods and class specializers only. |
---|
89 | ; * Primary methods and call-next-method; no other method combination. |
---|
90 | ; * Uses Scheme's lexical scoping facilities as the class and generic |
---|
91 | ; function naming mechanism. Another way of saying this is that |
---|
92 | ; class, generic function and methods are first-class (meta)objects. |
---|
93 | ; |
---|
94 | ; While the MOP is simple, it is essentially equal in power to both MOPs |
---|
95 | ; in AMOP. This implementation is not at all optimized, but the MOP is |
---|
96 | ; designed so that it can be optimized. In fact, this MOP allows better |
---|
97 | ; optimization of slot access extenstions than those in AMOP. |
---|
98 | ; |
---|
99 | ; |
---|
100 | ; |
---|
101 | ; In addition to calling a generic, the entry points to the default base |
---|
102 | ; language are: |
---|
103 | ; |
---|
104 | ; (MAKE-CLASS list-of-superclasses list-of-slot-names) |
---|
105 | ; (MAKE-GENERIC) |
---|
106 | ; (MAKE-METHOD list-of-specializers procedure) |
---|
107 | ; (ADD-METHOD generic method) |
---|
108 | ; |
---|
109 | ; (MAKE class . initargs) |
---|
110 | ; (INITIALIZE instance initargs) ;Add methods to this, |
---|
111 | ; ;don't call it directly. |
---|
112 | ; |
---|
113 | ; (SLOT-REF object slot-name) |
---|
114 | ; (SLOT-SET! object slot-name new-value) |
---|
115 | ; |
---|
116 | ; |
---|
117 | ; So, for example, one might do (but only within this file! 'getl' is not exported): |
---|
118 | ; |
---|
119 | ; (define <position> (make-class (list <object>) (list 'x 'y))) |
---|
120 | ; (add-method initialize |
---|
121 | ; (make-method (list <position>) |
---|
122 | ; (lambda (call-next-method pos initargs) |
---|
123 | ; (for-each (lambda (initarg-name slot-name) |
---|
124 | ; (slot-set! pos slot-name (getl initargs initarg-name 0))) |
---|
125 | ; '(x y) |
---|
126 | ; '(x y))))) |
---|
127 | ; |
---|
128 | ; (set! p1 (make <position> 'x 1 'y 3)) |
---|
129 | ; |
---|
130 | ; |
---|
131 | ; |
---|
132 | ; NOTE! Do not use EQUAL? to compare objects! Use EQ? or some hand |
---|
133 | ; written procedure. Objects have a pointer to their class, |
---|
134 | ; and classes are circular structures, and ... |
---|
135 | ; |
---|
136 | ; |
---|
137 | ; |
---|
138 | ; The introspective part of the MOP looks like the following. Note that |
---|
139 | ; these are ordinary procedures, not generics. |
---|
140 | ; |
---|
141 | ; CLASS-OF |
---|
142 | ; |
---|
143 | ; CLASS-DIRECT-SUPERS |
---|
144 | ; CLASS-DIRECT-SLOTS |
---|
145 | ; CLASS-CPL |
---|
146 | ; CLASS-SLOTS |
---|
147 | ; |
---|
148 | ; GENERIC-METHODS |
---|
149 | ; |
---|
150 | ; METHOD-SPECIALIZERS |
---|
151 | ; METHOD-PROCEDURE |
---|
152 | ; |
---|
153 | ; |
---|
154 | ; The intercessory protocol looks like (generics in uppercase): |
---|
155 | ; |
---|
156 | ; make |
---|
157 | ; ALLOCATE-INSTANCE |
---|
158 | ; INITIALIZE (really a base-level generic) |
---|
159 | ; |
---|
160 | ; class initialization |
---|
161 | ; COMPUTE-CPL |
---|
162 | ; COMPUTE-SLOTS |
---|
163 | ; COMPUTE-GETTER-AND-SETTER |
---|
164 | ; |
---|
165 | ; add-method (Notice this is not a generic!) |
---|
166 | ; COMPUTE-APPLY-GENERIC |
---|
167 | ; COMPUTE-METHODS |
---|
168 | ; COMPUTE-METHOD-MORE-SPECIFIC? |
---|
169 | ; COMPUTE-APPLY-METHODS |
---|
170 | ; |
---|
171 | |
---|
172 | ;;; Aliases for sys stuff |
---|
173 | |
---|
174 | (define-inline (%car p) (##sys#slot p 0)) |
---|
175 | (define-inline (%cdr p) (##sys#slot p 1)) |
---|
176 | (define-inline (%cadr p) (%car (%cdr p))) |
---|
177 | (define-inline (%cddr p) (%cdr (%cdr p))) |
---|
178 | (define-inline (%set-car! p y) (##sys#setslot p 0 y)) |
---|
179 | (define-inline (%set-cdr! p y) (##sys#setslot p 1 y)) |
---|
180 | |
---|
181 | (define-inline (%string-length s) (##sys#size s)) |
---|
182 | |
---|
183 | (define-inline (%vector-ref v i) (##sys#slot v i)) |
---|
184 | (define-inline (%vector-set! v i x) (##sys#setslot v i x)) |
---|
185 | (define-inline (%vector-length v) (##sys#size v)) |
---|
186 | |
---|
187 | (define-syntax (%structure? x r c) |
---|
188 | (let ((?x (cadr x)) |
---|
189 | (?t (cddr x))) |
---|
190 | (if (null? ?t) |
---|
191 | `(##sys#generic-structure? ,?x) |
---|
192 | `(##sys#structure? ,?x ,(car ?t))))) |
---|
193 | |
---|
194 | (define-inline (%structure-ref r i) (##sys#slot r i)) |
---|
195 | (define-inline (%structure-set! r i x) (##sys#setslot r i x)) |
---|
196 | (define-inline (%structure-length r) (##sys#size r)) |
---|
197 | (define-inline (%structure-tag r) (##sys#slot r 0)) |
---|
198 | |
---|
199 | (define-inline (%closure-ref c i) (##sys#slot c i)) |
---|
200 | (define-inline (%closure-length c) (##sys#size c)) |
---|
201 | |
---|
202 | (define-inline (%tagged-pointer-data p) (##sys#slot p 1)) |
---|
203 | |
---|
204 | (define-inline (%null-pointer? p) (##sys#null-pointer? p)) |
---|
205 | |
---|
206 | (define-inline (%blob? x) (##sys#bytevector? x)) |
---|
207 | |
---|
208 | (define-inline (%immediate-value? x) (##sys#immediate? x)) |
---|
209 | |
---|
210 | (define-inline (%undefined? x) (##core#inline "C_undefinedp" x)) |
---|
211 | |
---|
212 | (define-inline (%unbound? x) (eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))) |
---|
213 | |
---|
214 | (define-inline (%pointer? x) (##core#inline "C_pointerp" x)) |
---|
215 | |
---|
216 | (define-inline (%tagged-pointer? x) (##core#inline "C_taggedpointerp" x)) |
---|
217 | |
---|
218 | (define-inline (%swig-pointer? x) (##core#inline "C_swigpointerp" x)) |
---|
219 | |
---|
220 | (define-inline (%locative? x) (##core#inline "C_locativep" x)) |
---|
221 | |
---|
222 | (define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x)) |
---|
223 | |
---|
224 | ;;; Support code |
---|
225 | |
---|
226 | (define-syntax (define-unique-object x r c) |
---|
227 | `(,(r 'define) ,(cadr x) (,(r 'gensym)) )) |
---|
228 | |
---|
229 | (define (filter-in f l) |
---|
230 | (let loop ([l l]) |
---|
231 | (cond [(null? l) '()] |
---|
232 | [else |
---|
233 | (let ([h (%car l )] |
---|
234 | [r (%cdr l)] ) |
---|
235 | (if (f h) |
---|
236 | ; Unlike SRFI-1 filter this doesn't share the undeleted longest tail |
---|
237 | #;(let ([t (loop r)]) (if (eq? r t) l (cons h t))) |
---|
238 | (cons h (loop r)) |
---|
239 | (loop r) ) ) ] ) ) ) |
---|
240 | |
---|
241 | (define fast-getl |
---|
242 | (foreign-lambda* scheme-object ((scheme-object initargs) (scheme-object name) (scheme-object def)) " |
---|
243 | while(initargs != C_SCHEME_END_OF_LIST) { |
---|
244 | if(name == C_block_item(initargs, 0)) { |
---|
245 | if((initargs = C_block_item(initargs, 1)) == C_SCHEME_END_OF_LIST) return(def); |
---|
246 | else return(C_block_item(initargs, 0)); |
---|
247 | } |
---|
248 | initargs = C_block_item(initargs, 1); |
---|
249 | } |
---|
250 | return(def);") ) |
---|
251 | |
---|
252 | (define-unique-object not-found-object) |
---|
253 | |
---|
254 | (define (getl initargs name . def) |
---|
255 | (let ([value (fast-getl initargs name not-found-object)]) |
---|
256 | (if (eq? value not-found-object) |
---|
257 | (optional def (##sys#error 'getl "cannot find item" name initargs)) |
---|
258 | value ) ) ) |
---|
259 | |
---|
260 | ; |
---|
261 | ; A simple topological sort. |
---|
262 | ; |
---|
263 | ; This is a fairly modified version of code I originally got from Anurag |
---|
264 | ; Mendhekar <anurag@moose.cs.indiana.edu>. |
---|
265 | ; |
---|
266 | |
---|
267 | (define (compute-std-cpl c get-direct-supers) |
---|
268 | |
---|
269 | (define-inline (every1 test lst) |
---|
270 | (let loop ([lst lst]) |
---|
271 | (or (null? lst) |
---|
272 | (and (test (%car lst)) |
---|
273 | (loop (%cdr lst)) ) ) ) ) |
---|
274 | |
---|
275 | (define (top-sort elements constraints tie-breaker) |
---|
276 | (let loop ((elements elements) |
---|
277 | (constraints constraints) |
---|
278 | (result '())) |
---|
279 | (if (null? elements) |
---|
280 | result |
---|
281 | (let ((can-go-in-now |
---|
282 | (filter-in |
---|
283 | (lambda (x) |
---|
284 | (every1 (lambda (constraint) |
---|
285 | (or (not (eq? (%cadr constraint) x)) |
---|
286 | (memq (%car constraint) result))) |
---|
287 | constraints)) |
---|
288 | elements))) |
---|
289 | (if (null? can-go-in-now) |
---|
290 | (##sys#error 'top-sort "invalid constraints") |
---|
291 | (let ((choice (if (null? (%cdr can-go-in-now)) |
---|
292 | (%car can-go-in-now) |
---|
293 | (tie-breaker result can-go-in-now)))) |
---|
294 | (loop (filter-in (lambda (x) (not (eq? x choice))) elements) |
---|
295 | ; Include all constraints |
---|
296 | #;(filter-in (lambda (x) (not (eq? (%cadr x) choice))) constraints) |
---|
297 | constraints |
---|
298 | (append result (list choice))))))) ) ) |
---|
299 | |
---|
300 | (define (std-tie-breaker get-supers) |
---|
301 | (lambda (partial-cpl min-elts) |
---|
302 | (let loop ((pcpl (reverse partial-cpl))) |
---|
303 | (let* ((current-elt (%car pcpl)) |
---|
304 | (ds-of-ce (get-supers current-elt)) |
---|
305 | (common (filter-in (cut memq <> ds-of-ce) min-elts))) |
---|
306 | (if (null? common) |
---|
307 | (let ([r (%cdr pcpl)]) |
---|
308 | (if (null? r) |
---|
309 | (##sys#error 'std-tie-breaker "nothing valid") |
---|
310 | (loop r)) ) |
---|
311 | (%car common)) ) ) ) ) |
---|
312 | |
---|
313 | (define (build-transitive-closure get-follow-ons) |
---|
314 | (lambda (x) |
---|
315 | (let track ((result '()) |
---|
316 | (pending (list x))) |
---|
317 | (if (null? pending) |
---|
318 | result |
---|
319 | (let ((next (%car pending))) |
---|
320 | (if (memq next result) |
---|
321 | (track result (%cdr pending)) |
---|
322 | (track (cons next result) |
---|
323 | (append (get-follow-ons next) |
---|
324 | (%cdr pending)))))) ) ) ) |
---|
325 | |
---|
326 | (define (build-constraints get-follow-ons) |
---|
327 | (lambda (x) |
---|
328 | (let loop ((elements ((build-transitive-closure get-follow-ons) x)) |
---|
329 | (this-one '()) |
---|
330 | (result '())) |
---|
331 | (if (or (null? this-one) (null? (%cdr this-one))) |
---|
332 | (if (null? elements) |
---|
333 | result |
---|
334 | (loop (%cdr elements) |
---|
335 | (cons (%car elements) |
---|
336 | (get-follow-ons (%car elements))) |
---|
337 | result)) |
---|
338 | (loop elements |
---|
339 | (%cdr this-one) |
---|
340 | (cons (list (%car this-one) (%cadr this-one)) |
---|
341 | result))) ) ) ) |
---|
342 | |
---|
343 | (top-sort ((build-transitive-closure get-direct-supers) c) |
---|
344 | ((build-constraints get-direct-supers) c) |
---|
345 | (std-tie-breaker get-direct-supers) ) ) |
---|
346 | |
---|
347 | ;;; Method cache support code: |
---|
348 | |
---|
349 | #> |
---|
350 | #define C_METHOD_CACHE_SIZE 8 |
---|
351 | <# |
---|
352 | |
---|
353 | (define-foreign-variable method-cache-size int "C_METHOD_CACHE_SIZE") |
---|
354 | |
---|
355 | (define method-caching-enabled #f) |
---|
356 | (define method-cache-tag #f) |
---|
357 | |
---|
358 | (define (make-method-cache) |
---|
359 | (cons method-cache-tag (make-vector (arithmetic-shift method-cache-size 1) #f)) ) |
---|
360 | |
---|
361 | (define method-cache-lookup |
---|
362 | (foreign-lambda* scheme-object ((scheme-object mcache) (scheme-object hash) (scheme-object classes)) " |
---|
363 | C_word v = C_block_item(mcache, 1); |
---|
364 | C_word clist, x, y; |
---|
365 | int free_index = -1; |
---|
366 | int i = ((C_unfix(hash) & (C_METHOD_CACHE_SIZE - 1)) << 1) & 0xffff, |
---|
367 | i0, i2; |
---|
368 | for(i0 = i;; i = i2) { |
---|
369 | clist = C_block_item(v, i); |
---|
370 | if(clist != C_SCHEME_FALSE) { |
---|
371 | x = classes; |
---|
372 | y = clist; |
---|
373 | while(x != C_SCHEME_END_OF_LIST && y != C_SCHEME_END_OF_LIST) { |
---|
374 | if(C_block_item(x, 0) != C_block_item(y, 0)) goto mismatch; |
---|
375 | else { |
---|
376 | x = C_block_item(x, 1); |
---|
377 | y = C_block_item(y, 1); |
---|
378 | } |
---|
379 | } |
---|
380 | if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST) |
---|
381 | return(C_block_item(v, i + 1)); |
---|
382 | else |
---|
383 | goto mismatch; |
---|
384 | } |
---|
385 | else if(free_index == -1) free_index = i; |
---|
386 | mismatch: |
---|
387 | i2 = (i + 2) & ((C_METHOD_CACHE_SIZE << 1) - 1); |
---|
388 | if(i2 == i0) return(free_index == -1 ? C_SCHEME_FALSE : C_fix(free_index)); |
---|
389 | }") ) |
---|
390 | |
---|
391 | ; |
---|
392 | ; Then, we need to build what, in a more real implementation, would be |
---|
393 | ; the interface to the memory subsystem: instances and entities. The |
---|
394 | ; former are used for instances of instances of <class>; the latter |
---|
395 | ; are used for instances of instances of <entity-class>. In this MOP, |
---|
396 | ; none of this is visible to base- or MOP-level programmers. |
---|
397 | ; |
---|
398 | ; (One might consider rewriting the definition of instances using |
---|
399 | ; define-record or something. It doesn't turn out to make it much |
---|
400 | ; simpler, at least not to me. It also breaks the nice parallelism |
---|
401 | ; with entities.) |
---|
402 | ; |
---|
403 | ; %allocate-instance, %allocate-entity, get-field, set-field!, and class-of are |
---|
404 | ; the normal interface, from the rest of the code, to the low-level memory |
---|
405 | ; system. |
---|
406 | ; |
---|
407 | ; One thing to take note of is that the protocol does not allow the user |
---|
408 | ; to add low-level instance representations. I have never seen a way to make |
---|
409 | ; that work. |
---|
410 | ; |
---|
411 | |
---|
412 | ; Instance |
---|
413 | |
---|
414 | (define the-slots-of-a-class ; |
---|
415 | '(direct-supers ;(class ...) |
---|
416 | direct-slots ;((name . options) ...) |
---|
417 | cpl ;(class ...) |
---|
418 | slots ;((name . options) ...) |
---|
419 | nfields ;an integer |
---|
420 | field-initializers ;(proc ...) |
---|
421 | getters-n-setters ;((slot-name getter . setter) ...) |
---|
422 | name) ) ;name |
---|
423 | |
---|
424 | ; structure: tag class cache direct-supers ... name |
---|
425 | (define-constant basic-class-instance-size 11) |
---|
426 | |
---|
427 | (define (%allocate-instance class nfields) |
---|
428 | (let ((instance (make-vector (+ nfields 3) #f))) |
---|
429 | (##core#inline "C_vector_to_structure" instance) |
---|
430 | (%structure-set! instance 0 'instance) |
---|
431 | (%structure-set! instance 1 class) |
---|
432 | instance)) |
---|
433 | |
---|
434 | (define-inline (%instance? x) |
---|
435 | (%structure? x 'instance)) |
---|
436 | |
---|
437 | (define-inline (%instance-class instance) |
---|
438 | (%structure-ref instance 1)) |
---|
439 | |
---|
440 | (define-inline (%set-instance-class! instance new-value) |
---|
441 | (%structure-set! instance 1 new-value)) |
---|
442 | |
---|
443 | (define-inline (%instance-cache-ref instance) |
---|
444 | (%structure-ref instance 2)) |
---|
445 | |
---|
446 | (define-inline (%instance-cache-set! instance x) |
---|
447 | (%structure-set! instance 2 x)) |
---|
448 | |
---|
449 | (define-inline (%instance-ref instance index) |
---|
450 | (%structure-ref instance (+ index 3))) |
---|
451 | |
---|
452 | (define-inline (%instance-set! instance index new-value) |
---|
453 | (%structure-set! instance (+ index 3) new-value)) |
---|
454 | |
---|
455 | (define-record-printer (instance x out) |
---|
456 | (print-object x out) ) |
---|
457 | |
---|
458 | ; Entity |
---|
459 | |
---|
460 | (define-unique-object entity-tag) |
---|
461 | |
---|
462 | (define %allocate-entity |
---|
463 | (let ([default-proc |
---|
464 | (lambda args |
---|
465 | (##sys#error '%allocate-entity "called entity without first setting proc"))] ) |
---|
466 | (lambda (class nfields name) |
---|
467 | (letrec ((entity-def (make-vector (+ nfields 5) #f)) |
---|
468 | (closure (lambda args (apply (%structure-ref entity-def 1) args)))) |
---|
469 | (##core#inline "C_vector_to_structure" entity-def) |
---|
470 | (%structure-set! entity-def 0 'entity) |
---|
471 | (%structure-set! entity-def 1 default-proc) |
---|
472 | (%structure-set! entity-def 2 class) |
---|
473 | (%structure-set! entity-def 3 name) |
---|
474 | ;; slot #4 is cache (defaults to #f) |
---|
475 | (let ([len (%closure-length closure)]) |
---|
476 | (let ([entity (make-vector (+ len 2))] ) |
---|
477 | (do ([i 1 (add1 i)]) |
---|
478 | ((>= i len) |
---|
479 | (%vector-set! entity i entity-def) |
---|
480 | (%vector-set! entity (add1 i) entity-tag) |
---|
481 | (##core#inline "C_vector_to_closure" entity) |
---|
482 | (##core#inline "C_copy_pointer" closure entity) |
---|
483 | entity) |
---|
484 | (%vector-set! entity i (%closure-ref closure i)) ) ) ) ) ) ) ) |
---|
485 | |
---|
486 | (define-inline (%entity? x) |
---|
487 | (and (procedure? x) |
---|
488 | (let ([len (%closure-length x)]) |
---|
489 | (and (> len 3) |
---|
490 | (eq? entity-tag (%closure-ref x (sub1 len))) ) ) ) ) |
---|
491 | |
---|
492 | (define-inline (%entity-def entity) |
---|
493 | (%closure-ref entity (- (%closure-length entity) 2)) ) |
---|
494 | |
---|
495 | (define-inline (%set-entity-proc! entity proc) |
---|
496 | (%structure-set! (%entity-def entity) 1 proc) ) |
---|
497 | |
---|
498 | (define-inline (%entity-class entity) |
---|
499 | (%structure-ref (%entity-def entity) 2) ) |
---|
500 | |
---|
501 | (define-inline (%entity-name entity) |
---|
502 | (%structure-ref (%entity-def entity) 3) ) |
---|
503 | |
---|
504 | (define-inline (%set-entity-name! entity x) |
---|
505 | (%structure-set! (%entity-def entity) 3 x) ) |
---|
506 | |
---|
507 | (define-inline (%entity-cache-ref entity) |
---|
508 | (%structure-ref (%entity-def entity) 4) ) |
---|
509 | |
---|
510 | (define-inline (%entity-cache-set! entity x) |
---|
511 | (%structure-set! (%entity-def entity) 4 x) ) |
---|
512 | |
---|
513 | (define-inline (%entity-ref entity index) |
---|
514 | (%structure-ref (%entity-def entity) (+ index 5)) ) |
---|
515 | |
---|
516 | (define-inline (%entity-set! entity index new-value) |
---|
517 | (%structure-set! (%entity-def entity) (+ index 5) new-value) ) |
---|
518 | |
---|
519 | (define-record-printer (entity x out) |
---|
520 | (print-object x out) ) |
---|
521 | |
---|
522 | ; Instance/Entity field accessors |
---|
523 | |
---|
524 | (define get-field |
---|
525 | (lambda (object field) |
---|
526 | (cond ((%instance? object) (%instance-ref object field)) |
---|
527 | ((%entity? object) (%entity-ref object field)) |
---|
528 | (else |
---|
529 | (##sys#signal-hook #:type-error 'get-field "can only get-field of instances and entities" object))))) |
---|
530 | |
---|
531 | (define set-field! |
---|
532 | (lambda (object field new-value) |
---|
533 | (cond ((%instance? object) (%instance-set! object field new-value)) |
---|
534 | ((%entity? object) (%entity-set! object field new-value)) |
---|
535 | (else |
---|
536 | (##sys#signal-hook #:type-error 'set-field! "can only set-field! of instances and entities" object))))) |
---|
537 | |
---|
538 | ; |
---|
539 | ; Note that this implementation of class-of assumes the name of the |
---|
540 | ; primitive classes that are set up later. |
---|
541 | ; |
---|
542 | |
---|
543 | ; Local namespace - all "exported" procedures are inline so |
---|
544 | ; defined in compilation unit top-level scope. |
---|
545 | |
---|
546 | (define (delete1! test lst) |
---|
547 | (let loop ((cpair lst) (ppair #f)) |
---|
548 | (cond ((null? cpair) lst ) |
---|
549 | ((test (%car cpair)) |
---|
550 | (if ppair |
---|
551 | (begin (%set-cdr! ppair (%cdr cpair)) lst) |
---|
552 | (%cdr cpair)) ) |
---|
553 | (else (loop (%cdr cpair) cpair) ) ) ) ) |
---|
554 | |
---|
555 | (define (any1 test lst) |
---|
556 | (let loop ([lst lst]) |
---|
557 | (and (not (null? lst)) |
---|
558 | (or (test (%car lst)) |
---|
559 | (loop (%cdr lst)) ) ) ) ) |
---|
560 | |
---|
561 | ; Class-of extension helpers |
---|
562 | ; |
---|
563 | ; Implemented as a map: "test" <-> "class" |
---|
564 | ; |
---|
565 | ; tst - test value; symbol or procedure |
---|
566 | ; cls - class |
---|
567 | ; prd - predicate? obj |
---|
568 | ; eql - symbol eq? obj |
---|
569 | |
---|
570 | (define-inline (clsmapelm-tst cme) |
---|
571 | (%car cme) ) |
---|
572 | |
---|
573 | (define-inline (clsmapelm-cls cme) |
---|
574 | (%cdr cme) ) |
---|
575 | |
---|
576 | (define-inline (clsmapelm-tst-set! cme tst) |
---|
577 | (%set-car! cme tst) ) |
---|
578 | |
---|
579 | (define-inline (clsmapelm-cls-set! cme cls) |
---|
580 | (%set-cdr! cme cls) ) |
---|
581 | |
---|
582 | (define-inline (clsmap-tst? tst) |
---|
583 | (or (procedure? tst) (symbol? tst)) ) |
---|
584 | |
---|
585 | (define-inline (clsmapelm-cls-of/prd? cme tst) |
---|
586 | ((clsmapelm-tst cme) tst) ) |
---|
587 | |
---|
588 | (define-inline (clsmapelm-cls-of/eql? cme tst) |
---|
589 | (eq? tst (clsmapelm-tst cme)) ) |
---|
590 | |
---|
591 | (define-inline (clsmapelm-cls-of/prd cme tst) |
---|
592 | (and (clsmapelm-cls-of/prd? cme tst) |
---|
593 | (clsmapelm-cls cme)) ) |
---|
594 | |
---|
595 | (define-inline (clsmapelm-cls-of/eql cme tst) |
---|
596 | (and (clsmapelm-cls-of/eql? cme tst) |
---|
597 | (clsmapelm-cls cme)) ) |
---|
598 | |
---|
599 | (define-inline (clsmap-add cm tst cls) |
---|
600 | (cons (cons tst cls) cm) ) |
---|
601 | |
---|
602 | (define clsmap-update |
---|
603 | (lambda (cm tst cls) |
---|
604 | (let ((cme (any1 (cut clsmapelm-cls-of/eql? <> tst) cm))) |
---|
605 | (if cme |
---|
606 | (begin (clsmapelm-tst-set! cme tst) (clsmapelm-cls-set! cme cls) cm) |
---|
607 | (clsmap-add cm tst cls) ) ) )) |
---|
608 | |
---|
609 | (define clsmap-cls-of/prd |
---|
610 | (lambda (cm tst) |
---|
611 | (any1 (cut clsmapelm-cls-of/prd <> tst) cm) )) |
---|
612 | |
---|
613 | (define clsmap-cls-of/eql |
---|
614 | (lambda (cm tst) |
---|
615 | (any1 (cut clsmapelm-cls-of/eql <> tst) cm) )) |
---|
616 | |
---|
617 | (define clsmap-del/tst |
---|
618 | (lambda (cm tst) |
---|
619 | (delete1! (cut clsmapelm-cls-of/eql? <> tst) cm) )) |
---|
620 | |
---|
621 | (define clsmap-del/cls |
---|
622 | (lambda (cm cls) |
---|
623 | (delete1! (lambda (cme) (eq? cls (clsmapelm-cls cme))) cm) )) |
---|
624 | |
---|
625 | ; Primitive class-of extensions |
---|
626 | |
---|
627 | (define *primitive-class-map* '()) |
---|
628 | |
---|
629 | (define-inline (primitive-class-of x) |
---|
630 | (or (clsmap-cls-of/prd *primitive-class-map* x) |
---|
631 | #;<object>) ) |
---|
632 | |
---|
633 | (define-inline (delete-primitive-class-of cls-or-tst) |
---|
634 | (set! *primitive-class-map* |
---|
635 | (if (clsmap-tst? cls-or-tst) |
---|
636 | (clsmap-del/tst *primitive-class-map* cls-or-tst) |
---|
637 | (clsmap-del/cls *primitive-class-map* cls-or-tst))) ) |
---|
638 | |
---|
639 | (define-inline (update-primitive-class-of prd cls) |
---|
640 | (set! *primitive-class-map* (clsmap-update *primitive-class-map* prd cls)) ) |
---|
641 | |
---|
642 | ; Structure class-of extensions |
---|
643 | |
---|
644 | (define *structure-class-map* '()) |
---|
645 | |
---|
646 | (define-inline (structure-class-of x) |
---|
647 | (or (clsmap-cls-of/eql *structure-class-map* x) |
---|
648 | <structure>) ) |
---|
649 | |
---|
650 | (define-inline (delete-structure-class-of cls-or-tst) |
---|
651 | (set! *structure-class-map* |
---|
652 | (if (clsmap-tst? cls-or-tst) |
---|
653 | (clsmap-del/tst *structure-class-map* cls-or-tst) |
---|
654 | (clsmap-del/cls *structure-class-map* cls-or-tst))) ) |
---|
655 | |
---|
656 | (define-inline (update-structure-class-of tag cls) |
---|
657 | (set! *structure-class-map* (clsmap-update *structure-class-map* tag cls)) ) |
---|
658 | |
---|
659 | ; Tagged-pointer class-of extensions |
---|
660 | |
---|
661 | (define *tagged-pointer-class-map* '()) |
---|
662 | |
---|
663 | (define-inline (tagged-pointer-class-of x) |
---|
664 | (or (clsmap-cls-of/eql *tagged-pointer-class-map* (%tagged-pointer-data x)) |
---|
665 | <tagged-pointer>) ) |
---|
666 | |
---|
667 | (define-inline (delete-tagged-pointer-class-of cls-or-tst) |
---|
668 | (set! *tagged-pointer-class-map* |
---|
669 | (if (clsmap-tst? cls-or-tst) |
---|
670 | (clsmap-del/tst *tagged-pointer-class-map* cls-or-tst) |
---|
671 | (clsmap-del/cls *tagged-pointer-class-map* cls-or-tst))) ) |
---|
672 | |
---|
673 | (define-inline (update-tagged-pointer-class-of tag cls) |
---|
674 | (set! *tagged-pointer-class-map* (clsmap-update *tagged-pointer-class-map* tag cls)) ) |
---|
675 | |
---|
676 | ; Extended-procedure class-of extensions |
---|
677 | |
---|
678 | (define *extended-procedure-class-map* '()) |
---|
679 | (define xproc-tag (vector 'extended)) |
---|
680 | |
---|
681 | (define-inline (extended-procedure-lambda-decoration x) |
---|
682 | (##sys#lambda-decoration x (lambda (x) (and (pair? x) (equal? xproc-tag (%car x))))) ) |
---|
683 | |
---|
684 | (define-inline (procedure-class-of x) |
---|
685 | (or (and-let* ([d (extended-procedure-lambda-decoration x)]) |
---|
686 | (clsmap-cls-of/prd *extended-procedure-class-map* (%cdr d)) ) |
---|
687 | <procedure>) ) |
---|
688 | |
---|
689 | (define-inline (delete-extended-procedure-class-of cls-or-tst) |
---|
690 | (set! *extended-procedure-class-map* |
---|
691 | (if (clsmap-tst? cls-or-tst) |
---|
692 | (clsmap-del/tst *extended-procedure-class-map* cls-or-tst) |
---|
693 | (clsmap-del/cls *extended-procedure-class-map* cls-or-tst))) ) |
---|
694 | |
---|
695 | (define-inline (update-extended-procedure-class-of prd cls) |
---|
696 | (set! *extended-procedure-class-map* (clsmap-update *extended-procedure-class-map* prd cls)) ) |
---|
697 | |
---|
698 | ; |
---|
699 | |
---|
700 | (define (class-of x) |
---|
701 | (cond [(%unbound? x) (##sys#error 'class-of "unbound object")] |
---|
702 | [(null? x) <null>] |
---|
703 | [(fixnum? x) <exact>] |
---|
704 | [(boolean? x) <boolean>] |
---|
705 | [(char? x) <char>] |
---|
706 | [(eof-object? x) <end-of-file>] |
---|
707 | [(%undefined? x) <void>] |
---|
708 | [(%immediate-value? x) (##sys#error 'class-of "unidentified immediate object - cannot infer class" x)] |
---|
709 | [(flonum? x) <inexact>] |
---|
710 | [(integer? x) <integer>] |
---|
711 | [(symbol? x) <symbol>] |
---|
712 | [(%instance? x) (%instance-class x)] |
---|
713 | [(%entity? x) (%entity-class x)] |
---|
714 | [(vector? x) <vector>] |
---|
715 | [(pair? x) <pair>] |
---|
716 | [(string? x) <string>] |
---|
717 | [(procedure? x) (procedure-class-of x)] |
---|
718 | [(port? x) (if (input-port? x) <input-port> <output-port>)] |
---|
719 | [(%blob? x) <blob>] |
---|
720 | [(%pointer? x) <pointer>] |
---|
721 | [(%tagged-pointer? x) (tagged-pointer-class-of x)] |
---|
722 | [(%swig-pointer? x) <swig-pointer>] |
---|
723 | [(%locative? x) <locative>] |
---|
724 | [(%structure? x) |
---|
725 | (case (%structure-tag x) |
---|
726 | [(environment) <environment>] |
---|
727 | [(array) <array>] |
---|
728 | [(hash-table) <hash-table>] |
---|
729 | [(queue) <queue>] |
---|
730 | [(condition) <condition>] |
---|
731 | [(condition-variable) <condition-variable>] |
---|
732 | [(char-set) <char-set>] |
---|
733 | [(time) <time>] |
---|
734 | [(lock) <lock>] |
---|
735 | [(mmap) <mmap>] |
---|
736 | [(promise) <promise>] |
---|
737 | [(u8vector) <u8vector>] |
---|
738 | [(s8vector) <s8vector>] |
---|
739 | [(u16vector) <u16vector>] |
---|
740 | [(s16vector) <s16vector>] |
---|
741 | [(u32vector) <u32vector>] |
---|
742 | [(s32vector) <s32vector>] |
---|
743 | [(f32vector) <f32vector>] |
---|
744 | [(f64vector) <f64vector>] |
---|
745 | [(tcp-listener) <tcp-listener>] |
---|
746 | [(thread) <thread>] |
---|
747 | [(mutex) <mutex>] |
---|
748 | [(continuation) <continuation>] |
---|
749 | [(read-table) <read-table>] |
---|
750 | [(regexp) <regexp>] |
---|
751 | [else (structure-class-of x)] ) ] |
---|
752 | [(primitive-class-of x)] |
---|
753 | [else |
---|
754 | (##sys#error 'class-of "unidentified primitive object - cannot infer class" x) ] ) ) |
---|
755 | |
---|
756 | ; |
---|
757 | ; Now we can get down to business. First, we initialize the braid. |
---|
758 | ; |
---|
759 | ; For Bootstrapping, we define an early version of MAKE. It will be |
---|
760 | ; changed to the real version later on. String search for ``set! make''. |
---|
761 | ; |
---|
762 | |
---|
763 | (randomize) |
---|
764 | |
---|
765 | (define (make class . initargs) |
---|
766 | (cond ((or (eq? class <class>) |
---|
767 | (eq? class <entity-class>)) |
---|
768 | (let* ((new (%allocate-instance class (length the-slots-of-a-class))) |
---|
769 | (dsupers (fast-getl initargs 'direct-supers '())) |
---|
770 | (name (fast-getl initargs 'name "(anonymous)")) |
---|
771 | (dslots (map list (fast-getl initargs 'direct-slots '()))) |
---|
772 | (cpl (let loop ((sups dsupers) (so-far (list new))) |
---|
773 | (if (null? sups) |
---|
774 | (reverse so-far) |
---|
775 | (let ([cls (%car sups)]) |
---|
776 | (loop (class-direct-supers cls) (cons cls so-far)))))) |
---|
777 | (slots (apply append dslots (map class-direct-slots (%cdr cpl)))) |
---|
778 | (nfields 0) |
---|
779 | (field-initializers '()) |
---|
780 | (allocator |
---|
781 | (lambda (init) |
---|
782 | (let ((f nfields)) |
---|
783 | (set! nfields (add1 nfields)) |
---|
784 | (set! field-initializers |
---|
785 | (cons init field-initializers)) |
---|
786 | (values (lambda (o) (get-field o f)) |
---|
787 | (lambda (o n) (set-field! o f n)))))) |
---|
788 | (getters-n-setters |
---|
789 | (map (lambda (s) |
---|
790 | (cons (%car s) |
---|
791 | (call-with-values (lambda () (allocator (lambda () (void)))) cons) ) ) |
---|
792 | slots))) |
---|
793 | (##tinyclos#slot-set! new 'direct-supers dsupers) |
---|
794 | (##tinyclos#slot-set! new 'direct-slots dslots) |
---|
795 | (##tinyclos#slot-set! new 'cpl cpl) |
---|
796 | (##tinyclos#slot-set! new 'slots slots) |
---|
797 | (##tinyclos#slot-set! new 'nfields nfields) |
---|
798 | (##tinyclos#slot-set! new 'field-initializers (reverse field-initializers)) |
---|
799 | (##tinyclos#slot-set! new 'getters-n-setters getters-n-setters) |
---|
800 | (##tinyclos#slot-set! new 'name name) |
---|
801 | (%instance-cache-set! new (%random-fixnum #x10000)) |
---|
802 | new)) |
---|
803 | ((eq? class <generic>) |
---|
804 | (let ([new (%allocate-entity class (length (class-slots class)) |
---|
805 | (fast-getl initargs 'name "(unnamed)") ) ] ) |
---|
806 | (##tinyclos#slot-set! new 'methods '()) |
---|
807 | new)) |
---|
808 | ((eq? class <method>) |
---|
809 | (let ((new (%allocate-instance class (length (class-slots class))))) |
---|
810 | (##tinyclos#slot-set! new 'specializers (getl initargs 'specializers)) |
---|
811 | (##tinyclos#slot-set! new 'procedure (getl initargs 'procedure)) |
---|
812 | new)) |
---|
813 | (else |
---|
814 | (##sys#error "bootstrap make: unknown class" class)) ) ) |
---|
815 | |
---|
816 | ; |
---|
817 | ; These are the real versions of slot-ref and slot-set!. Because of the |
---|
818 | ; way the new slot access protocol works, with no generic call inline, |
---|
819 | ; they can be defined up front like this. Cool eh? |
---|
820 | ; |
---|
821 | |
---|
822 | (define (##tinyclos#slot-ref object slot-name) |
---|
823 | ; if true, then this is an instance of <class>, with no additional slots |
---|
824 | (if (and (%instance? object) (%instance-cache-ref object)) |
---|
825 | (%instance-ref |
---|
826 | object |
---|
827 | (case slot-name |
---|
828 | [(direct-supers) 0] |
---|
829 | [(direct-slots) 1] |
---|
830 | [(cpl) 2] |
---|
831 | [(slots) 3] |
---|
832 | [(nfields) 4] |
---|
833 | [(field-initializers) 5] |
---|
834 | [(getters-n-setters) 6] |
---|
835 | [(name) 7] |
---|
836 | [else (##sys#error "unknown basic slot-name" slot-name)] ) ) |
---|
837 | (let* ((info (lookup-slot-info (class-of object) slot-name)) |
---|
838 | (getter (%car info))) |
---|
839 | (getter object))) ) |
---|
840 | |
---|
841 | (define (##tinyclos#slot-set! object slot-name new-value) |
---|
842 | (let* ((info (lookup-slot-info (class-of object) slot-name)) |
---|
843 | (setter (%cdr info)) ) |
---|
844 | (setter object new-value)) ) |
---|
845 | |
---|
846 | (define slot-ref (getter-with-setter ##tinyclos#slot-ref ##tinyclos#slot-set!)) |
---|
847 | (define slot-set! ##tinyclos#slot-set!) |
---|
848 | |
---|
849 | (define (lookup-slot-info class slot-name) |
---|
850 | (let* ((getters-n-setters |
---|
851 | (if (eq? class <class>) ;* This grounds out |
---|
852 | getters-n-setters-for-class ;* the slot-ref tower. |
---|
853 | (##tinyclos#slot-ref class 'getters-n-setters))) |
---|
854 | (entry (assq slot-name getters-n-setters))) |
---|
855 | (if entry |
---|
856 | (%cdr entry) |
---|
857 | (##sys#error "no slot in instances of class" slot-name class) ) ) ) |
---|
858 | |
---|
859 | ; |
---|
860 | ; Given that the early version of MAKE is allowed to call accessors on |
---|
861 | ; class metaobjects, the definitions for them come here, before the |
---|
862 | ; actual class definitions, which are coming up right afterwards. |
---|
863 | ; |
---|
864 | |
---|
865 | (define (class-direct-slots class) |
---|
866 | (##tinyclos#slot-ref class 'direct-slots) ) |
---|
867 | (define (class-direct-supers class) |
---|
868 | (##tinyclos#slot-ref class 'direct-supers)) |
---|
869 | (define (class-slots class) |
---|
870 | (##tinyclos#slot-ref class 'slots) ) |
---|
871 | |
---|
872 | (define (class-name class) |
---|
873 | (##tinyclos#slot-ref class 'name)) |
---|
874 | |
---|
875 | (define (generic-methods generic) |
---|
876 | (##tinyclos#slot-ref generic 'methods) ) |
---|
877 | |
---|
878 | (define (method-specializers method) |
---|
879 | (##tinyclos#slot-ref method 'specializers) ) |
---|
880 | (define (method-procedure method) |
---|
881 | (##tinyclos#slot-ref method 'procedure) ) |
---|
882 | |
---|
883 | (define (class-cpl class) |
---|
884 | (##tinyclos#slot-ref class 'cpl) ) |
---|
885 | |
---|
886 | ;;; Inline procedures inside this module only: |
---|
887 | |
---|
888 | (eval-when (compile) |
---|
889 | (define-syntax define-inline-accessor |
---|
890 | (syntax-rules () |
---|
891 | ((_ name slot) |
---|
892 | (define-syntax name |
---|
893 | (syntax-rules () |
---|
894 | ((_ class) (slot-ref class 'slot))))))) |
---|
895 | (define-inline-accessor class-direct-slots direct-slots) |
---|
896 | (define-inline-accessor class-direct-supers direct-supers) |
---|
897 | (define-inline-accessor class-slots slots) |
---|
898 | (define-inline-accessor class-name name) |
---|
899 | (define-inline-accessor generic-methods methods) |
---|
900 | (define-inline-accessor method-specializers specializers) |
---|
901 | (define-inline-accessor method-procedure procedure) |
---|
902 | (define-inline-accessor class-cpl cpl)) |
---|
903 | |
---|
904 | ; |
---|
905 | ; The next 7 clusters define the 6 initial classes. It takes 7 to 6 |
---|
906 | ; because the first and fourth both contribute to <class>. |
---|
907 | ; |
---|
908 | |
---|
909 | (define getters-n-setters-for-class ;see lookup-slot-info |
---|
910 | (let loop ([lst the-slots-of-a-class] [i 0]) |
---|
911 | (if (null? lst) |
---|
912 | '() |
---|
913 | (cons (cons (%car lst) |
---|
914 | (cons (lambda (o) (%instance-ref o i)) |
---|
915 | (lambda (o n) (%instance-set! o i n)) ) ) |
---|
916 | (loop (%cdr lst) (add1 i)) ) ) ) ) |
---|
917 | |
---|
918 | (define <class> (%allocate-instance #f (length the-slots-of-a-class))) |
---|
919 | (%set-instance-class! <class> <class>) |
---|
920 | |
---|
921 | (define <top> (make <class> |
---|
922 | 'direct-supers '() |
---|
923 | 'direct-slots '() |
---|
924 | 'name "top")) |
---|
925 | |
---|
926 | (define <object> (make <class> |
---|
927 | 'direct-supers (list <top>) |
---|
928 | 'direct-slots '() |
---|
929 | 'name "object")) |
---|
930 | |
---|
931 | ; |
---|
932 | ; This cluster, together with the first cluster above that defines |
---|
933 | ; <class> and sets its class, have the effect of: |
---|
934 | ; |
---|
935 | ; (define <class> |
---|
936 | ; (make <class> |
---|
937 | ; 'direct-supers (list <object>) |
---|
938 | ; 'direct-slots (list 'direct-supers ...))) |
---|
939 | ; |
---|
940 | |
---|
941 | (%instance-set! <class> 0 (list <object>)) ;d supers |
---|
942 | (%instance-set! <class> 1 (map list the-slots-of-a-class)) ;d slots |
---|
943 | (%instance-set! <class> 2 (list <class> <object> <top>)) ;cpl |
---|
944 | (%instance-set! <class> 3 (map list the-slots-of-a-class)) ;slots |
---|
945 | (%instance-set! <class> 4 (length the-slots-of-a-class)) ;nfields |
---|
946 | (%instance-set! <class> 5 (map (lambda (s) ;field-ini.. |
---|
947 | (lambda () (void))) |
---|
948 | the-slots-of-a-class)) |
---|
949 | (%instance-set! <class> 6 '()) |
---|
950 | (%instance-set! <class> 7 'class) |
---|
951 | (%instance-cache-set! <class> (%random-fixnum #x10000)) |
---|
952 | |
---|
953 | (define <procedure-class> (make <class> |
---|
954 | 'direct-supers (list <class>) |
---|
955 | 'direct-slots '() |
---|
956 | 'name "procedure-class")) |
---|
957 | |
---|
958 | (define <entity-class> (make <class> |
---|
959 | 'direct-supers (list <procedure-class>) |
---|
960 | 'direct-slots '() |
---|
961 | 'name "entity-class")) |
---|
962 | |
---|
963 | (define <generic> (make <entity-class> |
---|
964 | 'direct-supers (list <object>) |
---|
965 | 'direct-slots (list 'methods) |
---|
966 | 'name "generic")) |
---|
967 | |
---|
968 | (define <method> (make <class> |
---|
969 | 'direct-supers (list <object>) |
---|
970 | 'direct-slots (list 'specializers 'procedure) |
---|
971 | 'name "method")) |
---|
972 | |
---|
973 | ; |
---|
974 | ; These are the convenient syntax we expose to the base-level user. |
---|
975 | ; |
---|
976 | |
---|
977 | (define (make-class direct-supers direct-slots . name) |
---|
978 | (make <class> |
---|
979 | 'direct-supers direct-supers |
---|
980 | 'direct-slots direct-slots |
---|
981 | 'name (optional name "(anonymous)")) ) |
---|
982 | |
---|
983 | (define (make-generic . name) |
---|
984 | (make <generic> |
---|
985 | 'name (optional name "(unnamed)")) ) |
---|
986 | |
---|
987 | (define (make-method specializers procedure) |
---|
988 | (make <method> |
---|
989 | 'specializers specializers |
---|
990 | 'procedure procedure) ) |
---|
991 | |
---|
992 | ; |
---|
993 | ; The initialization protocol |
---|
994 | ; |
---|
995 | |
---|
996 | (define initialize (make-generic "initialize")) |
---|
997 | |
---|
998 | ; |
---|
999 | ; The instance structure protocol. |
---|
1000 | ; |
---|
1001 | |
---|
1002 | (define allocate-instance (make-generic "allocate-instance")) |
---|
1003 | (define compute-getter-and-setter (make-generic "compute-getter-and-setter")) |
---|
1004 | |
---|
1005 | ; |
---|
1006 | ; The class initialization protocol. |
---|
1007 | ; |
---|
1008 | |
---|
1009 | (define compute-cpl (make-generic "compute-cpl")) |
---|
1010 | (define compute-slots (make-generic "compute-slots")) |
---|
1011 | |
---|
1012 | ; |
---|
1013 | ; The generic invocation protocol. |
---|
1014 | ; |
---|
1015 | |
---|
1016 | (define compute-apply-generic (make-generic "compute-apply-generic")) |
---|
1017 | (define compute-methods (make-generic "compute-methods")) |
---|
1018 | (define compute-method-more-specific? (make-generic "compute-method-more-specific?")) |
---|
1019 | (define compute-apply-methods (make-generic "compute-apply-methods")) |
---|
1020 | |
---|
1021 | ; |
---|
1022 | ; The next thing to do is bootstrap generic functions. |
---|
1023 | ; |
---|
1024 | |
---|
1025 | (define generic-invocation-generics (list compute-apply-generic |
---|
1026 | compute-methods |
---|
1027 | compute-method-more-specific? |
---|
1028 | compute-apply-methods)) |
---|
1029 | |
---|
1030 | (define (add-method generic method) |
---|
1031 | (##tinyclos#slot-set! |
---|
1032 | generic |
---|
1033 | 'methods |
---|
1034 | (let* ([ms1 (method-specializers method)] |
---|
1035 | [l1 (length ms1)] ) |
---|
1036 | (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)]) |
---|
1037 | (if (null? methods) |
---|
1038 | (list method) |
---|
1039 | (let* ([mm (%car methods)] |
---|
1040 | [ms2 (method-specializers mm)] |
---|
1041 | [l2 (length ms2)]) |
---|
1042 | (cond ((> l1 l2) |
---|
1043 | (cons mm (filter-in-method (%cdr methods)))) |
---|
1044 | ((< l1 l2) |
---|
1045 | (cons method methods)) |
---|
1046 | (else |
---|
1047 | (let check-method ([ms1 ms1] |
---|
1048 | [ms2 ms2]) |
---|
1049 | (cond ((and (null? ms1) (null? ms2)) |
---|
1050 | (cons method (%cdr methods))) ;; skip the method already in the generic |
---|
1051 | ((eq? (%car ms1) (%car ms2)) |
---|
1052 | (check-method (%cdr ms1) (%cdr ms2))) |
---|
1053 | (else |
---|
1054 | (cons mm (filter-in-method (%cdr methods))))))))))))) |
---|
1055 | (if (memq generic generic-invocation-generics) |
---|
1056 | (set! method-cache-tag (vector)) |
---|
1057 | (%entity-cache-set! generic #f) ) |
---|
1058 | (%set-entity-proc! generic (compute-apply-generic generic)) ) |
---|
1059 | |
---|
1060 | ; |
---|
1061 | ; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls |
---|
1062 | ; the other generics in the generic invocation protocol. Two, related, |
---|
1063 | ; problems come up. A chicken and egg problem and a infinite regress |
---|
1064 | ; problem. |
---|
1065 | ; |
---|
1066 | ; In order to add our first method to COMPUTE-APPLY-GENERIC, we need |
---|
1067 | ; something sitting there, so it can be called. The first definition |
---|
1068 | ; below does that. |
---|
1069 | ; |
---|
1070 | ; Then, the second definition solves both the infinite regress and the |
---|
1071 | ; not having enough of the protocol around to build itself problem the |
---|
1072 | ; same way: it special cases invocation of generics in the invocation |
---|
1073 | ; protocol. |
---|
1074 | ; |
---|
1075 | ; |
---|
1076 | |
---|
1077 | (%set-entity-proc! compute-apply-generic |
---|
1078 | (lambda (generic) ;The ONE time this is called |
---|
1079 | ;it doesn't get cnm. |
---|
1080 | (lambda args |
---|
1081 | (apply (method-procedure (car (generic-methods generic))) |
---|
1082 | #f args)))) ;But, the ONE time it is run, |
---|
1083 | ;it needs to pass a dummy |
---|
1084 | ;value for cnm! |
---|
1085 | |
---|
1086 | (let ([symbol-vector (vector 'instance entity-tag)]) |
---|
1087 | |
---|
1088 | ; Compute class ID from object |
---|
1089 | (define hash-arg-list |
---|
1090 | (foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) " |
---|
1091 | C_word tag, h, x; |
---|
1092 | int n, i, j, len = 0; |
---|
1093 | for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) { |
---|
1094 | x = C_block_item(args, 0); |
---|
1095 | if(C_immediatep(x)) { |
---|
1096 | switch(x) { |
---|
1097 | case C_SCHEME_END_OF_LIST: i += 1; break; |
---|
1098 | case C_SCHEME_TRUE: |
---|
1099 | case C_SCHEME_FALSE: i += 3; break; |
---|
1100 | case C_SCHEME_END_OF_FILE: i += 7; break; |
---|
1101 | case C_SCHEME_UNDEFINED: i += 5; break; |
---|
1102 | default: |
---|
1103 | if(x & C_FIXNUM_BIT) i += 2; |
---|
1104 | else i += 4; |
---|
1105 | } |
---|
1106 | } |
---|
1107 | else { |
---|
1108 | h = C_header_bits(x); |
---|
1109 | switch(h) { |
---|
1110 | case C_STRUCTURE_TYPE: |
---|
1111 | tag = C_block_item(x, 0); |
---|
1112 | if(tag == C_block_item(svector, 0)) { /* instance */ |
---|
1113 | if((tag = C_block_item(C_block_item(x, 1), 2)) != C_SCHEME_FALSE) i += C_unfix(tag); |
---|
1114 | else i += C_header_size(x) << 4; |
---|
1115 | } |
---|
1116 | else i += 17; |
---|
1117 | break; |
---|
1118 | case C_CLOSURE_TYPE: |
---|
1119 | n = C_header_size(x); |
---|
1120 | if(n > 3 && C_block_item(svector, 1) == C_block_item(x, n - 1)) { |
---|
1121 | if((tag = C_block_item(C_block_item(C_block_item(x, n - 2), 2), 2)) != C_SCHEME_FALSE) i += C_unfix(tag); |
---|
1122 | else i += 13; |
---|
1123 | } |
---|
1124 | break; |
---|
1125 | case C_SYMBOL_TYPE: i += 8; break; |
---|
1126 | case C_BYTEVECTOR_TYPE: i += 16; break; |
---|
1127 | case C_VECTOR_TYPE: i += 9; break; |
---|
1128 | case C_PAIR_TYPE: i += 10; break; |
---|
1129 | case C_FLONUM_TYPE: i += 11; break; |
---|
1130 | case C_STRING_TYPE: i += 12; break; |
---|
1131 | case C_PORT_TYPE: i += C_block_item(x, 1) ? 15 : 14; break; |
---|
1132 | default: i += 255; |
---|
1133 | } |
---|
1134 | } |
---|
1135 | ++len; |
---|
1136 | } |
---|
1137 | return((i + len) & (C_METHOD_CACHE_SIZE - 1));") ) |
---|
1138 | |
---|
1139 | (add-method compute-apply-generic |
---|
1140 | (make-method (list <generic>) |
---|
1141 | (lambda (call-next-method generic) |
---|
1142 | (lambda args |
---|
1143 | (let ([mc (%entity-cache-ref generic)]) |
---|
1144 | (when (or (not mc) (not (eq? method-cache-tag (%car mc)))) |
---|
1145 | (set! mc (make-method-cache)) |
---|
1146 | (%entity-cache-set! generic mc) ) |
---|
1147 | (let* ([classes (and method-caching-enabled (map class-of args))] |
---|
1148 | [key (and classes (hash-arg-list args symbol-vector))] |
---|
1149 | [e (and classes (method-cache-lookup mc key classes))] ) |
---|
1150 | ;(unless (##sys#immediate? e) (print (%entity-name generic) ": " key)) |
---|
1151 | (if (not (##sys#immediate? e)) |
---|
1152 | (e args) |
---|
1153 | (let ([cam |
---|
1154 | (if (and (memq generic generic-invocation-generics) |
---|
1155 | (memq (car args) generic-invocation-generics)) |
---|
1156 | (let ([proc |
---|
1157 | (method-procedure |
---|
1158 | ; select the first method of one argument |
---|
1159 | (let loop ([lis (generic-methods generic)]) |
---|
1160 | (if (null? lis) |
---|
1161 | (##sys#error "cannot find original compute-apply-generic") |
---|
1162 | (let* ([h (%car lis)] |
---|
1163 | [ms (method-specializers h)]) |
---|
1164 | (if (= 1 (length ms)) |
---|
1165 | h |
---|
1166 | (loop (%cdr lis))))))) ] ) |
---|
1167 | (lambda (args) (apply proc #f args)) ) |
---|
1168 | (let ([x (compute-apply-methods generic)] |
---|
1169 | [y ((compute-methods generic) args)] ) |
---|
1170 | (lambda (args) (x y args)) ) ) ] ) |
---|
1171 | (when (and e method-caching-enabled) |
---|
1172 | (let ([v (%cdr mc)]) |
---|
1173 | (%vector-set! v e classes) |
---|
1174 | (%vector-set! v (add1 e) cam) ) ) |
---|
1175 | (cam args) ) ) ) ) ) ) ) ) ) |
---|
1176 | |
---|
1177 | (add-method compute-methods |
---|
1178 | (make-method (list <generic>) |
---|
1179 | (lambda (call-next-method generic) |
---|
1180 | (lambda (args) |
---|
1181 | (let ([applicable |
---|
1182 | (filter-in (lambda (method) |
---|
1183 | (let check-applicable ([lst1 (method-specializers method)] |
---|
1184 | [lst2 args]) |
---|
1185 | (cond ((null? lst1) #t) |
---|
1186 | ((null? lst2) #f) |
---|
1187 | (else |
---|
1188 | (and (applicable? (%car lst1) (%car lst2)) |
---|
1189 | (check-applicable (%cdr lst1) (%cdr lst2))))))) |
---|
1190 | (generic-methods generic) ) ] ) |
---|
1191 | (if (or (null? applicable) (null? (%cdr applicable))) |
---|
1192 | applicable |
---|
1193 | (let ([cmms (compute-method-more-specific? generic)]) |
---|
1194 | (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) ) |
---|
1195 | |
---|
1196 | (add-method compute-method-more-specific? |
---|
1197 | (make-method (list <generic>) |
---|
1198 | (lambda (call-next-method generic) |
---|
1199 | (lambda (m1 m2 args) |
---|
1200 | (let loop ((specls1 (method-specializers m1)) |
---|
1201 | (specls2 (method-specializers m2)) |
---|
1202 | (args args)) |
---|
1203 | (cond-expand |
---|
1204 | [unsafe |
---|
1205 | (let ((c1 (%car specls1)) |
---|
1206 | (c2 (%car specls2)) |
---|
1207 | (arg (%car args))) |
---|
1208 | (if (eq? c1 c2) |
---|
1209 | (loop (%cdr specls1) |
---|
1210 | (%cdr specls2) |
---|
1211 | (%cdr args)) |
---|
1212 | (more-specific? c1 c2 arg))) ] |
---|
1213 | [else |
---|
1214 | (cond ((and (null? specls1) (null? specls2)) |
---|
1215 | (##sys#error "two methods are equally specific" generic)) |
---|
1216 | #; ; Ok to have diff # of specializers |
---|
1217 | ((or (null? specls1) (null? specls2)) |
---|
1218 | (##sys#error "two methods have different number of specializers" generic)) |
---|
1219 | ((null? specls1) #f) |
---|
1220 | ((null? specls2) #t) |
---|
1221 | ((null? args) |
---|
1222 | (##sys#error "fewer arguments than specializers" generic)) |
---|
1223 | (else |
---|
1224 | (let ((c1 (%car specls1)) |
---|
1225 | (c2 (%car specls2)) |
---|
1226 | (arg (%car args))) |
---|
1227 | (if (eq? c1 c2) |
---|
1228 | (loop (%cdr specls1) |
---|
1229 | (%cdr specls2) |
---|
1230 | (%cdr args)) |
---|
1231 | (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) ) |
---|
1232 | |
---|
1233 | (add-method compute-apply-methods |
---|
1234 | (make-method (list <generic>) |
---|
1235 | (lambda (call-next-method generic) |
---|
1236 | (lambda (methods args) |
---|
1237 | (letrec ((one-step |
---|
1238 | (lambda (tail) |
---|
1239 | (lambda () |
---|
1240 | (cond-expand |
---|
1241 | [unsafe] |
---|
1242 | [else |
---|
1243 | (when (null? tail) |
---|
1244 | (##sys#error "call-next-method: no methods left" generic) ) ] ) |
---|
1245 | (apply (method-procedure (%car tail)) |
---|
1246 | (one-step (%cdr tail)) args))))) |
---|
1247 | ((one-step methods))))))) |
---|
1248 | |
---|
1249 | (define (applicable? c arg) |
---|
1250 | (memq c (class-cpl (class-of arg))) ) |
---|
1251 | |
---|
1252 | (define (more-specific? c1 c2 arg) |
---|
1253 | (memq c2 (memq c1 (class-cpl (class-of arg)))) ) |
---|
1254 | |
---|
1255 | (add-method initialize |
---|
1256 | (make-method (list <top>) |
---|
1257 | (lambda (call-next-method object initargs) |
---|
1258 | (##sys#error "cannot initialize object" object) ) ) ) |
---|
1259 | |
---|
1260 | (add-method initialize |
---|
1261 | (make-method (list <object>) |
---|
1262 | (lambda (call-next-method object initargs) object))) |
---|
1263 | |
---|
1264 | (add-method initialize |
---|
1265 | (make-method (list <class>) |
---|
1266 | (lambda (call-next-method class initargs) |
---|
1267 | (call-next-method) |
---|
1268 | (##tinyclos#slot-set! class 'direct-supers (fast-getl initargs 'direct-supers '())) |
---|
1269 | (let ([dslots |
---|
1270 | (map (lambda (s) (if (pair? s) s (list s))) |
---|
1271 | (fast-getl initargs 'direct-slots '()))]) |
---|
1272 | (let ([namestr |
---|
1273 | (let ([name (fast-getl initargs 'name "(anonymous)")]) |
---|
1274 | (cond [(symbol? name) (##sys#symbol->string name)] |
---|
1275 | [(string? name) name] |
---|
1276 | [else (##sys#signal-hook #:type-error |
---|
1277 | 'initialize "invalid class name" name) ] ) ) ] ) |
---|
1278 | (##tinyclos#slot-set! class 'direct-slots dslots) |
---|
1279 | (##tinyclos#slot-set! class 'cpl (compute-cpl class)) |
---|
1280 | (##tinyclos#slot-set! class 'name |
---|
1281 | (let ([namestrlen (%string-length namestr)]) |
---|
1282 | (if (and (> namestrlen 0) |
---|
1283 | (char=? #\< (string-ref namestr 0)) |
---|
1284 | (char=? #\> (string-ref namestr (sub1 namestrlen))) ) |
---|
1285 | (substring namestr 1 (sub1 namestrlen)) |
---|
1286 | namestr) )) |
---|
1287 | (let ([slots (compute-slots class)]) |
---|
1288 | (##tinyclos#slot-set! class 'slots slots) |
---|
1289 | (when (= basic-class-instance-size (%structure-length class)) |
---|
1290 | (%instance-cache-set! class (%random-fixnum #x10000)) ) |
---|
1291 | (let* ([nfields 0] |
---|
1292 | [field-initializers '()] |
---|
1293 | [allocator |
---|
1294 | (lambda (init) |
---|
1295 | (let ((f nfields)) |
---|
1296 | (set! nfields (add1 nfields)) |
---|
1297 | (set! field-initializers (cons init field-initializers)) |
---|
1298 | (values (lambda (o) (get-field o f)) |
---|
1299 | (lambda (o n) (set-field! o f n)))))] |
---|
1300 | [getters-n-setters |
---|
1301 | (map (lambda (slot) |
---|
1302 | (cons (%car slot) |
---|
1303 | (call-with-values (lambda () |
---|
1304 | (compute-getter-and-setter class slot allocator)) |
---|
1305 | cons) ) ) |
---|
1306 | slots) ] ) |
---|
1307 | (##tinyclos#slot-set! class 'nfields nfields) |
---|
1308 | (##tinyclos#slot-set! class 'field-initializers (reverse field-initializers)) |
---|
1309 | (##tinyclos#slot-set! class 'getters-n-setters getters-n-setters))))) ) ) ) |
---|
1310 | |
---|
1311 | (add-method initialize |
---|
1312 | (make-method (list <generic>) |
---|
1313 | (lambda (call-next-method generic initargs) |
---|
1314 | (call-next-method) |
---|
1315 | (unless (%entity? generic) |
---|
1316 | (##sys#error 'initialize "generic is not an entity") ) |
---|
1317 | (##tinyclos#slot-set! generic 'methods '()) |
---|
1318 | (%set-entity-name! generic (fast-getl initargs 'name "(unnamed)")) |
---|
1319 | (%set-entity-proc! generic (lambda args (##sys#error "has no methods" generic)))))) |
---|
1320 | |
---|
1321 | (add-method initialize |
---|
1322 | (make-method (list <method>) |
---|
1323 | (lambda (call-next-method method initargs) |
---|
1324 | (call-next-method) |
---|
1325 | (##tinyclos#slot-set! method 'specializers (getl initargs 'specializers)) |
---|
1326 | (##tinyclos#slot-set! method 'procedure (getl initargs 'procedure))))) |
---|
1327 | |
---|
1328 | (add-method allocate-instance |
---|
1329 | (make-method (list <class>) |
---|
1330 | (lambda (call-next-method class) |
---|
1331 | (let* ((field-initializers (##tinyclos#slot-ref class 'field-initializers)) |
---|
1332 | (new (%allocate-instance class (length field-initializers)))) |
---|
1333 | (let loop ((n 0) (inits field-initializers)) |
---|
1334 | (if (null? inits) |
---|
1335 | new |
---|
1336 | (begin |
---|
1337 | (%instance-set! new n ((%car inits))) |
---|
1338 | (loop (add1 n) (%cdr inits))))))))) |
---|
1339 | |
---|
1340 | (add-method allocate-instance |
---|
1341 | (make-method (list <entity-class>) |
---|
1342 | (lambda (call-next-method class) |
---|
1343 | (let* ([field-initializers (##tinyclos#slot-ref class 'field-initializers)] |
---|
1344 | [new (%allocate-entity class (length field-initializers) "(unnamed)") ] ) |
---|
1345 | (let loop ((n 0) (inits field-initializers)) |
---|
1346 | (if (null? inits) |
---|
1347 | new |
---|
1348 | (begin |
---|
1349 | (%entity-set! new n ((%car inits))) |
---|
1350 | (loop (add1 n) (%cdr inits))))))))) |
---|
1351 | |
---|
1352 | (add-method compute-cpl |
---|
1353 | (make-method (list <class>) |
---|
1354 | (lambda (call-next-method class) |
---|
1355 | (compute-std-cpl class class-direct-supers)))) |
---|
1356 | |
---|
1357 | (add-method compute-slots |
---|
1358 | (make-method (list <class>) |
---|
1359 | (lambda (call-next-method class) |
---|
1360 | (let collect ((to-process (apply append (map class-direct-slots (class-cpl class)))) |
---|
1361 | (result '())) |
---|
1362 | (if (null? to-process) |
---|
1363 | (reverse result) |
---|
1364 | (let* ((current (%car to-process)) |
---|
1365 | (name (%car current)) |
---|
1366 | (others '()) |
---|
1367 | (remaining-to-process |
---|
1368 | (filter-in (lambda (o) |
---|
1369 | (if (eq? (%car o) name) |
---|
1370 | (begin |
---|
1371 | (set! others (cons o others)) |
---|
1372 | #f) |
---|
1373 | #t)) |
---|
1374 | (%cdr to-process)))) |
---|
1375 | (collect remaining-to-process |
---|
1376 | (cons (append current (apply append (map (lambda (x) (%cdr x)) others))) |
---|
1377 | result)))))))) |
---|
1378 | |
---|
1379 | (add-method compute-getter-and-setter |
---|
1380 | (make-method (list <class>) |
---|
1381 | (lambda (call-next-method class slot allocator) |
---|
1382 | (allocator (lambda () (void)))))) |
---|
1383 | |
---|
1384 | ; |
---|
1385 | ; Now everything works, both generic functions and classes, so we can |
---|
1386 | ; turn on the real MAKE. |
---|
1387 | ; |
---|
1388 | |
---|
1389 | (set! make |
---|
1390 | (lambda (class . initargs) |
---|
1391 | (let ((instance (allocate-instance class))) |
---|
1392 | (initialize instance initargs) |
---|
1393 | instance))) |
---|
1394 | |
---|
1395 | ; |
---|
1396 | ; Now define what CLOS calls `built in' classes. |
---|
1397 | ; |
---|
1398 | |
---|
1399 | (define <primitive-class> |
---|
1400 | (make <class> |
---|
1401 | 'direct-supers (list <class>) |
---|
1402 | 'direct-slots '() |
---|
1403 | 'name "primitive-class")) |
---|
1404 | |
---|
1405 | (define <primitive> |
---|
1406 | (make <class> |
---|
1407 | 'direct-supers (list <top>) |
---|
1408 | 'direct-slots '() |
---|
1409 | 'name "primitive")) |
---|
1410 | |
---|
1411 | (add-method initialize |
---|
1412 | (make-method (list <primitive>) |
---|
1413 | (lambda (call-next-method object initargs) object))) |
---|
1414 | |
---|
1415 | (define (make-primitive-class name . sclasses) |
---|
1416 | (make <primitive-class> |
---|
1417 | 'direct-supers (if (null? sclasses) (list <primitive>) sclasses) |
---|
1418 | 'direct-slots '() |
---|
1419 | 'name name) ) |
---|
1420 | |
---|
1421 | (define (make-port-class name) |
---|
1422 | (make <class> |
---|
1423 | 'direct-supers (list <port>) |
---|
1424 | 'direct-slots '() |
---|
1425 | 'name name) ) |
---|
1426 | |
---|
1427 | (define (make-structure-class name) |
---|
1428 | (make-primitive-class name <structure>) ) |
---|
1429 | |
---|
1430 | (define (make-extended-procedure-class name) |
---|
1431 | (make-primitive-class name <procedure>) ) |
---|
1432 | |
---|
1433 | (define (make-tagged-pointer-class name) |
---|
1434 | (make <class> |
---|
1435 | 'direct-supers (list <tagged-pointer>) |
---|
1436 | 'direct-slots '() |
---|
1437 | 'name name) ) |
---|
1438 | |
---|
1439 | (define <void> (make-primitive-class "void")) |
---|
1440 | (define <null> (make-primitive-class "null")) |
---|
1441 | (define <end-of-file> (make-primitive-class "end-of-file")) |
---|
1442 | (define <boolean> (make-primitive-class "boolean")) |
---|
1443 | (define <symbol> (make-primitive-class "symbol")) |
---|
1444 | (define <char> (make-primitive-class "char")) |
---|
1445 | (define <number> (make-primitive-class "number")) |
---|
1446 | (define <integer> (make-primitive-class "integer" <number>)) |
---|
1447 | (define <exact> (make-primitive-class "exact" <integer>)) |
---|
1448 | (define <inexact> (make-primitive-class "inexact" <number>)) |
---|
1449 | (define <vector> (make-primitive-class "vector")) |
---|
1450 | (define <pair> (make-primitive-class "pair")) |
---|
1451 | (define <string> (make-primitive-class "string")) |
---|
1452 | (define <port> (make-primitive-class "port")) |
---|
1453 | (define <input-port> (make-port-class "input-port")) |
---|
1454 | (define <output-port> (make-port-class "output-port")) |
---|
1455 | (define <procedure> (make-primitive-class "procedure" <procedure-class>)) |
---|
1456 | (define <blob> (make-primitive-class "blob")) |
---|
1457 | (define <byte-vector> (make-primitive-class "byte-vector")) ; DEPRECATED |
---|
1458 | (define <structure> (make-primitive-class "structure")) |
---|
1459 | (define <environment> (make-structure-class "environment")) |
---|
1460 | (define <hash-table> (make-structure-class "hash-table")) |
---|
1461 | (define <promise> (make-structure-class "promise")) |
---|
1462 | (define <queue> (make-structure-class "queue")) |
---|
1463 | (define <condition> (make-structure-class "condition")) |
---|
1464 | (define <condition-variable> (make-structure-class "condition-variable")) |
---|
1465 | (define <continuation> (make-structure-class "continuation")) |
---|
1466 | (define <char-set> (make-structure-class "char-set")) |
---|
1467 | (define <time> (make-structure-class "time")) |
---|
1468 | (define <lock> (make-structure-class "lock")) |
---|
1469 | (define <mmap> (make-structure-class "mmap")) |
---|
1470 | (define <array> (make-structure-class "array")) |
---|
1471 | (define <tcp-listener> (make-structure-class "tcp-listener")) |
---|
1472 | (define <thread> (make-structure-class "thread")) |
---|
1473 | (define <mutex> (make-structure-class "mutex")) |
---|
1474 | (define <regexp> (make-structure-class "regexp")) |
---|
1475 | (define <read-table> (make-structure-class "read-table")) |
---|
1476 | (define <locative> (make-primitive-class "locative")) |
---|
1477 | (define <pointer> (make-primitive-class "pointer")) |
---|
1478 | (define <swig-pointer> (make-primitive-class "swig-pointer" <pointer>)) |
---|
1479 | (define <tagged-pointer> (make-primitive-class "tagged-pointer" <pointer>)) |
---|
1480 | (define <u8vector> (make-primitive-class "u8vector" <vector>)) |
---|
1481 | (define <s8vector> (make-primitive-class "s8vector" <vector>)) |
---|
1482 | (define <u16vector> (make-primitive-class "u16vector" <vector>)) |
---|
1483 | (define <s16vector> (make-primitive-class "s16vector" <vector>)) |
---|
1484 | (define <u32vector> (make-primitive-class "u32vector" <vector>)) |
---|
1485 | (define <s32vector> (make-primitive-class "s32vector" <vector>)) |
---|
1486 | (define <f32vector> (make-primitive-class "f32vector" <vector>)) |
---|
1487 | (define <f64vector> (make-primitive-class "f64vector" <vector>)) |
---|
1488 | |
---|
1489 | (define <c++-object> |
---|
1490 | (make <class> |
---|
1491 | 'direct-supers (list <object>) |
---|
1492 | 'direct-slots '(this) |
---|
1493 | 'name "c++-object")) |
---|
1494 | |
---|
1495 | (add-method initialize |
---|
1496 | (make-method (list <c++-object>) |
---|
1497 | (lambda (call-next-method obj initargs) |
---|
1498 | (when (and (pair? initargs) (eq? 'this (%car initargs))) |
---|
1499 | (##tinyclos#slot-set! obj 'this (cadr initargs)) ) ) ) ) |
---|
1500 | |
---|
1501 | (set! method-caching-enabled #t) |
---|
1502 | |
---|
1503 | ;;; Utilities: |
---|
1504 | |
---|
1505 | (define (initialize-slots object initargs) |
---|
1506 | (##sys#check-list initargs 'initialize-slots) |
---|
1507 | (for-each |
---|
1508 | (lambda (slot) |
---|
1509 | (let* ([name (car slot)] |
---|
1510 | [value (fast-getl initargs name not-found-object)] ) |
---|
1511 | (unless (eq? value not-found-object) |
---|
1512 | (slot-set! object name value)))) |
---|
1513 | (class-slots (class-of object))) ) |
---|
1514 | |
---|
1515 | (define print-object (make-generic "print-object")) |
---|
1516 | (define describe-object (make-generic "describe-object")) |
---|
1517 | |
---|
1518 | (add-method print-object |
---|
1519 | (make-method (list <object>) |
---|
1520 | (lambda (call-next-method x . port) |
---|
1521 | (fprintf (optional port ##sys#standard-output) "#<~A>" (class-name (class-of x))) ) ) ) |
---|
1522 | |
---|
1523 | (add-method print-object |
---|
1524 | (make-method (list <primitive>) |
---|
1525 | (lambda (call-next-method x . port) |
---|
1526 | (write x (optional port ##sys#standard-output)) ) ) ) |
---|
1527 | |
---|
1528 | (add-method print-object |
---|
1529 | (make-method (list <class>) |
---|
1530 | (lambda (call-next-method x . port) |
---|
1531 | (fprintf (optional port ##sys#standard-output) "#<class ~A>" (class-name x)) ) ) ) |
---|
1532 | |
---|
1533 | (add-method print-object |
---|
1534 | (make-method (list <generic>) |
---|
1535 | (lambda (call-next-method x . port) |
---|
1536 | (fprintf (optional port ##sys#standard-output) "#<generic ~A>" (%entity-name x)) ) ) ) |
---|
1537 | |
---|
1538 | (add-method describe-object |
---|
1539 | (make-method (list <object>) |
---|
1540 | (lambda (call-next-method x . port) |
---|
1541 | (let ([class (class-of x)] |
---|
1542 | [port (optional port ##sys#standard-output)] ) |
---|
1543 | (fprintf port "instance of class ~A:~%" (class-name class)) |
---|
1544 | (for-each |
---|
1545 | (lambda (s) |
---|
1546 | (let ([slot (car s)]) |
---|
1547 | (fprintf port " ~S\t-> ~S~%" slot (slot-ref x slot)) ) ) |
---|
1548 | (class-slots class) ) ) ) ) ) |
---|
1549 | |
---|
1550 | (add-method describe-object |
---|
1551 | (make-method (list <class>) |
---|
1552 | (lambda (call-next-method x . port) |
---|
1553 | (fprintf (optional port ##sys#standard-output) "class ~A~%" (class-name x)) ) ) ) |
---|
1554 | |
---|
1555 | (add-method describe-object |
---|
1556 | (make-method (list <generic>) |
---|
1557 | (lambda (call-next-method x . port) |
---|
1558 | (fprintf (optional port ##sys#standard-output) "generic ~A~%" (%entity-name x)) ) ) ) |
---|
1559 | |
---|
1560 | (define ensure-generic |
---|
1561 | (let ([make-generic make-generic]) |
---|
1562 | (lambda (x sym) |
---|
1563 | (if (%entity? x) |
---|
1564 | x |
---|
1565 | (make-generic (##sys#symbol->string sym)) ) ) ) ) |
---|
1566 | |
---|
1567 | (define add-global-method |
---|
1568 | (let ([make-method make-method] |
---|
1569 | [add-method add-method] ) |
---|
1570 | (lambda (val sym specializers proc) |
---|
1571 | (let ([g (ensure-generic val sym)]) |
---|
1572 | (add-method g (make-method specializers proc)) |
---|
1573 | g) ) ) ) |
---|
1574 | |
---|
1575 | (define (instance? x) |
---|
1576 | (or (%instance? x) (%entity? x)) ) |
---|
1577 | |
---|
1578 | (define (subclass? x y) |
---|
1579 | (if (memq y (compute-cpl x)) #t #f) ) |
---|
1580 | |
---|
1581 | (define (instance-of? x class) |
---|
1582 | (let ([cl (class-of x)]) |
---|
1583 | (or (eq? cl class) |
---|
1584 | (subclass? cl class) ) ) ) |
---|
1585 | |
---|
1586 | (define (make-instance-from-pointer ptr cls) |
---|
1587 | (and ptr |
---|
1588 | (not (%null-pointer? ptr)) |
---|
1589 | (make cls 'this ptr) ) ) |
---|
1590 | |
---|
1591 | (define (make/copy x . initargs) |
---|
1592 | (let ([class (class-of x)]) |
---|
1593 | (apply make class |
---|
1594 | (let ([initlist initargs] |
---|
1595 | [inited-slot? |
---|
1596 | (lambda (nam) |
---|
1597 | (let loop ([testing? #t] [initargs initargs]) |
---|
1598 | (and (pair? initargs) |
---|
1599 | (or (and testing? (equal? nam (car initargs))) |
---|
1600 | (loop (not testing?) (cdr initargs)) ) ) ) )]) |
---|
1601 | (for-each |
---|
1602 | (lambda (s) |
---|
1603 | (let ([nam (car s)]) |
---|
1604 | (unless (inited-slot? nam) |
---|
1605 | (set! initlist (cons nam (cons (slot-ref x nam) initlist))) ) ) ) |
---|
1606 | (class-slots class)) |
---|
1607 | initlist ) ) ) ) |
---|
1608 | |
---|
1609 | ;; Procedural interface for extending the "builtin" class system |
---|
1610 | |
---|
1611 | ; Primitive |
---|
1612 | |
---|
1613 | (define (new-primitive-class name pred . sclasses) |
---|
1614 | (let ((cls (apply make-primitive-class name sclasses))) |
---|
1615 | (update-primitive-class-of pred cls) |
---|
1616 | cls ) ) |
---|
1617 | |
---|
1618 | (define (delete-primitive-class cls) |
---|
1619 | (delete-primitive-class-of cls) ) |
---|
1620 | |
---|
1621 | ; Structure |
---|
1622 | |
---|
1623 | (define (new-structure-class name tag) |
---|
1624 | (let ((cls (make-structure-class name))) |
---|
1625 | (update-structure-class-of tag cls) |
---|
1626 | cls ) ) |
---|
1627 | |
---|
1628 | (define (delete-structure-class cls) |
---|
1629 | (delete-structure-class-of cls) ) |
---|
1630 | |
---|
1631 | ; Tagged-pointer |
---|
1632 | |
---|
1633 | (define (new-tagged-pointer-class name tag) |
---|
1634 | (let ((cls (make-tagged-pointer-class name))) |
---|
1635 | (update-tagged-pointer-class-of tag cls) |
---|
1636 | cls ) ) |
---|
1637 | |
---|
1638 | (define (delete-tagged-pointer-class cls) |
---|
1639 | (delete-tagged-pointer-class-of cls) ) |
---|
1640 | |
---|
1641 | ; Procedure |
---|
1642 | |
---|
1643 | (define (new-extended-procedure-class name pred) |
---|
1644 | (let ((cls (make-extended-procedure-class name))) |
---|
1645 | (update-extended-procedure-class-of pred cls) |
---|
1646 | cls ) ) |
---|
1647 | |
---|
1648 | (define (delete-extended-procedure-class cls) |
---|
1649 | (delete-extended-procedure-class-of cls) ) |
---|
1650 | |
---|
1651 | ) |
---|