Ticket #32: 4.scm

File 4.scm, 61.7 KB (added by Tony Sidaway, 13 years ago)

Trimmed version of the version 4 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-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)