Context Navigation

Back to Ticket #32

Ticket #32: 3.scm

File 3.scm, 61.4 KB (added by Tony Sidaway, 16 years ago)
Trimmed version of version 3 egg, for comparison using diff

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

Download in other formats:

Original Format