Ticket #32: 3.scm

File 3.scm, 61.4 KB (added by Tony Sidaway, 13 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) )