3 ;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
4 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 ;;;; This file was based upon stklos.stk from the STk distribution
24 ;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
27 (define-module (oop goops)
28 #:use-module (srfi srfi-1)
29 #:export-syntax (define-class class standard-define-class
30 define-generic define-accessor define-method
31 define-extended-generic define-extended-generics
33 #:export ( ;; The root of everything.
38 <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
39 <read-only-slot> <self-slot> <protected-opaque-slot>
40 <protected-hidden-slot> <protected-read-only-slot>
41 <scm-slot> <int-slot> <float-slot> <double-slot>
43 ;; Methods are implementations of generic functions.
44 <method> <accessor-method>
46 ;; Applicable objects, either procedures or applicable structs.
47 <procedure-class> <applicable>
48 <procedure> <primitive-generic>
50 ;; Applicable structs.
51 <applicable-struct-class>
53 <generic> <extended-generic>
54 <generic-with-setter> <extended-generic-with-setter>
55 <accessor> <extended-accessor>
57 ;; Types with their own allocated typecodes.
58 <boolean> <char> <list> <pair> <null> <string> <symbol>
59 <vector> <bytevector> <uvec> <foreign> <hashtable>
60 <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
63 <number> <complex> <real> <integer> <fraction>
68 ;; Particular SMOB data types. All SMOB types have
69 ;; corresponding classes, which may be obtained via class-of,
70 ;; once you have an instance. Perhaps FIXME to provide a
71 ;; smob-type-name->class procedure.
72 <arbiter> <promise> <thread> <mutex> <condition-variable>
73 <regexp> <hook> <bitvector> <random-state> <async>
74 <directory> <keyword> <array> <character-set>
75 <dynamic-object> <guardian> <macro>
81 <port> <input-port> <output-port> <input-output-port>
83 ;; Like SMOB types, all port types have their own classes,
84 ;; which can be accessed via `class-of' once you have an
85 ;; instance. Here we export bindings just for file ports.
87 <file-input-port> <file-output-port> <file-input-output-port>
90 ensure-metaclass ensure-metaclass-with-supers
92 make-generic ensure-generic
94 make-accessor ensure-accessor
96 class-slot-ref class-slot-set! slot-unbound slot-missing
97 slot-definition-name slot-definition-options
98 slot-definition-allocation
100 slot-definition-getter slot-definition-setter
101 slot-definition-accessor
102 slot-definition-init-value slot-definition-init-form
103 slot-definition-init-thunk slot-definition-init-keyword
104 slot-init-function class-slot-definition
106 compute-cpl compute-std-cpl compute-get-n-set compute-slots
107 compute-getter-method compute-setter-method
108 allocate-instance initialize make-instance make
109 no-next-method no-applicable-method no-method
110 change-class update-instance-for-different-class
111 shallow-clone deep-clone
113 apply-generic apply-method apply-methods
114 compute-applicable-methods %compute-applicable-methods
115 method-more-specific? sort-applicable-methods
116 class-subclasses class-methods
118 min-fixnum max-fixnum
120 ;;; *fixme* Should go into goops.c
121 instance? slot-ref-using-class
122 slot-set-using-class! slot-bound-using-class?
123 slot-exists-using-class? slot-ref slot-set! slot-bound?
124 class-name class-direct-supers class-direct-subclasses
125 class-direct-methods class-direct-slots class-precedence-list
127 generic-function-name
128 generic-function-methods method-generic-function
129 method-specializers method-formals
130 primitive-generic-generic enable-primitive-generic!
131 method-procedure accessor-method-slot-definition
132 slot-exists? make find-method get-keyword)
135 (define *goops-module* (current-module))
137 ;; XXX FIXME: figure out why the 'eval-when's in this file must use
138 ;; 'compile' and must avoid 'expand', but only in 2.2, and only when
139 ;; compiling something that imports goops, e.g. (ice-9 occam-channel),
140 ;; before (oop goops) itself has been compiled.
142 ;; First initialize the builtin part of GOOPS
143 (eval-when (compile load eval)
144 (%init-goops-builtins))
146 (eval-when (compile load eval)
147 (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
148 (add-interesting-primitive! 'class-of))
150 ;; Then load the rest of GOOPS
151 (use-modules (oop goops util)
157 (eval-when (compile load eval)
158 (define min-fixnum (- (expt 2 29)))
159 (define max-fixnum (- (expt 2 29) 1)))
164 (define (goops-error format-string . args)
165 (scm-error 'goops-error #f format-string args '()))
170 (define (is-a? obj class)
171 (and (memq class (class-precedence-list (class-of obj))) #t))
178 (define ensure-metaclass-with-supers
179 (let ((table-of-metas '()))
180 (lambda (meta-supers)
181 (let ((entry (assoc meta-supers table-of-metas)))
183 ;; Found a previously created metaclass
185 ;; Create a new meta-class which inherit from "meta-supers"
186 (let ((new (make <class> #:dsupers meta-supers
188 #:name (gensym "metaclass"))))
189 (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
192 (define (ensure-metaclass supers)
195 (let* ((all-metas (map (lambda (x) (class-of x)) supers))
196 (all-cpls (append-map (lambda (m)
197 (cdr (class-precedence-list m)))
200 ;; Find the most specific metaclasses. The new metaclass will be
201 ;; a subclass of these.
204 (if (and (not (member meta all-cpls))
205 (not (member meta needed-metas)))
206 (set! needed-metas (append needed-metas (list meta)))))
208 ;; Now return a subclass of the metaclasses we found.
209 (if (null? (cdr needed-metas))
210 (car needed-metas) ; If there's only one, just use it.
211 (ensure-metaclass-with-supers needed-metas)))))
217 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
219 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
220 ;;; OPTION ::= KEYWORD VALUE
223 (define (kw-do-map mapper f kwargs)
227 ((or (null? (cdr l)) (not (keyword? (car l))))
228 (goops-error "malformed keyword arguments: ~a" kwargs))
229 (else (cons (car l) (keywords (cddr l))))))
231 (if (null? l) '() (cons (cadr l) (args (cddr l)))))
232 ;; let* to check keywords first
233 (let* ((k (keywords kwargs))
237 (define (make-class supers slots . options)
238 (let* ((name (get-keyword #:name options (make-unbound)))
239 (supers (if (not (or-map (lambda (class)
241 (class-precedence-list class)))
243 (append supers (list <object>))
245 (metaclass (or (get-keyword #:metaclass options #f)
246 (ensure-metaclass supers))))
248 ;; Verify that all direct slots are different and that we don't inherit
249 ;; several time from the same class
250 (let ((tmp1 (find-duplicate supers))
251 (tmp2 (find-duplicate (map slot-definition-name slots))))
253 (goops-error "make-class: super class ~S is duplicate in class ~S"
256 (goops-error "make-class: slot ~S is duplicate in class ~S"
259 ;; Everything seems correct, build the class
260 (apply make metaclass
266 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
268 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
269 ;;; OPTION ::= KEYWORD VALUE
271 (define-macro (class supers . slots)
272 (define (make-slot-definition-forms slots)
278 ,@(kw-do-map append-map
283 #:init-thunk (lambda () ,arg)))
284 (else (list kw arg))))
289 (if (not (list? supers))
290 (goops-error "malformed superclass list: ~S" supers))
291 (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
292 (options (or (find-tail keyword? slots) '())))
294 ;; evaluate super class variables
296 ;; evaluate slot definitions, except the slot name!
297 (list ,@(make-slot-definition-forms slots))
298 ;; evaluate class options
301 (define-syntax define-class-pre-definition
304 ((_ (k arg rest ...) out ...)
305 (keyword? (syntax->datum #'k))
306 (case (syntax->datum #'k)
308 #'(define-class-pre-definition (rest ...)
310 (if (or (not (defined? 'arg))
311 (not (is-a? arg <generic>)))
314 (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
316 #'(define-class-pre-definition (rest ...)
318 (if (or (not (defined? 'arg))
319 (not (is-a? arg <accessor>)))
322 (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
324 #'(define-class-pre-definition (rest ...) out ...))))
326 #'(begin out ...)))))
328 ;; Some slot options require extra definitions to be made. In
329 ;; particular, we want to make sure that the generic function objects
330 ;; which represent accessors exist before `make-class' tries to add
332 (define-syntax define-class-pre-definitions
337 ((_ (slot rest ...) out ...)
338 (keyword? (syntax->datum #'slot))
340 ((_ (slot rest ...) out ...)
342 #'(define-class-pre-definitions (rest ...)
344 ((_ ((slotname slotopt ...) rest ...) out ...)
345 #'(define-class-pre-definitions (rest ...)
346 out ... (define-class-pre-definition (slotopt ...)))))))
348 (define-syntax-rule (define-class name supers slot ...)
350 (define-class-pre-definitions (slot ...))
351 (if (and (defined? 'name)
353 (memq <object> (class-precedence-list name)))
354 (class-redefinition name
355 (class supers slot ... #:name 'name))
356 (toplevel-define! 'name (class supers slot ... #:name 'name)))))
358 (define-syntax-rule (standard-define-class arg ...)
359 (define-class arg ...))
362 ;;; {Generic functions and accessors}
365 ;; Apparently the desired semantics are that we extend previous
366 ;; procedural definitions, but that if `name' was already a generic, we
367 ;; overwrite its definition.
368 (define-macro (define-generic name)
369 (if (not (symbol? name))
370 (goops-error "bad generic function name: ~S" name))
372 (if (and (defined? ',name) (is-a? ,name <generic>))
373 (make <generic> #:name ',name)
374 (ensure-generic (if (defined? ',name) ,name #f) ',name))))
376 (define-macro (define-extended-generic name val)
377 (if (not (symbol? name))
378 (goops-error "bad generic function name: ~S" name))
379 `(define ,name (make-extended-generic ,val ',name)))
381 (define-macro (define-extended-generics names . args)
382 (let ((prefixes (get-keyword #:prefix args #f)))
385 ,@(map (lambda (name)
386 `(define-extended-generic ,name
387 (list ,@(map (lambda (prefix)
388 (symbol-append prefix name))
391 (goops-error "no prefixes supplied"))))
393 (define* (make-generic #:optional name)
394 (make <generic> #:name name))
396 (define* (make-extended-generic gfs #:optional name)
397 (let* ((gfs (if (list? gfs) gfs (list gfs)))
398 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
400 (let* ((sname (and name (make-setter-name name)))
402 (append-map (lambda (gf)
403 (if (is-a? gf <generic-with-setter>)
404 (list (ensure-generic (setter gf)
408 (es (make <extended-generic-with-setter>
411 #:setter (make <extended-generic>
413 #:extends setters))))
414 (extended-by! setters (setter es))
416 (make <extended-generic>
419 (extended-by! gfs ans)
422 (define (extended-by! gfs eg)
423 (for-each (lambda (gf)
424 (slot-set! gf 'extended-by
425 (cons eg (slot-ref gf 'extended-by))))
427 (invalidate-method-cache! eg))
429 (define (not-extended-by! gfs eg)
430 (for-each (lambda (gf)
431 (slot-set! gf 'extended-by
432 (delq! eg (slot-ref gf 'extended-by))))
434 (invalidate-method-cache! eg))
436 (define* (ensure-generic old-definition #:optional name)
437 (cond ((is-a? old-definition <generic>) old-definition)
438 ((procedure-with-setter? old-definition)
439 (make <generic-with-setter>
441 #:default (procedure old-definition)
442 #:setter (setter old-definition)))
443 ((procedure? old-definition)
444 (if (generic-capability? old-definition) old-definition
445 (make <generic> #:name name #:default old-definition)))
446 (else (make <generic> #:name name))))
448 ;; same semantics as <generic>
449 (define-syntax-rule (define-accessor name)
451 (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
452 ((is-a? name <accessor>) (make <accessor> #:name 'name))
453 (else (ensure-accessor name 'name)))))
455 (define (make-setter-name name)
456 (string->symbol (string-append "setter:" (symbol->string name))))
458 (define* (make-accessor #:optional name)
461 #:setter (make <generic>
462 #:name (and name (make-setter-name name)))))
464 (define* (ensure-accessor proc #:optional name)
465 (cond ((and (is-a? proc <accessor>)
466 (is-a? (setter proc) <generic>))
468 ((is-a? proc <generic-with-setter>)
469 (upgrade-accessor proc (setter proc)))
470 ((is-a? proc <generic>)
471 (upgrade-accessor proc (make-generic name)))
472 ((procedure-with-setter? proc)
475 #:default (procedure proc)
476 #:setter (ensure-generic (setter proc) name)))
478 (ensure-accessor (if (generic-capability? proc)
479 (make <generic> #:name name #:default proc)
480 (ensure-generic proc name))
483 (make-accessor name))))
485 (define (upgrade-accessor generic setter)
486 (let ((methods (slot-ref generic 'methods))
487 (gws (make (if (is-a? generic <extended-generic>)
488 <extended-generic-with-setter>
490 #:name (generic-function-name generic)
491 #:extended-by (slot-ref generic 'extended-by)
493 (if (is-a? generic <extended-generic>)
494 (let ((gfs (slot-ref generic 'extends)))
495 (not-extended-by! gfs generic)
496 (slot-set! gws 'extends gfs)
497 (extended-by! gfs gws)))
499 (for-each (lambda (method)
500 (slot-set! method 'generic-function gws))
502 (slot-set! gws 'methods methods)
503 (invalidate-method-cache! gws)
510 (define (toplevel-define! name val)
511 (module-define! (current-module) name val))
513 (define-syntax define-method
514 (syntax-rules (setter)
515 ((_ ((setter name) . args) body ...)
517 (if (or (not (defined? 'name))
518 (not (is-a? name <accessor>)))
519 (toplevel-define! 'name
521 (if (defined? 'name) name #f) 'name)))
522 (add-method! (setter name) (method args body ...))))
523 ((_ (name . args) body ...)
525 ;; FIXME: this code is how it always was, but it's quite cracky:
526 ;; it will only define the generic function if it was undefined
527 ;; before (ok), or *was defined to #f*. The latter is crack. But
528 ;; there are bootstrap issues about fixing this -- change it to
529 ;; (is-a? name <generic>) and see.
530 (if (or (not (defined? 'name))
532 (toplevel-define! 'name (make <generic> #:name 'name)))
533 (add-method! name (method args body ...))))))
535 (define-syntax method
537 (define (parse-args args)
538 (let lp ((ls args) (formals '()) (specializers '()))
541 (and (identifier? #'f) (identifier? #'s))
544 (cons #'s specializers)))
549 (cons #'<top> specializers)))
551 (list (reverse formals)
552 (reverse (cons #''() specializers))))
555 (list (append (reverse formals) #'tail)
556 (reverse (cons #'<top> specializers)))))))
558 (define (find-free-id exp referent)
561 (or (find-free-id #'x referent)
562 (find-free-id #'y referent)))
565 (let ((id (datum->syntax #'x referent)))
566 (and (free-identifier=? #'x id) id)))
569 (define (compute-procedure formals body)
572 (with-syntax ((formals formals))
573 #'(lambda formals body0 ...)))))
575 (define (->proper args)
576 (let lp ((ls args) (out '()))
578 ((x . xs) (lp #'xs (cons #'x out)))
580 (tail (reverse (cons #'tail out))))))
582 (define (compute-make-procedure formals body next-method)
585 (with-syntax ((next-method next-method))
586 (syntax-case formals ()
588 #'(lambda (real-next-method)
590 (let ((next-method (lambda args
592 (real-next-method formal ...)
593 (apply real-next-method args)))))
596 (with-syntax (((formal ...) (->proper #'formals)))
597 #'(lambda (real-next-method)
599 (let ((next-method (lambda args
601 (apply real-next-method formal ...)
602 (apply real-next-method args)))))
605 (define (compute-procedures formals body)
606 ;; So, our use of this is broken, because it operates on the
607 ;; pre-expansion source code. It's equivalent to just searching
608 ;; for referent in the datums. Ah well.
609 (let ((id (find-free-id body 'next-method)))
611 ;; return a make-procedure
613 (compute-make-procedure formals body id))
614 (values (compute-procedure formals body)
618 ((_ args) #'(method args (if #f #f)))
619 ((_ args body0 body1 ...)
620 (with-syntax (((formals (specializer ...)) (parse-args #'args)))
623 (compute-procedures #'formals #'(body0 body1 ...)))
624 (lambda (procedure make-procedure)
625 (with-syntax ((procedure procedure)
626 (make-procedure make-procedure))
628 #:specializers (cons* specializer ...)
630 #:body '(body0 body1 ...)
631 #:make-procedure make-procedure
632 #:procedure procedure)))))))))
638 (define (add-method-in-classes! m)
639 ;; Add method in all the classes which appears in its specializers list
640 (for-each* (lambda (x)
641 (let ((dm (class-direct-methods x)))
642 (if (not (memq m dm))
643 (slot-set! x 'direct-methods (cons m dm)))))
644 (method-specializers m)))
646 (define (remove-method-in-classes! m)
647 ;; Remove method in all the classes which appears in its specializers list
648 (for-each* (lambda (x)
651 (delv! m (class-direct-methods x))))
652 (method-specializers m)))
654 (define (compute-new-list-of-methods gf new)
655 (let ((new-spec (method-specializers new))
656 (methods (slot-ref gf 'methods)))
657 (let loop ((l methods))
660 (if (equal? (method-specializers (car l)) new-spec)
662 ;; This spec. list already exists. Remove old method from dependents
663 (remove-method-in-classes! (car l))
668 (define (method-n-specializers m)
669 (length* (slot-ref m 'specializers)))
671 (define (calculate-n-specialized gf)
672 (fold (lambda (m n) (max n (method-n-specializers m)))
674 (generic-function-methods gf)))
676 (define (invalidate-method-cache! gf)
677 (%invalidate-method-cache! gf)
678 (slot-set! gf 'n-specialized (calculate-n-specialized gf))
679 (for-each (lambda (gf) (invalidate-method-cache! gf))
680 (slot-ref gf 'extended-by)))
682 (define internal-add-method!
683 (method ((gf <generic>) (m <method>))
684 (slot-set! m 'generic-function gf)
685 (slot-set! gf 'methods (compute-new-list-of-methods gf m))
686 (invalidate-method-cache! gf)
687 (add-method-in-classes! m)
690 (define-generic add-method!)
692 ((method-procedure internal-add-method!) add-method! internal-add-method!)
694 (define-method (add-method! (proc <procedure>) (m <method>))
695 (if (generic-capability? proc)
697 (enable-primitive-generic! proc)
698 (add-method! proc m))
701 (define-method (add-method! (pg <primitive-generic>) (m <method>))
702 (add-method! (primitive-generic-generic pg) m))
704 (define-method (add-method! obj (m <method>))
705 (goops-error "~S is not a valid generic function" obj))
708 ;;; {Access to meta objects}
714 (define-method (method-source (m <method>))
715 (let* ((spec (map* class-name (slot-ref m 'specializers)))
716 (src (procedure-source (slot-ref m 'procedure))))
718 (let ((args (cadr src))
721 (cons (map* list args spec)
724 (define-method (method-formals (m <method>))
725 (slot-ref m 'formals))
730 (define slot-definition-name car)
732 (define slot-definition-options cdr)
734 (define (slot-definition-allocation s)
735 (get-keyword #:allocation (cdr s) #:instance))
737 (define (slot-definition-getter s)
738 (get-keyword #:getter (cdr s) #f))
740 (define (slot-definition-setter s)
741 (get-keyword #:setter (cdr s) #f))
743 (define (slot-definition-accessor s)
744 (get-keyword #:accessor (cdr s) #f))
746 (define (slot-definition-init-value s)
747 ;; can be #f, so we can't use #f as non-value
748 (get-keyword #:init-value (cdr s) (make-unbound)))
750 (define (slot-definition-init-form s)
751 (get-keyword #:init-form (cdr s) (make-unbound)))
753 (define (slot-definition-init-thunk s)
754 (get-keyword #:init-thunk (cdr s) #f))
756 (define (slot-definition-init-keyword s)
757 (get-keyword #:init-keyword (cdr s) #f))
759 (define (class-slot-definition class slot-name)
760 (assq slot-name (class-slots class)))
762 (define (slot-init-function class slot-name)
763 (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
765 (define (accessor-method-slot-definition obj)
766 "Return the slot definition of the accessor @var{obj}."
767 (slot-ref obj 'slot-definition))
771 ;;; {Standard methods used by the C runtime}
774 ;;; Methods to compare objects
777 ;; Have to do this in a strange order because equal? is used in the
778 ;; add-method! implementation; we need to make sure that when the
779 ;; primitive is extended, that the generic has a method. =
780 (define g-equal? (make-generic 'equal?))
781 ;; When this generic gets called, we will have already checked eq? and
782 ;; eqv? -- the purpose of this generic is to extend equality. So by
783 ;; default, there is no extension, thus the #f return.
784 (add-method! g-equal? (method (x y) #f))
785 (set-primitive-generic! equal? g-equal?)
788 ;;; methods to display/write an object
791 ; Code for writing objects must test that the slots they use are
792 ; bound. Otherwise a slot-unbound method will be called and will
793 ; conduct to an infinite loop.
796 (define (display-address o file)
797 (display (number->string (object-address o) 16) file))
799 (define-method (write o file)
800 (display "#<instance " file)
801 (display-address o file)
804 (define write-object (primitive-generic-generic write))
806 (define-method (write (o <object>) file)
807 (let ((class (class-of o)))
808 (if (slot-bound? class 'name)
811 (display (class-name class) file)
812 (display #\space file)
813 (display-address o file)
817 (define-method (write (class <class>) file)
818 (let ((meta (class-of class)))
819 (if (and (slot-bound? class 'name)
820 (slot-bound? meta 'name))
823 (display (class-name meta) file)
824 (display #\space file)
825 (display (class-name class) file)
826 (display #\space file)
827 (display-address class file)
831 (define-method (write (gf <generic>) file)
832 (let ((meta (class-of gf)))
833 (if (and (slot-bound? meta 'name)
834 (slot-bound? gf 'methods))
837 (display (class-name meta) file)
838 (let ((name (generic-function-name gf)))
841 (display #\space file)
842 (display name file))))
844 (display (length (generic-function-methods gf)) file)
848 (define-method (write (o <method>) file)
849 (let ((meta (class-of o)))
850 (if (and (slot-bound? meta 'name)
851 (slot-bound? o 'specializers))
854 (display (class-name meta) file)
855 (display #\space file)
856 (display (map* (lambda (spec)
857 (if (slot-bound? spec 'name)
858 (slot-ref spec 'name)
860 (method-specializers o))
862 (display #\space file)
863 (display-address o file)
867 ;; Display (do the same thing as write by default)
868 (define-method (display o file)
869 (write-object o file))
872 ;;; Handling of duplicate bindings in the module system
875 (define (find-subclass super name)
876 (let lp ((classes (class-direct-subclasses super)))
879 (error "class not found" name))
880 ((and (slot-bound? (car classes) 'name)
881 (eq? (class-name (car classes)) name))
884 (lp (cdr classes))))))
887 (define <module> (find-subclass <top> '<module>))
889 (define-method (merge-generics (module <module>)
899 (define-method (merge-generics (module <module>)
907 (and (not (eq? val1 val2))
908 (make-variable (make-extended-generic (list val2 val1) name))))
910 (define-method (merge-generics (module <module>)
917 (gf <extended-generic>))
918 (and (not (memq val2 (slot-ref gf 'extends)))
922 (cons val2 (delq! val2 (slot-ref gf 'extends))))
925 (cons gf (delq! gf (slot-ref val2 'extended-by))))
926 (invalidate-method-cache! gf)
929 (module-define! duplicate-handlers 'merge-generics merge-generics)
931 (define-method (merge-accessors (module <module>)
941 (define-method (merge-accessors (module <module>)
949 (merge-generics module name int1 val1 int2 val2 var val))
951 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
957 (define (class-slot-g-n-s class slot-name)
958 (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
959 (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
960 (slot-missing class slot-name)))))
961 (if (not (memq (slot-definition-allocation this-slot)
962 '(#:class #:each-subclass)))
963 (slot-missing class slot-name))
966 (define (class-slot-ref class slot)
967 (let ((x ((car (class-slot-g-n-s class slot)) #f)))
969 (slot-unbound class slot)
972 (define (class-slot-set! class slot value)
973 ((cadr (class-slot-g-n-s class slot)) #f value))
975 (define-method (slot-unbound (c <class>) (o <object>) s)
976 (goops-error "Slot `~S' is unbound in object ~S" s o))
978 (define-method (slot-unbound (c <class>) s)
979 (goops-error "Slot `~S' is unbound in class ~S" s c))
981 (define-method (slot-unbound (o <object>))
982 (goops-error "Unbound slot in object ~S" o))
984 (define-method (slot-missing (c <class>) (o <object>) s)
985 (goops-error "No slot with name `~S' in object ~S" s o))
987 (define-method (slot-missing (c <class>) s)
988 (goops-error "No class slot with name `~S' in class ~S" s c))
991 (define-method (slot-missing (c <class>) (o <object>) s value)
992 (slot-missing c o s))
994 ;;; Methods for the possible error we can encounter when calling a gf
996 (define-method (no-next-method (gf <generic>) args)
997 (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
999 (define-method (no-applicable-method (gf <generic>) args)
1000 (goops-error "No applicable method for ~S in call ~S"
1001 gf (cons (generic-function-name gf) args)))
1003 (define-method (no-method (gf <generic>) args)
1004 (goops-error "No method defined for ~S" gf))
1007 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
1010 (define-method (shallow-clone (self <object>))
1011 (let ((clone (%allocate-instance (class-of self) '()))
1012 (slots (map slot-definition-name
1013 (class-slots (class-of self)))))
1014 (for-each (lambda (slot)
1015 (if (slot-bound? self slot)
1016 (slot-set! clone slot (slot-ref self slot))))
1020 (define-method (deep-clone (self <object>))
1021 (let ((clone (%allocate-instance (class-of self) '()))
1022 (slots (map slot-definition-name
1023 (class-slots (class-of self)))))
1024 (for-each (lambda (slot)
1025 (if (slot-bound? self slot)
1026 (slot-set! clone slot
1027 (let ((value (slot-ref self slot)))
1028 (if (instance? value)
1035 ;;; {Class redefinition utilities}
1038 ;;; (class-redefinition OLD NEW)
1041 ;;; Has correct the following conditions:
1045 ;;; 1. New accessor specializers refer to new header
1049 ;;; 1. New class cpl refers to the new class header
1050 ;;; 2. Old class header exists on old super classes direct-subclass lists
1051 ;;; 3. New class header exists on new super classes direct-subclass lists
1053 (define-method (class-redefinition (old <class>) (new <class>))
1054 ;; Work on direct methods:
1055 ;; 1. Remove accessor methods from the old class
1056 ;; 2. Patch the occurences of new in the specializers by old
1057 ;; 3. Displace the methods from old to new
1058 (remove-class-accessors! old) ;; -1-
1059 (let ((methods (class-direct-methods new)))
1060 (for-each (lambda (m)
1061 (update-direct-method! m new old)) ;; -2-
1065 (append methods (class-direct-methods old))))
1067 ;; Substitute old for new in new cpl
1068 (set-car! (slot-ref new 'cpl) old)
1070 ;; Remove the old class from the direct-subclasses list of its super classes
1071 (for-each (lambda (c) (slot-set! c 'direct-subclasses
1072 (delv! old (class-direct-subclasses c))))
1073 (class-direct-supers old))
1075 ;; Replace the new class with the old in the direct-subclasses of the supers
1076 (for-each (lambda (c)
1077 (slot-set! c 'direct-subclasses
1078 (cons old (delv! new (class-direct-subclasses c)))))
1079 (class-direct-supers new))
1081 ;; Swap object headers
1082 (%modify-class old new)
1086 ;; Redefine all the subclasses of old to take into account modification
1089 (update-direct-subclass! c new old))
1090 (class-direct-subclasses new))
1092 ;; Invalidate class so that subsequent instances slot accesses invoke
1093 ;; change-object-class
1094 (slot-set! new 'redefined old)
1095 (%invalidate-class new) ;must come after slot-set!
1100 ;;; remove-class-accessors!
1103 (define-method (remove-class-accessors! (c <class>))
1104 (for-each (lambda (m)
1105 (if (is-a? m <accessor-method>)
1106 (let ((gf (slot-ref m 'generic-function)))
1107 ;; remove the method from its GF
1108 (slot-set! gf 'methods
1109 (delq1! m (slot-ref gf 'methods)))
1110 (invalidate-method-cache! gf)
1111 ;; remove the method from its specializers
1112 (remove-method-in-classes! m))))
1113 (class-direct-methods c)))
1116 ;;; update-direct-method!
1119 (define-method (update-direct-method! (m <method>)
1122 (let loop ((l (method-specializers m)))
1123 ;; Note: the <top> in dotted list is never used.
1124 ;; So we can work as if we had only proper lists.
1127 (if (eqv? (car l) old)
1132 ;;; update-direct-subclass!
1135 (define-method (update-direct-subclass! (c <class>)
1138 (class-redefinition c
1139 (make-class (class-direct-supers c)
1140 (class-direct-slots c)
1141 #:name (class-name c)
1142 #:metaclass (class-of c))))
1145 ;;; {Utilities for INITIALIZE methods}
1148 ;;; compute-slot-accessors
1150 (define (compute-slot-accessors class slots)
1153 (let ((getter-function (slot-definition-getter s))
1154 (setter-function (slot-definition-setter s))
1155 (accessor (slot-definition-accessor s)))
1157 (add-method! getter-function
1158 (compute-getter-method class g-n-s)))
1160 (add-method! setter-function
1161 (compute-setter-method class g-n-s)))
1164 (add-method! accessor
1165 (compute-getter-method class g-n-s))
1166 (add-method! (setter accessor)
1167 (compute-setter-method class g-n-s))))))
1168 slots (slot-ref class 'getters-n-setters)))
1170 (define-method (compute-getter-method (class <class>) slotdef)
1171 (let ((init-thunk (cadr slotdef))
1172 (g-n-s (cddr slotdef)))
1173 (make <accessor-method>
1174 #:specializers (list class)
1175 #:procedure (cond ((pair? g-n-s)
1176 (make-generic-bound-check-getter (car g-n-s)))
1178 (standard-get g-n-s))
1180 (bound-check-get g-n-s)))
1181 #:slot-definition slotdef)))
1183 (define-method (compute-setter-method (class <class>) slotdef)
1184 (let ((g-n-s (cddr slotdef)))
1185 (make <accessor-method>
1186 #:specializers (list class <top>)
1187 #:procedure (if (pair? g-n-s)
1189 (standard-set g-n-s))
1190 #:slot-definition slotdef)))
1192 (define (make-generic-bound-check-getter proc)
1193 (lambda (o) (assert-bound (proc o) o)))
1195 ;;; Pre-generate getters and setters for the first 20 slots.
1196 (define-syntax define-standard-accessor-method
1198 (define num-standard-pre-cache 20)
1200 ((_ ((proc n) arg ...) body)
1202 (let ((cache (vector #,@(map (lambda (n*)
1206 (iota num-standard-pre-cache)))))
1208 (if (< n #,num-standard-pre-cache)
1209 (vector-ref cache n)
1210 (lambda (arg ...) body)))))))))
1212 (define-standard-accessor-method ((bound-check-get n) o)
1213 (let ((x (struct-ref o n)))
1218 (define-standard-accessor-method ((standard-get n) o)
1221 (define-standard-accessor-method ((standard-set n) o v)
1222 (struct-set! o n v))
1224 ;;; compute-getters-n-setters
1226 (define (compute-getters-n-setters class slots)
1228 (define (compute-slot-init-function name s)
1229 (or (let ((thunk (slot-definition-init-thunk s)))
1233 (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
1234 name class thunk))))
1235 (let ((init (slot-definition-init-value s)))
1236 (and (not (unbound? init))
1237 (lambda () init)))))
1239 (define (verify-accessors slot l)
1240 (cond ((integer? l))
1241 ((not (and (list? l) (= (length l) 2)))
1242 (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
1247 (if (not (procedure? get))
1248 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1250 (if (not (procedure? set))
1251 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1252 slot class set))))))
1255 ;; The strange treatment of nfields is due to backward compatibility.
1256 (let* ((index (slot-ref class 'nfields))
1257 (g-n-s (compute-get-n-set class s))
1258 (size (- (slot-ref class 'nfields) index))
1259 (name (slot-definition-name s)))
1260 ;; NOTE: The following is interdependent with C macros
1261 ;; defined above goops.c:scm_sys_prep_layout_x.
1263 ;; For simple instance slots, we have the simplest form
1264 ;; '(name init-function . index)
1265 ;; For other slots we have
1266 ;; '(name init-function getter setter . alloc)
1268 ;; '(index size) for instance allocated slots
1269 ;; '() for other slots
1270 (verify-accessors name g-n-s)
1272 (cons (compute-slot-init-function name s)
1273 (if (or (integer? g-n-s)
1276 (append g-n-s (list index size)))))))
1281 ;;; Correct behaviour:
1283 ;;; (define-class food ())
1284 ;;; (define-class fruit (food))
1285 ;;; (define-class spice (food))
1286 ;;; (define-class apple (fruit))
1287 ;;; (define-class cinnamon (spice))
1288 ;;; (define-class pie (apple cinnamon))
1289 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1291 ;;; (define-class d ())
1292 ;;; (define-class e ())
1293 ;;; (define-class f ())
1294 ;;; (define-class b (d e))
1295 ;;; (define-class c (e f))
1296 ;;; (define-class a (b c))
1297 ;;; => cpl (a) = a b d c e f object top
1300 (define-method (compute-cpl (class <class>))
1301 (compute-std-cpl class class-direct-supers))
1305 (define (only-non-null lst)
1306 (filter (lambda (l) (not (null? l))) lst))
1308 (define (compute-std-cpl c get-direct-supers)
1309 (let ((c-direct-supers (get-direct-supers c)))
1310 (merge-lists (list c)
1311 (only-non-null (append (map class-precedence-list
1313 (list c-direct-supers))))))
1315 (define (merge-lists reversed-partial-result inputs)
1317 ((every null? inputs)
1318 (reverse! reversed-partial-result))
1320 (let* ((candidate (lambda (c)
1321 (and (not (any (lambda (l)
1325 (candidate-car (lambda (l)
1326 (and (not (null? l))
1327 (candidate (car l)))))
1328 (next (any candidate-car inputs)))
1330 (goops-error "merge-lists: Inconsistent precedence graph"))
1331 (let ((remove-next (lambda (l)
1332 (if (eq? (car l) next)
1335 (merge-lists (cons next reversed-partial-result)
1336 (only-non-null (map remove-next inputs))))))))
1338 ;; Modified from TinyClos:
1340 ;; A simple topological sort.
1342 ;; It's in this file so that both TinyClos and Objects can use it.
1344 ;; This is a fairly modified version of code I originally got from Anurag
1345 ;; Mendhekar <anurag@moose.cs.indiana.edu>.
1348 (define (compute-clos-cpl c get-direct-supers)
1349 (top-sort ((build-transitive-closure get-direct-supers) c)
1350 ((build-constraints get-direct-supers) c)
1351 (std-tie-breaker get-direct-supers)))
1354 (define (top-sort elements constraints tie-breaker)
1355 (let loop ((elements elements)
1356 (constraints constraints)
1358 (if (null? elements)
1360 (let ((can-go-in-now
1363 (every (lambda (constraint)
1364 (or (not (eq? (cadr constraint) x))
1365 (memq (car constraint) result)))
1368 (if (null? can-go-in-now)
1369 (goops-error "top-sort: Invalid constraints")
1370 (let ((choice (if (null? (cdr can-go-in-now))
1375 (filter (lambda (x) (not (eq? x choice)))
1378 (append result (list choice)))))))))
1380 (define (std-tie-breaker get-supers)
1381 (lambda (partial-cpl min-elts)
1382 (let loop ((pcpl (reverse partial-cpl)))
1383 (let ((current-elt (car pcpl)))
1384 (let ((ds-of-ce (get-supers current-elt)))
1385 (let ((common (filter (lambda (x)
1389 (if (null? (cdr pcpl))
1390 (goops-error "std-tie-breaker: Nothing valid")
1395 (define (build-transitive-closure get-follow-ons)
1397 (let track ((result '())
1401 (let ((next (car pending)))
1402 (if (memq next result)
1403 (track result (cdr pending))
1404 (track (cons next result)
1405 (append (get-follow-ons next)
1406 (cdr pending)))))))))
1408 (define (build-constraints get-follow-ons)
1410 (let loop ((elements ((build-transitive-closure get-follow-ons) x))
1413 (if (or (null? this-one) (null? (cdr this-one)))
1414 (if (null? elements)
1416 (loop (cdr elements)
1417 (cons (car elements)
1418 (get-follow-ons (car elements)))
1422 (cons (list (car this-one) (cadr this-one))
1425 ;;; compute-get-n-set
1427 (define-method (compute-get-n-set (class <class>) s)
1428 (case (slot-definition-allocation s)
1429 ((#:instance) ;; Instance slot
1430 ;; get-n-set is just its offset
1431 (let ((already-allocated (slot-ref class 'nfields)))
1432 (slot-set! class 'nfields (+ already-allocated 1))
1435 ((#:class) ;; Class slot
1436 ;; Class-slots accessors are implemented as 2 closures around
1437 ;; a Scheme variable. As instance slots, class slots must be
1438 ;; unbound at init time.
1439 (let ((name (slot-definition-name s)))
1440 (if (memq name (map slot-definition-name (class-direct-slots class)))
1441 ;; This slot is direct; create a new shared variable
1442 (make-closure-variable class)
1443 ;; Slot is inherited. Find its definition in superclass
1444 (let loop ((l (cdr (class-precedence-list class))))
1445 (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1448 (loop (cdr l))))))))
1450 ((#:each-subclass) ;; slot shared by instances of direct subclass.
1451 ;; (Thomas Buerger, April 1998)
1452 (make-closure-variable class))
1454 ((#:virtual) ;; No allocation
1455 ;; slot-ref and slot-set! function must be given by the user
1456 (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
1457 (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
1458 (if (not (and get set))
1459 (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
1462 (else (next-method))))
1464 (define (make-closure-variable class)
1465 (let ((shared-variable (make-unbound)))
1466 (list (lambda (o) shared-variable)
1467 (lambda (o v) (set! shared-variable v)))))
1469 (define-method (compute-get-n-set (o <object>) s)
1470 (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1472 (define-method (compute-slots (class <class>))
1473 (%compute-slots class))
1479 (define-method (initialize (object <object>) initargs)
1480 (%initialize-object object initargs))
1482 (define-method (initialize (class <class>) initargs)
1484 (let ((dslots (get-keyword #:slots initargs '()))
1485 (supers (get-keyword #:dsupers initargs '())))
1486 (slot-set! class 'name (get-keyword #:name initargs '???))
1487 (slot-set! class 'direct-supers supers)
1488 (slot-set! class 'direct-slots dslots)
1489 (slot-set! class 'direct-subclasses '())
1490 (slot-set! class 'direct-methods '())
1491 (slot-set! class 'cpl (compute-cpl class))
1492 (slot-set! class 'redefined #f)
1493 (let ((slots (compute-slots class)))
1494 (slot-set! class 'slots slots)
1495 (slot-set! class 'nfields 0)
1496 (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1498 ;; Build getters - setters - accessors
1499 (compute-slot-accessors class slots))
1501 ;; Update the "direct-subclasses" of each inherited classes
1502 (for-each (lambda (x)
1505 (cons class (slot-ref x 'direct-subclasses))))
1508 ;; Support for the underlying structs:
1510 ;; Set the layout slot
1511 (%prep-layout! class)
1512 ;; Inherit class flags (invisible on scheme level) from supers
1513 (%inherit-magic! class supers)))
1515 (define (initialize-object-procedure object initargs)
1516 (let ((proc (get-keyword #:procedure initargs #f)))
1519 (apply slot-set! object 'procedure proc))
1521 (slot-set! object 'procedure proc)))))
1523 (define-method (initialize (applicable-struct <applicable-struct>) initargs)
1525 (initialize-object-procedure applicable-struct initargs))
1527 (define-method (initialize (generic <generic>) initargs)
1528 (let ((previous-definition (get-keyword #:default initargs #f))
1529 (name (get-keyword #:name initargs #f)))
1531 (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1533 (apply previous-definition args)))
1536 (set-procedure-property! generic 'name name))
1539 (define-method (initialize (gws <generic-with-setter>) initargs)
1541 (%set-object-setter! gws (get-keyword #:setter initargs #f)))
1543 (define-method (initialize (eg <extended-generic>) initargs)
1545 (slot-set! eg 'extends (get-keyword #:extends initargs '())))
1547 (define dummy-procedure (lambda args *unspecified*))
1549 (define-method (initialize (method <method>) initargs)
1551 (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1552 (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1553 (slot-set! method 'procedure
1554 (get-keyword #:procedure initargs #f))
1555 (slot-set! method 'formals (get-keyword #:formals initargs '()))
1556 (slot-set! method 'body (get-keyword #:body initargs '()))
1557 (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
1564 (define (change-object-class old-instance old-class new-class)
1565 (let ((new-instance (allocate-instance new-class '())))
1566 ;; Initialize the slots of the new instance
1567 (for-each (lambda (slot)
1568 (if (and (slot-exists-using-class? old-class old-instance slot)
1569 (eq? (slot-definition-allocation
1570 (class-slot-definition old-class slot))
1572 (slot-bound-using-class? old-class old-instance slot))
1573 ;; Slot was present and allocated in old instance; copy it
1574 (slot-set-using-class!
1578 (slot-ref-using-class old-class old-instance slot))
1579 ;; slot was absent; initialize it with its default value
1580 (let ((init (slot-init-function new-class slot)))
1582 (slot-set-using-class!
1586 (apply init '()))))))
1587 (map slot-definition-name (class-slots new-class)))
1588 ;; Exchange old and new instance in place to keep pointers valid
1589 (%modify-instance old-instance new-instance)
1590 ;; Allow class specific updates of instances (which now are swapped)
1591 (update-instance-for-different-class new-instance old-instance)
1595 (define-method (update-instance-for-different-class (old-instance <object>)
1598 ;;not really important what we do, we just need a default method
1601 (define-method (change-class (old-instance <object>) (new-class <class>))
1602 (change-object-class old-instance (class-of old-instance) new-class))
1607 ;;; A new definition which overwrites the previous one which was built-in
1610 (define-method (allocate-instance (class <class>) initargs)
1611 (%allocate-instance class initargs))
1613 (define-method (make-instance (class <class>) . initargs)
1614 (let ((instance (allocate-instance class initargs)))
1615 (initialize instance initargs)
1618 (define make make-instance)
1623 ;;; Protocol for calling standard generic functions. This protocol is
1624 ;;; not used for real <generic> functions (in this case we use a
1625 ;;; completely C hard-coded protocol). Apply-generic is used by
1626 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1627 ;;; The code below is similar to the first MOP described in AMOP. In
1628 ;;; particular, it doesn't used the currified approach to gf
1629 ;;; call. There are 2 reasons for that:
1630 ;;; - the protocol below is exposed to mimic completely the one written in C
1631 ;;; - the currified protocol would be imho inefficient in C.
1634 (define-method (apply-generic (gf <generic>) args)
1635 (if (null? (slot-ref gf 'methods))
1636 (no-method gf args))
1637 (let ((methods (compute-applicable-methods gf args)))
1639 (apply-methods gf (sort-applicable-methods gf methods args) args)
1640 (no-applicable-method gf args))))
1642 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1644 (define %%compute-applicable-methods
1645 (make <generic> #:name 'compute-applicable-methods))
1647 (define-method (%%compute-applicable-methods (gf <generic>) args)
1648 (%compute-applicable-methods gf args))
1650 (set! compute-applicable-methods %%compute-applicable-methods)
1652 (define-method (sort-applicable-methods (gf <generic>) methods args)
1653 (let ((targs (map class-of args)))
1654 (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1656 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1657 (%method-more-specific? m1 m2 targs))
1659 (define-method (apply-method (gf <generic>) methods build-next args)
1660 (apply (method-procedure (car methods))
1661 (build-next (cdr methods) args)
1664 (define-method (apply-methods (gf <generic>) (l <list>) args)
1665 (letrec ((next (lambda (procs args)
1667 (let ((a (if (null? new-args) args new-args)))
1669 (no-next-method gf a)
1670 (apply-method gf procs next a)))))))
1671 (apply-method gf l next args)))
1673 ;; We don't want the following procedure to turn up in backtraces:
1674 (for-each (lambda (proc)
1675 (set-procedure-property! proc 'system-procedure #t))
1679 no-applicable-method
1684 ;;; {<composite-metaclass> and <active-metaclass>}
1687 ;(autoload "active-slot" <active-metaclass>)
1688 ;(autoload "composite-slot" <composite-metaclass>)
1689 ;(export <composite-metaclass> <active-metaclass>)
1697 ;; duplicate the standard list->set function but using eq instead of
1698 ;; eqv which really sucks a lot, uselessly here
1700 (define (list2set l)
1705 ((memq (car l) res) (loop (cdr l) res))
1706 (else (loop (cdr l) (cons (car l) res))))))
1708 (define (class-subclasses c)
1709 (letrec ((allsubs (lambda (c)
1710 (cons c (mapappend allsubs
1711 (class-direct-subclasses c))))))
1712 (list2set (cdr (allsubs c)))))
1714 (define (class-methods c)
1715 (list2set (mapappend class-direct-methods
1716 (cons c (class-subclasses c)))))
1719 ;;; {Final initialization}
1722 ;; Tell C code that the main bulk of Goops has been loaded
1729 ;;; {SMOB and port classes}
1732 (define <arbiter> (find-subclass <top> '<arbiter>))
1733 (define <promise> (find-subclass <top> '<promise>))
1734 (define <thread> (find-subclass <top> '<thread>))
1735 (define <mutex> (find-subclass <top> '<mutex>))
1736 (define <condition-variable> (find-subclass <top> '<condition-variable>))
1737 (define <regexp> (find-subclass <top> '<regexp>))
1738 (define <hook> (find-subclass <top> '<hook>))
1739 (define <bitvector> (find-subclass <top> '<bitvector>))
1740 (define <random-state> (find-subclass <top> '<random-state>))
1741 (define <async> (find-subclass <top> '<async>))
1742 (define <directory> (find-subclass <top> '<directory>))
1743 (define <keyword> (find-subclass <top> '<keyword>))
1744 (define <array> (find-subclass <top> '<array>))
1745 (define <character-set> (find-subclass <top> '<character-set>))
1746 (define <dynamic-object> (find-subclass <top> '<dynamic-object>))
1747 (define <guardian> (find-subclass <applicable> '<guardian>))
1748 (define <macro> (find-subclass <top> '<macro>))
1750 (define (define-class-subtree class)
1751 (define! (class-name class) class)
1752 (for-each define-class-subtree (class-direct-subclasses class)))
1754 (define-class-subtree (find-subclass <port> '<file-port>))