3 ;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 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 #:use-module (ice-9 match)
30 #:use-module (oop goops util)
31 #:use-module (system base target)
32 #:export-syntax (define-class class standard-define-class
33 define-generic define-accessor define-method
34 define-extended-generic define-extended-generics
36 #:export ( ;; The root of everything.
41 <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
42 <read-only-slot> <self-slot> <protected-opaque-slot>
43 <protected-hidden-slot> <protected-read-only-slot>
44 <scm-slot> <int-slot> <float-slot> <double-slot>
46 ;; Methods are implementations of generic functions.
47 <method> <accessor-method>
49 ;; Applicable objects, either procedures or applicable structs.
50 <procedure-class> <applicable>
51 <procedure> <primitive-generic>
53 ;; Applicable structs.
54 <applicable-struct-class> <applicable-struct-with-setter-class>
55 <applicable-struct> <applicable-struct-with-setter>
56 <generic> <extended-generic>
57 <generic-with-setter> <extended-generic-with-setter>
58 <accessor> <extended-accessor>
60 ;; Types with their own allocated typecodes.
61 <boolean> <char> <list> <pair> <null> <string> <symbol>
62 <vector> <bytevector> <uvec> <foreign> <hashtable>
63 <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
67 <number> <complex> <real> <integer> <fraction>
72 ;; Particular SMOB data types. All SMOB types have
73 ;; corresponding classes, which may be obtained via class-of,
74 ;; once you have an instance. Perhaps FIXME to provide a
75 ;; smob-type-name->class procedure.
76 <arbiter> <promise> <thread> <mutex> <condition-variable>
77 <regexp> <hook> <bitvector> <random-state> <async>
78 <directory> <array> <character-set>
79 <dynamic-object> <guardian> <macro>
85 <port> <input-port> <output-port> <input-output-port>
87 ;; Like SMOB types, all port types have their own classes,
88 ;; which can be accessed via `class-of' once you have an
89 ;; instance. Here we export bindings just for file ports.
91 <file-input-port> <file-output-port> <file-input-output-port>
94 ensure-metaclass ensure-metaclass-with-supers
96 make-generic ensure-generic
98 make-accessor ensure-accessor
100 class-slot-ref class-slot-set! slot-unbound slot-missing
101 slot-definition-name slot-definition-options
102 slot-definition-allocation
104 slot-definition-getter slot-definition-setter
105 slot-definition-accessor
106 slot-definition-init-value slot-definition-init-form
107 slot-definition-init-thunk slot-definition-init-keyword
108 slot-init-function class-slot-definition
110 compute-cpl compute-std-cpl compute-get-n-set compute-slots
111 compute-getter-method compute-setter-method
112 allocate-instance initialize make-instance make
113 no-next-method no-applicable-method no-method
114 change-class update-instance-for-different-class
115 shallow-clone deep-clone
117 apply-generic apply-method apply-methods
118 compute-applicable-methods %compute-applicable-methods
119 method-more-specific? sort-applicable-methods
120 class-subclasses class-methods
122 min-fixnum max-fixnum
124 ;;; *fixme* Should go into goops.c
125 instance? slot-ref-using-class
126 slot-set-using-class! slot-bound-using-class?
127 slot-exists-using-class? slot-ref slot-set! slot-bound?
128 class-name class-direct-supers class-direct-subclasses
129 class-direct-methods class-direct-slots class-precedence-list
131 generic-function-name
132 generic-function-methods method-generic-function
133 method-specializers method-formals
134 primitive-generic-generic enable-primitive-generic!
135 method-procedure accessor-method-slot-definition
136 slot-exists? make find-method get-keyword)
139 ;; XXX FIXME: figure out why the 'eval-when's in this file must use
140 ;; 'compile' and must avoid 'expand', but only in 2.2, and only when
141 ;; compiling something that imports goops, e.g. (ice-9 occam-channel),
142 ;; before (oop goops) itself has been compiled.
144 ;; First initialize the builtin part of GOOPS
145 (eval-when (compile load eval)
146 (load-extension (string-append "libguile-" (effective-version))
147 "scm_init_goops_builtins"))
149 (eval-when (compile load eval)
150 (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
151 (add-interesting-primitive! 'class-of))
153 (define-syntax macro-fold-left
155 ((_ folder seed ()) seed)
156 ((_ folder seed (head . tail))
157 (macro-fold-left folder (folder head seed) tail))))
159 (define-syntax macro-fold-right
161 ((_ folder seed ()) seed)
162 ((_ folder seed (head . tail))
163 (folder head (macro-fold-right folder seed tail)))))
165 (define-syntax fold-<class>-slots
168 '((layout <protected-read-only-slot>)
169 (flags <hidden-slot>)
171 (instance-finalizer <hidden-slot>)
173 (name <protected-hidden-slot>)
174 (reserved-0 <hidden-slot>)
175 (reserved-1 <hidden-slot>)
187 ;; The datum->syntax makes it as if the identifiers in `slots'
188 ;; were present in the initial form, which allows them to be used
189 ;; as (components of) introduced identifiers.
190 #`(fold visit seed #,(datum->syntax #'visit slots))))))
192 ;; Define class-index-layout to 0, class-index-flags to 1, and so on.
193 (let-syntax ((define-class-index
195 (define (id-append ctx a b)
196 (datum->syntax ctx (symbol-append (syntax->datum a)
198 (define (tail-length tail)
201 ((visit head tail) (1+ (tail-length #'tail)))))
205 (define #,(id-append #'name #'class-index- #'name)
206 #,(tail-length #'tail))
208 (fold-<class>-slots macro-fold-left define-class-index (begin)))
210 (define-syntax-rule (define-class-accessor name docstring field)
215 (scm-error 'wrong-type-arg #f "Not a class: ~S"
217 (struct-ref val field))))
219 (define-class-accessor class-name
220 "Return the class name of @var{obj}."
222 (define-class-accessor class-direct-supers
223 "Return the direct superclasses of the class @var{obj}."
224 class-index-direct-supers)
225 (define-class-accessor class-direct-slots
226 "Return the direct slots of the class @var{obj}."
227 class-index-direct-slots)
228 (define-class-accessor class-direct-subclasses
229 "Return the direct subclasses of the class @var{obj}."
230 class-index-direct-subclasses)
231 (define-class-accessor class-direct-methods
232 "Return the direct methods of the class @var{obj}."
233 class-index-direct-methods)
234 (define-class-accessor class-precedence-list
235 "Return the class precedence list of the class @var{obj}."
237 (define-class-accessor class-slots
238 "Return the slot list of the class @var{obj}."
241 ;;; The standard class precedence list computation algorithm
243 ;;; Correct behaviour:
245 ;;; (define-class food ())
246 ;;; (define-class fruit (food))
247 ;;; (define-class spice (food))
248 ;;; (define-class apple (fruit))
249 ;;; (define-class cinnamon (spice))
250 ;;; (define-class pie (apple cinnamon))
251 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
253 ;;; (define-class d ())
254 ;;; (define-class e ())
255 ;;; (define-class f ())
256 ;;; (define-class b (d e))
257 ;;; (define-class c (e f))
258 ;;; (define-class a (b c))
259 ;;; => cpl (a) = a b d c e f object top
262 (define (compute-std-cpl c get-direct-supers)
263 (define (only-non-null lst)
264 (filter (lambda (l) (not (null? l))) lst))
266 (define (merge-lists reversed-partial-result inputs)
268 ((every null? inputs)
269 (reverse! reversed-partial-result))
271 (let* ((candidate (lambda (c)
272 (and (not (any (lambda (l)
276 (candidate-car (lambda (l)
278 (candidate (car l)))))
279 (next (any candidate-car inputs)))
281 (goops-error "merge-lists: Inconsistent precedence graph"))
282 (let ((remove-next (lambda (l)
283 (if (eq? (car l) next)
286 (merge-lists (cons next reversed-partial-result)
287 (only-non-null (map remove-next inputs))))))))
288 (let ((c-direct-supers (get-direct-supers c)))
289 (merge-lists (list c)
290 (only-non-null (append (map class-precedence-list
292 (list c-direct-supers))))))
294 ;; Bootstrap version.
295 (define (compute-cpl class)
296 (compute-std-cpl class class-direct-supers))
298 (define (build-slots-list dslots cpl)
299 (define (check-cpl slots class-slots)
300 (when (or-map (lambda (slot-def) (assq (car slot-def) slots))
302 (scm-error 'misc-error #f
303 "a predefined <class> inherited field cannot be redefined"
305 (define (remove-duplicate-slots slots)
306 (let lp ((slots (reverse slots)) (res '()) (seen '()))
309 ((memq (caar slots) seen)
310 (lp (cdr slots) res seen))
312 (lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen))))))
313 (let* ((class-slots (and (memq <class> cpl)
314 (struct-ref <class> class-index-slots))))
316 (check-cpl dslots class-slots))
317 (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
319 (remove-duplicate-slots (append class-slots res))
320 (let* ((head (car cpl))
322 (new-slots (struct-ref head class-index-direct-slots)))
325 (lp cpl (append new-slots res) class-slots))
327 ;; Move class slots to the head of the list.
328 (lp cpl res new-slots))
330 (check-cpl new-slots class-slots)
331 (lp cpl (append new-slots res) class-slots))))))))
333 (define (%compute-getters-n-setters slots)
334 (define (compute-init-thunk options)
336 ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val)))
337 ((kw-arg-ref options #:init-thunk))
339 (let lp ((slots slots) (n 0))
342 (((name . options) . slots)
343 (cons (cons name (cons (compute-init-thunk options) n))
344 (lp slots (1+ n)))))))
346 (define (%compute-layout slots getters-n-setters nfields is-class?)
347 (define (instance-allocated? g-n-s)
349 ((name init-thunk . (? exact-integer? index)) #t)
350 ((name init-thunk getter setter index size) #t)
353 (define (allocated-index g-n-s)
355 ((name init-thunk . (? exact-integer? index)) index)
356 ((name init-thunk getter setter index size) index)))
358 (define (allocated-size g-n-s)
360 ((name init-thunk . (? exact-integer? index)) 1)
361 ((name init-thunk getter setter index size) size)))
363 (define (slot-protection-and-kind options)
364 (define (subclass? class parent)
365 (memq parent (class-precedence-list class)))
366 (let ((type (kw-arg-ref options #:class)))
367 (if (and type (subclass? type <foreign-slot>))
369 ((subclass? type <self-slot>) #\s)
370 ((subclass? type <protected-slot>) #\p)
373 ((subclass? type <opaque-slot>) #\o)
374 ((subclass? type <read-only-slot>) #\r)
375 ((subclass? type <hidden-slot>) #\h)
379 (let ((layout (make-string (* nfields 2))))
380 (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
381 (match getters-n-setters
383 (unless (= n nfields) (error "bad nfields"))
384 (unless (null? slots) (error "inconsistent g-n-s/slots"))
386 (let ((class-layout (struct-ref <class> class-index-layout)))
387 (unless (string-prefix? (symbol->string class-layout) layout)
388 (error "bad layout for class"))))
390 ((g-n-s . getters-n-setters)
392 (((name . options) . slots)
394 ((instance-allocated? g-n-s)
395 (unless (< n nfields) (error "bad nfields"))
396 (unless (= n (allocated-index g-n-s)) (error "bad allocation"))
397 (call-with-values (lambda () (slot-protection-and-kind options))
398 (lambda (protection kind)
399 (let init ((n n) (size (allocated-size g-n-s)))
401 ((zero? size) (lp n slots getters-n-setters))
403 (string-set! layout (* n 2) protection)
404 (string-set! layout (1+ (* n 2)) kind)
405 (init (1+ n) (1- size))))))))
407 (lp n slots getters-n-setters))))))))))
409 (define (%prep-layout! class)
410 (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
411 (layout (%compute-layout
412 (struct-ref class class-index-slots)
413 (struct-ref class class-index-getters-n-setters)
414 (struct-ref class class-index-nfields)
416 (%init-layout! class layout)))
418 (define (make-standard-class class name dsupers dslots)
419 (let ((z (make-struct/no-tail class)))
420 (struct-set! z class-index-direct-supers dsupers)
421 (let* ((cpl (compute-cpl z))
422 (dslots (map (lambda (slot)
423 (if (pair? slot) slot (list slot)))
425 (slots (build-slots-list dslots cpl))
426 (nfields (length slots))
427 (g-n-s (%compute-getters-n-setters slots)))
428 (struct-set! z class-index-name name)
429 (struct-set! z class-index-direct-slots dslots)
430 (struct-set! z class-index-direct-subclasses '())
431 (struct-set! z class-index-direct-methods '())
432 (struct-set! z class-index-cpl cpl)
433 (struct-set! z class-index-slots slots)
434 (struct-set! z class-index-nfields nfields)
435 (struct-set! z class-index-getters-n-setters g-n-s)
436 (struct-set! z class-index-redefined #f)
437 (for-each (lambda (super)
439 (struct-ref super class-index-direct-subclasses)))
440 (struct-set! super class-index-direct-subclasses
441 (cons z subclasses))))
444 (%inherit-magic! z dsupers)
449 ;; The specialized slot classes have not been defined
450 ;; yet; initialize <class> with unspecialized slots.
452 ((_ (name) tail) (cons (list 'name) tail))
453 ((_ (name class) tail) (cons (list 'name) tail)))))
454 (let ((dslots (fold-<class>-slots macro-fold-right visit '())))
455 (%make-root-class '<class> dslots (%compute-getters-n-setters dslots)))))
457 (define-syntax define-standard-class
459 ((define-standard-class name (super ...) #:metaclass meta slot ...)
461 (make-standard-class meta 'name (list super ...) '(slot ...))))
462 ((define-standard-class name (super ...) slot ...)
463 (define-standard-class name (super ...) #:metaclass <class> slot ...))))
465 (define-standard-class <top> ())
466 (define-standard-class <object> (<top>))
468 ;; <top>, <object>, and <class> were partially initialized. Correct
470 (struct-set! <object> class-index-direct-subclasses (list <class>))
471 (struct-set! <class> class-index-direct-supers (list <object>))
472 (struct-set! <class> class-index-cpl (list <class> <object> <top>))
474 (define-standard-class <foreign-slot> (<top>))
475 (define-standard-class <protected-slot> (<foreign-slot>))
476 (define-standard-class <hidden-slot> (<foreign-slot>))
477 (define-standard-class <opaque-slot> (<foreign-slot>))
478 (define-standard-class <read-only-slot> (<foreign-slot>))
479 (define-standard-class <self-slot> (<read-only-slot>))
480 (define-standard-class <protected-opaque-slot> (<protected-slot>
482 (define-standard-class <protected-hidden-slot> (<protected-slot>
484 (define-standard-class <protected-read-only-slot> (<protected-slot>
486 (define-standard-class <scm-slot> (<protected-slot>))
487 (define-standard-class <int-slot> (<foreign-slot>))
488 (define-standard-class <float-slot> (<foreign-slot>))
489 (define-standard-class <double-slot> (<foreign-slot>))
491 ;; Finish initialization of <class> with specialized slots.
495 (cons (list 'name) tail))
496 ((_ (name class) tail)
497 (cons (list 'name #:class class) tail)))))
498 (let* ((dslots (fold-<class>-slots macro-fold-right visit '()))
499 (g-n-s (%compute-getters-n-setters dslots)))
500 (struct-set! <class> class-index-direct-slots dslots)
501 (struct-set! <class> class-index-slots dslots)
502 (struct-set! <class> class-index-getters-n-setters g-n-s)))
504 ;; Applicables and their classes.
505 (define-standard-class <procedure-class> (<class>))
506 (define-standard-class <applicable-struct-class>
508 (define-standard-class <applicable-struct-with-setter-class>
509 (<applicable-struct-class>))
510 (%bless-applicable-struct-vtables! <applicable-struct-class>
511 <applicable-struct-with-setter-class>)
513 (define-standard-class <applicable> (<top>))
514 (define-standard-class <applicable-struct> (<object> <applicable>)
515 #:metaclass <applicable-struct-class>
517 (define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
518 #:metaclass <applicable-struct-with-setter-class>
520 (define-standard-class <generic> (<applicable-struct>)
521 #:metaclass <applicable-struct-class>
523 (n-specialized #:init-value 0)
524 (extended-by #:init-value ())
526 (%bless-pure-generic-vtable! <generic>)
527 (define-standard-class <extended-generic> (<generic>)
528 #:metaclass <applicable-struct-class>
529 (extends #:init-value ()))
530 (%bless-pure-generic-vtable! <extended-generic>)
531 (define-standard-class <generic-with-setter> (<generic>
532 <applicable-struct-with-setter>)
533 #:metaclass <applicable-struct-with-setter-class>)
534 (%bless-pure-generic-vtable! <generic-with-setter>)
535 (define-standard-class <accessor> (<generic-with-setter>)
536 #:metaclass <applicable-struct-with-setter-class>)
537 (%bless-pure-generic-vtable! <accessor>)
538 (define-standard-class <extended-generic-with-setter> (<extended-generic>
539 <generic-with-setter>)
540 #:metaclass <applicable-struct-with-setter-class>)
541 (%bless-pure-generic-vtable! <extended-generic-with-setter>)
542 (define-standard-class <extended-accessor> (<accessor>
543 <extended-generic-with-setter>)
544 #:metaclass <applicable-struct-with-setter-class>)
545 (%bless-pure-generic-vtable! <extended-accessor>)
548 (define-standard-class <method> (<object>)
555 (define-standard-class <accessor-method> (<method>)
556 (slot-definition #:init-keyword #:slot-definition))
558 ;; Primitive types classes
559 (define-standard-class <boolean> (<top>))
560 (define-standard-class <char> (<top>))
561 (define-standard-class <list> (<top>))
562 (define-standard-class <pair> (<list>))
563 (define-standard-class <null> (<list>))
564 (define-standard-class <string> (<top>))
565 (define-standard-class <symbol> (<top>))
566 (define-standard-class <vector> (<top>))
567 (define-standard-class <foreign> (<top>))
568 (define-standard-class <hashtable> (<top>))
569 (define-standard-class <fluid> (<top>))
570 (define-standard-class <dynamic-state> (<top>))
571 (define-standard-class <frame> (<top>))
572 (define-standard-class <vm-continuation> (<top>))
573 (define-standard-class <bytevector> (<top>))
574 (define-standard-class <uvec> (<bytevector>))
575 (define-standard-class <array> (<top>))
576 (define-standard-class <bitvector> (<top>))
577 (define-standard-class <number> (<top>))
578 (define-standard-class <complex> (<number>))
579 (define-standard-class <real> (<complex>))
580 (define-standard-class <integer> (<real>))
581 (define-standard-class <fraction> (<real>))
582 (define-standard-class <keyword> (<top>))
583 (define-standard-class <unknown> (<top>))
584 (define-standard-class <procedure> (<applicable>)
585 #:metaclass <procedure-class>)
586 (define-standard-class <primitive-generic> (<procedure>)
587 #:metaclass <procedure-class>)
588 (define-standard-class <port> (<top>))
589 (define-standard-class <input-port> (<port>))
590 (define-standard-class <output-port> (<port>))
591 (define-standard-class <input-output-port> (<input-port> <output-port>))
593 (define (%invalidate-method-cache! gf)
594 (slot-set! gf 'procedure (delayed-compile gf))
595 (slot-set! gf 'effective-methods '()))
598 (define (invalidate-method-cache! gf)
599 (%invalidate-method-cache! gf))
601 ;; A simple make which will be redefined later. This version handles
602 ;; only creation of gf, methods and classes (no instances).
604 ;; Since this code will disappear when Goops will be fully booted,
605 ;; no precaution is taken to be efficient.
607 (define (make class . args)
609 ((or (eq? class <generic>) (eq? class <accessor>))
610 (let ((z (make-struct/no-tail class #f '() 0 '())))
611 (set-procedure-property! z 'name (get-keyword #:name args #f))
612 (invalidate-method-cache! z)
613 (when (eq? class <accessor>)
614 (let ((setter (get-keyword #:setter args #f)))
616 (slot-set! z 'setter setter))))
619 (let ((z (%allocate-instance class args)))
621 ((or (eq? class <method>) (eq? class <accessor-method>))
622 (for-each (match-lambda
624 (slot-set! z slot (get-keyword kw args default))))
625 '((#:generic-function generic-function #f)
626 (#:specializers specializers ())
627 (#:procedure procedure #f)
628 (#:formals formals ())
630 (#:make-procedure make-procedure #f))))
631 ((memq <class> (class-precedence-list class))
632 (for-each (match-lambda
634 (slot-set! z slot (get-keyword kw args default))))
636 (#:dsupers direct-supers ())
637 (#:slots direct-slots ())
640 (error "boot `make' does not support this class" class)))
643 (define *dispatch-module* (current-module))
646 ;;; Generic functions have an applicable-methods cache associated with
647 ;;; them. Every distinct set of types that is dispatched through a
648 ;;; generic adds an entry to the cache. This cache gets compiled out to
649 ;;; a dispatch procedure. In steady-state, this dispatch procedure is
650 ;;; never recompiled; but during warm-up there is some churn, both to
651 ;;; the cache and to the dispatch procedure.
653 ;;; So what is the deal if warm-up happens in a multithreaded context?
654 ;;; There is indeed a window between missing the cache for a certain set
655 ;;; of arguments, and then updating the cache with the newly computed
656 ;;; applicable methods. One of the updaters is liable to lose their new
659 ;;; This is actually OK though, because a subsequent cache miss for the
660 ;;; race loser will just cause memoization to try again. The cache will
661 ;;; eventually be consistent. We're not mutating the old part of the
662 ;;; cache, just consing on the new entry.
664 ;;; It doesn't even matter if the dispatch procedure and the cache are
665 ;;; inconsistent -- most likely the type-set that lost the dispatch
666 ;;; procedure race will simply re-trigger a memoization, but since the
667 ;;; winner isn't in the effective-methods cache, it will likely also
668 ;;; re-trigger a memoization, and the cache will finally be consistent.
669 ;;; As you can see there is a possibility for ping-pong effects, but
670 ;;; it's unlikely given the shortness of the window between slot-set!
671 ;;; invocations. We could add a mutex, but it is strictly unnecessary,
672 ;;; and would add runtime cost and complexity.
675 (define (emit-linear-dispatch gf-sym nargs methods free rest?)
676 (define (gen-syms n stem)
677 (let lp ((n (1- n)) (syms '()))
680 (lp (1- n) (cons (gensym stem) syms)))))
681 (let* ((args (gen-syms nargs "a"))
682 (types (gen-syms nargs "t")))
683 (let lp ((methods methods)
685 (exp `(cache-miss ,gf-sym
691 (values `(,(if rest? `(,@args . rest) args)
692 (let ,(map (lambda (t a)
699 (let preddy ((free free)
701 (specs (vector-ref (car methods) 1))
704 (let ((m-sym (gensym "p")))
706 (acons (vector-ref (car methods) 3)
711 `(apply ,m-sym ,@args rest)
714 (let ((var (assq-ref free (car specs))))
719 (cons `(eq? ,(car types) ,var)
721 (let ((var (gensym "c")))
722 (preddy (acons (car specs) var free)
725 (cons `(eq? ,(car types) ,var)
728 (define (compute-dispatch-procedure gf cache)
730 (let lp ((ls cache) (nreq -1) (nrest -1))
733 (collate (make-vector (1+ nreq) '())
734 (make-vector (1+ nrest) '())))
735 ((vector-ref (car ls) 2) ; rest
736 (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
738 (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
739 (define (collate req rest)
744 ((vector-ref (car ls) 2) ; rest
745 (let ((n (vector-ref (car ls) 0)))
746 (vector-set! rest n (cons (car ls) (vector-ref rest n)))
749 (let ((n (vector-ref (car ls) 0)))
750 (vector-set! req n (cons (car ls) (vector-ref req n)))
752 (define (emit req rest)
753 (let ((gf-sym (gensym "g")))
754 (define (emit-rest n clauses free)
755 (if (< n (vector-length rest))
756 (let ((methods (vector-ref rest n)))
759 (emit-rest (1+ n) clauses free))
760 ;; FIXME: hash dispatch
764 (emit-linear-dispatch gf-sym n methods free #t))
765 (lambda (clause free)
766 (emit-rest (1+ n) (cons clause clauses) free))))))
767 (emit-req (1- (vector-length req)) clauses free)))
768 (define (emit-req n clauses free)
770 (comp `(lambda ,(map cdr free)
771 (case-lambda ,@clauses))
773 (let ((methods (vector-ref req n)))
776 (emit-req (1- n) clauses free))
777 ;; FIXME: hash dispatch
781 (emit-linear-dispatch gf-sym n methods free #f))
782 (lambda (clause free)
783 (emit-req (1- n) (cons clause clauses) free))))))))
786 (if (or (zero? (vector-length rest))
787 (null? (vector-ref rest 0)))
788 (list `(args (cache-miss ,gf-sym args)))
790 (acons gf gf-sym '()))))
791 (define (comp exp vals)
792 ;; When cross-compiling Guile itself, the native Guile must generate
793 ;; code for the host.
794 (with-target %host-type
796 (let ((p ((@ (system base compile) compile) exp
797 #:env *dispatch-module*
799 #:opts '(#:partial-eval? #f #:cse? #f))))
805 ;; o/~ ten, nine, eight
806 ;; sometimes that's just how it goes
809 ;; get out before it blows o/~
811 (define timer-init 30)
812 (define (delayed-compile gf)
813 (let ((timer timer-init))
815 (set! timer (1- timer))
818 (let ((dispatch (compute-dispatch-procedure
819 gf (slot-ref gf 'effective-methods))))
820 (slot-set! gf 'procedure dispatch)
821 (apply dispatch args)))
823 ;; interestingly, this catches recursive compilation attempts as
824 ;; well; in that case, timer is negative
825 (cache-dispatch gf args))))))
827 (define (cache-dispatch gf args)
828 (define (map-until n f ls)
829 (if (or (zero? n) (null? ls))
831 (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
832 (define (equal? x y) ; can't use the stock equal? because it's a generic...
833 (cond ((pair? x) (and (pair? y)
834 (eq? (car x) (car y))
835 (equal? (cdr x) (cdr y))))
836 ((null? x) (null? y))
838 (if (slot-ref gf 'n-specialized)
839 (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
840 (let lp ((cache (slot-ref gf 'effective-methods)))
842 (cache-miss gf args))
843 ((equal? (vector-ref (car cache) 1) types)
844 (apply (vector-ref (car cache) 3) args))
845 (else (lp (cdr cache))))))
846 (cache-miss gf args)))
848 (define (cache-miss gf args)
849 (apply (memoize-method! gf args) args))
851 (define (memoize-effective-method! gf args applicable)
852 (define (first-n ls n)
853 (if (or (zero? n) (null? ls))
855 (cons (car ls) (first-n (cdr ls) (- n 1)))))
858 (memoize n #f (map class-of args)))
859 ((= n (slot-ref gf 'n-specialized))
860 (memoize n #t (map class-of (first-n args n))))
862 (parse (1+ n) (cdr ls)))))
863 (define (memoize len rest? types)
864 (let* ((cmethod (compute-cmethod applicable types))
865 (cache (cons (vector len types rest? cmethod)
866 (slot-ref gf 'effective-methods))))
867 (slot-set! gf 'effective-methods cache)
868 (slot-set! gf 'procedure (delayed-compile gf))
873 ;;; Compiling next methods into method bodies
876 ;;; So, for the reader: there basic idea is that, given that the
877 ;;; semantics of `next-method' depend on the concrete types being
878 ;;; dispatched, why not compile a specific procedure to handle each type
879 ;;; combination that we see at runtime.
881 ;;; In theory we can do much better than a bytecode compilation, because
882 ;;; we know the *exact* types of the arguments. It's ideal for native
883 ;;; compilation. A task for the future.
885 ;;; I think this whole generic application mess would benefit from a
888 (define (compute-cmethod methods types)
889 (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
892 (if (null? (cdr methods))
894 (no-next-method (method-generic-function (car methods)) args))
895 (compute-cmethod (cdr methods) types)))
896 (method-procedure (car methods)))))
902 (define (memoize-method! gf args)
903 (let ((applicable ((if (eq? gf compute-applicable-methods)
904 %compute-applicable-methods
905 compute-applicable-methods)
908 (memoize-effective-method! gf args applicable))
910 (no-applicable-method gf args)))))
912 (set-procedure-property! memoize-method! 'system-procedure #t)
914 (define no-applicable-method
915 (make <generic> #:name 'no-applicable-method))
919 ;; Then load the rest of GOOPS
923 (define min-fixnum (- (expt 2 29)))
924 (define max-fixnum (- (expt 2 29) 1))
929 (define (goops-error format-string . args)
930 (scm-error 'goops-error #f format-string args '()))
935 (define (is-a? obj class)
936 (and (memq class (class-precedence-list (class-of obj))) #t))
943 (define ensure-metaclass-with-supers
944 (let ((table-of-metas '()))
945 (lambda (meta-supers)
946 (let ((entry (assoc meta-supers table-of-metas)))
948 ;; Found a previously created metaclass
950 ;; Create a new meta-class which inherit from "meta-supers"
951 (let ((new (make <class> #:dsupers meta-supers
953 #:name (gensym "metaclass"))))
954 (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
957 (define (ensure-metaclass supers)
960 (let* ((all-metas (map (lambda (x) (class-of x)) supers))
961 (all-cpls (append-map (lambda (m)
962 (cdr (class-precedence-list m)))
965 ;; Find the most specific metaclasses. The new metaclass will be
966 ;; a subclass of these.
969 (if (and (not (member meta all-cpls))
970 (not (member meta needed-metas)))
971 (set! needed-metas (append needed-metas (list meta)))))
973 ;; Now return a subclass of the metaclasses we found.
974 (if (null? (cdr needed-metas))
975 (car needed-metas) ; If there's only one, just use it.
976 (ensure-metaclass-with-supers needed-metas)))))
982 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
984 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
985 ;;; OPTION ::= KEYWORD VALUE
988 (define (make-class supers slots . options)
989 (let* ((name (get-keyword #:name options (make-unbound)))
990 (supers (if (not (or-map (lambda (class)
992 (class-precedence-list class)))
994 (append supers (list <object>))
996 (metaclass (or (get-keyword #:metaclass options #f)
997 (ensure-metaclass supers))))
999 ;; Verify that all direct slots are different and that we don't inherit
1000 ;; several time from the same class
1001 (let ((tmp1 (find-duplicate supers))
1002 (tmp2 (find-duplicate (map slot-definition-name slots))))
1004 (goops-error "make-class: super class ~S is duplicate in class ~S"
1007 (goops-error "make-class: slot ~S is duplicate in class ~S"
1010 ;; Everything seems correct, build the class
1011 (apply make metaclass
1017 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
1019 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
1020 ;;; OPTION ::= KEYWORD VALUE
1022 (define-syntax class
1024 (define (parse-options options)
1025 (syntax-case options ()
1027 ((kw arg . options) (keyword? (syntax->datum #'kw))
1028 (with-syntax ((options (parse-options #'options)))
1029 (syntax-case #'kw ()
1031 #'(kw 'arg #:init-thunk (lambda () arg) . options))
1033 #'(kw arg . options)))))))
1034 (define (check-valid-kwargs args)
1035 (syntax-case args ()
1037 ((kw arg . args) (keyword? (syntax->datum #'kw))
1038 #`(kw arg . #,(check-valid-kwargs #'args)))))
1039 (define (parse-slots-and-kwargs args)
1040 (syntax-case args ()
1043 ((kw . _) (keyword? (syntax->datum #'kw))
1044 #`(() #,(check-valid-kwargs args)))
1045 (((name option ...) args ...)
1046 (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
1047 ((option ...) (parse-options #'(option ...))))
1048 #'(((list 'name option ...) . slots) kwargs)))
1049 ((name args ...) (symbol? (syntax->datum #'name))
1050 (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
1051 #'(('(name) . slots) kwargs)))))
1053 ((class (super ...) arg ...)
1054 (with-syntax ((((slot-def ...) (option ...))
1055 (parse-slots-and-kwargs #'(arg ...))))
1056 #'(make-class (list super ...)
1060 (define-syntax define-class-pre-definition
1063 ((_ (k arg rest ...) out ...)
1064 (keyword? (syntax->datum #'k))
1065 (case (syntax->datum #'k)
1066 ((#:getter #:setter)
1067 #'(define-class-pre-definition (rest ...)
1069 (if (or (not (defined? 'arg))
1070 (not (is-a? arg <generic>)))
1073 (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
1075 #'(define-class-pre-definition (rest ...)
1077 (if (or (not (defined? 'arg))
1078 (not (is-a? arg <accessor>)))
1081 (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
1083 #'(define-class-pre-definition (rest ...) out ...))))
1085 #'(begin out ...)))))
1087 ;; Some slot options require extra definitions to be made. In
1088 ;; particular, we want to make sure that the generic function objects
1089 ;; which represent accessors exist before `make-class' tries to add
1091 (define-syntax define-class-pre-definitions
1096 ((_ (slot rest ...) out ...)
1097 (keyword? (syntax->datum #'slot))
1099 ((_ (slot rest ...) out ...)
1100 (identifier? #'slot)
1101 #'(define-class-pre-definitions (rest ...)
1103 ((_ ((slotname slotopt ...) rest ...) out ...)
1104 #'(define-class-pre-definitions (rest ...)
1105 out ... (define-class-pre-definition (slotopt ...)))))))
1107 (define-syntax-rule (define-class name supers slot ...)
1109 (define-class-pre-definitions (slot ...))
1110 (if (and (defined? 'name)
1111 (is-a? name <class>)
1112 (memq <object> (class-precedence-list name)))
1113 (class-redefinition name
1114 (class supers slot ... #:name 'name))
1115 (toplevel-define! 'name (class supers slot ... #:name 'name)))))
1117 (define-syntax-rule (standard-define-class arg ...)
1118 (define-class arg ...))
1121 ;;; {Generic functions and accessors}
1124 ;; Apparently the desired semantics are that we extend previous
1125 ;; procedural definitions, but that if `name' was already a generic, we
1126 ;; overwrite its definition.
1127 (define-syntax define-generic
1130 ((define-generic name) (symbol? (syntax->datum #'name))
1132 (if (and (defined? 'name) (is-a? name <generic>))
1133 (make <generic> #:name 'name)
1134 (ensure-generic (if (defined? 'name) name #f) 'name)))))))
1136 (define-syntax define-extended-generic
1139 ((define-extended-generic name val) (symbol? (syntax->datum #'name))
1140 #'(define name (make-extended-generic val 'name))))))
1142 (define-syntax define-extended-generics
1144 (define (id-append ctx a b)
1145 (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
1147 ((define-extended-generic (name ...) #:prefix (prefix ...))
1148 (and (and-map symbol? (syntax->datum #'(name ...)))
1149 (and-map symbol? (syntax->datum #'(prefix ...))))
1150 (with-syntax ((((val ...)) (map (lambda (name)
1151 (map (lambda (prefix)
1152 (id-append name prefix name))
1156 (define-extended-generic name (list val ...))
1159 (define* (make-generic #:optional name)
1160 (make <generic> #:name name))
1162 (define* (make-extended-generic gfs #:optional name)
1163 (let* ((gfs (if (list? gfs) gfs (list gfs)))
1164 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
1166 (let* ((sname (and name (make-setter-name name)))
1168 (append-map (lambda (gf)
1169 (if (is-a? gf <generic-with-setter>)
1170 (list (ensure-generic (setter gf)
1174 (es (make <extended-generic-with-setter>
1177 #:setter (make <extended-generic>
1179 #:extends setters))))
1180 (extended-by! setters (setter es))
1182 (make <extended-generic>
1185 (extended-by! gfs ans)
1188 (define (extended-by! gfs eg)
1189 (for-each (lambda (gf)
1190 (slot-set! gf 'extended-by
1191 (cons eg (slot-ref gf 'extended-by))))
1193 (invalidate-method-cache! eg))
1195 (define (not-extended-by! gfs eg)
1196 (for-each (lambda (gf)
1197 (slot-set! gf 'extended-by
1198 (delq! eg (slot-ref gf 'extended-by))))
1200 (invalidate-method-cache! eg))
1202 (define* (ensure-generic old-definition #:optional name)
1203 (cond ((is-a? old-definition <generic>) old-definition)
1204 ((procedure-with-setter? old-definition)
1205 (make <generic-with-setter>
1207 #:default (procedure old-definition)
1208 #:setter (setter old-definition)))
1209 ((procedure? old-definition)
1210 (if (generic-capability? old-definition) old-definition
1211 (make <generic> #:name name #:default old-definition)))
1212 (else (make <generic> #:name name))))
1214 ;; same semantics as <generic>
1215 (define-syntax-rule (define-accessor name)
1217 (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
1218 ((is-a? name <accessor>) (make <accessor> #:name 'name))
1219 (else (ensure-accessor name 'name)))))
1221 (define (make-setter-name name)
1222 (string->symbol (string-append "setter:" (symbol->string name))))
1224 (define* (make-accessor #:optional name)
1227 #:setter (make <generic>
1228 #:name (and name (make-setter-name name)))))
1230 (define* (ensure-accessor proc #:optional name)
1231 (cond ((and (is-a? proc <accessor>)
1232 (is-a? (setter proc) <generic>))
1234 ((is-a? proc <generic-with-setter>)
1235 (upgrade-accessor proc (setter proc)))
1236 ((is-a? proc <generic>)
1237 (upgrade-accessor proc (make-generic name)))
1238 ((procedure-with-setter? proc)
1241 #:default (procedure proc)
1242 #:setter (ensure-generic (setter proc) name)))
1244 (ensure-accessor (if (generic-capability? proc)
1245 (make <generic> #:name name #:default proc)
1246 (ensure-generic proc name))
1249 (make-accessor name))))
1251 (define (upgrade-accessor generic setter)
1252 (let ((methods (slot-ref generic 'methods))
1253 (gws (make (if (is-a? generic <extended-generic>)
1254 <extended-generic-with-setter>
1256 #:name (generic-function-name generic)
1257 #:extended-by (slot-ref generic 'extended-by)
1259 (if (is-a? generic <extended-generic>)
1260 (let ((gfs (slot-ref generic 'extends)))
1261 (not-extended-by! gfs generic)
1262 (slot-set! gws 'extends gfs)
1263 (extended-by! gfs gws)))
1264 ;; Steal old methods
1265 (for-each (lambda (method)
1266 (slot-set! method 'generic-function gws))
1268 (slot-set! gws 'methods methods)
1269 (invalidate-method-cache! gws)
1276 ;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
1277 ;; element longer than the other when we have a dotted parameter
1278 ;; list). For instance, with the call
1284 ;; (define-method M (a . l) ....)
1285 ;; (define-method M (a) ....)
1287 ;; we consider that the second method is more specific.
1289 ;; Precondition: `a' and `b' are methods and are applicable to `types'.
1290 (define (%method-more-specific? a b types)
1291 (let lp ((a-specializers (method-specializers a))
1292 (b-specializers (method-specializers b))
1295 ;; (a) less specific than (a b ...) or (a . b)
1296 ((null? a-specializers) #t)
1297 ;; (a b ...) or (a . b) less specific than (a)
1298 ((null? b-specializers) #f)
1299 ;; (a . b) less specific than (a b ...)
1300 ((not (pair? a-specializers)) #f)
1301 ;; (a b ...) more specific than (a . b)
1302 ((not (pair? b-specializers)) #t)
1304 (let ((a-specializer (car a-specializers))
1305 (b-specializer (car b-specializers))
1306 (a-specializers (cdr a-specializers))
1307 (b-specializers (cdr b-specializers))
1309 (types (cdr types)))
1310 (if (eq? a-specializer b-specializer)
1311 (lp a-specializers b-specializers types)
1312 (let lp ((cpl (class-precedence-list type)))
1313 (let ((elt (car cpl)))
1315 ((eq? a-specializer elt) #t)
1316 ((eq? b-specializer elt) #f)
1317 (else (lp (cdr cpl))))))))))))
1319 (define (%sort-applicable-methods methods types)
1320 (sort methods (lambda (a b) (%method-more-specific? a b types))))
1322 (define (%compute-applicable-methods gf args)
1323 (define (method-applicable? m types)
1324 (let lp ((specs (method-specializers m)) (types types))
1326 ((null? specs) (null? types))
1327 ((not (pair? specs)) #t)
1330 (and (memq (car specs) (class-precedence-list (car types)))
1331 (lp (cdr specs) (cdr types)))))))
1332 (let ((n (length args))
1333 (types (map class-of args)))
1334 (let lp ((methods (generic-function-methods gf))
1337 (and (not (null? applicable))
1338 (%sort-applicable-methods applicable types))
1339 (let ((m (car methods)))
1341 (if (method-applicable? m types)
1345 (define compute-applicable-methods %compute-applicable-methods)
1347 (define (toplevel-define! name val)
1348 (module-define! (current-module) name val))
1350 (define-syntax define-method
1351 (syntax-rules (setter)
1352 ((_ ((setter name) . args) body ...)
1354 (if (or (not (defined? 'name))
1355 (not (is-a? name <accessor>)))
1356 (toplevel-define! 'name
1358 (if (defined? 'name) name #f) 'name)))
1359 (add-method! (setter name) (method args body ...))))
1360 ((_ (name . args) body ...)
1362 ;; FIXME: this code is how it always was, but it's quite cracky:
1363 ;; it will only define the generic function if it was undefined
1364 ;; before (ok), or *was defined to #f*. The latter is crack. But
1365 ;; there are bootstrap issues about fixing this -- change it to
1366 ;; (is-a? name <generic>) and see.
1367 (if (or (not (defined? 'name))
1369 (toplevel-define! 'name (make <generic> #:name 'name)))
1370 (add-method! name (method args body ...))))))
1372 (define-syntax method
1374 (define (parse-args args)
1375 (let lp ((ls args) (formals '()) (specializers '()))
1378 (and (identifier? #'f) (identifier? #'s))
1381 (cons #'s specializers)))
1386 (cons #'<top> specializers)))
1388 (list (reverse formals)
1389 (reverse (cons #''() specializers))))
1391 (identifier? #'tail)
1392 (list (append (reverse formals) #'tail)
1393 (reverse (cons #'<top> specializers)))))))
1395 (define (find-free-id exp referent)
1398 (or (find-free-id #'x referent)
1399 (find-free-id #'y referent)))
1402 (let ((id (datum->syntax #'x referent)))
1403 (and (free-identifier=? #'x id) id)))
1406 (define (compute-procedure formals body)
1407 (syntax-case body ()
1409 (with-syntax ((formals formals))
1410 #'(lambda formals body0 ...)))))
1412 (define (->proper args)
1413 (let lp ((ls args) (out '()))
1415 ((x . xs) (lp #'xs (cons #'x out)))
1417 (tail (reverse (cons #'tail out))))))
1419 (define (compute-make-procedure formals body next-method)
1420 (syntax-case body ()
1422 (with-syntax ((next-method next-method))
1423 (syntax-case formals ()
1425 #'(lambda (real-next-method)
1426 (lambda (formal ...)
1427 (let ((next-method (lambda args
1429 (real-next-method formal ...)
1430 (apply real-next-method args)))))
1433 (with-syntax (((formal ...) (->proper #'formals)))
1434 #'(lambda (real-next-method)
1436 (let ((next-method (lambda args
1438 (apply real-next-method formal ...)
1439 (apply real-next-method args)))))
1442 (define (compute-procedures formals body)
1443 ;; So, our use of this is broken, because it operates on the
1444 ;; pre-expansion source code. It's equivalent to just searching
1445 ;; for referent in the datums. Ah well.
1446 (let ((id (find-free-id body 'next-method)))
1448 ;; return a make-procedure
1450 (compute-make-procedure formals body id))
1451 (values (compute-procedure formals body)
1455 ((_ args) #'(method args (if #f #f)))
1456 ((_ args body0 body1 ...)
1457 (with-syntax (((formals (specializer ...)) (parse-args #'args)))
1460 (compute-procedures #'formals #'(body0 body1 ...)))
1461 (lambda (procedure make-procedure)
1462 (with-syntax ((procedure procedure)
1463 (make-procedure make-procedure))
1465 #:specializers (cons* specializer ...)
1467 #:body '(body0 body1 ...)
1468 #:make-procedure make-procedure
1469 #:procedure procedure)))))))))
1475 (define (add-method-in-classes! m)
1476 ;; Add method in all the classes which appears in its specializers list
1477 (for-each* (lambda (x)
1478 (let ((dm (class-direct-methods x)))
1480 (struct-set! x class-index-direct-methods (cons m dm)))))
1481 (method-specializers m)))
1483 (define (remove-method-in-classes! m)
1484 ;; Remove method in all the classes which appears in its specializers list
1485 (for-each* (lambda (x)
1487 class-index-direct-methods
1488 (delv! m (class-direct-methods x))))
1489 (method-specializers m)))
1491 (define (compute-new-list-of-methods gf new)
1492 (let ((new-spec (method-specializers new))
1493 (methods (slot-ref gf 'methods)))
1494 (let loop ((l methods))
1497 (if (equal? (method-specializers (car l)) new-spec)
1499 ;; This spec. list already exists. Remove old method from dependents
1500 (remove-method-in-classes! (car l))
1505 (define (method-n-specializers m)
1506 (length* (slot-ref m 'specializers)))
1508 (define (calculate-n-specialized gf)
1509 (fold (lambda (m n) (max n (method-n-specializers m)))
1511 (generic-function-methods gf)))
1513 (define (invalidate-method-cache! gf)
1514 (%invalidate-method-cache! gf)
1515 (slot-set! gf 'n-specialized (calculate-n-specialized gf))
1516 (for-each (lambda (gf) (invalidate-method-cache! gf))
1517 (slot-ref gf 'extended-by)))
1519 (define internal-add-method!
1520 (method ((gf <generic>) (m <method>))
1521 (slot-set! m 'generic-function gf)
1522 (slot-set! gf 'methods (compute-new-list-of-methods gf m))
1523 (invalidate-method-cache! gf)
1524 (add-method-in-classes! m)
1527 (define-generic add-method!)
1529 ((method-procedure internal-add-method!) add-method! internal-add-method!)
1531 (define-method (add-method! (proc <procedure>) (m <method>))
1532 (if (generic-capability? proc)
1534 (enable-primitive-generic! proc)
1535 (add-method! proc m))
1538 (define-method (add-method! (pg <primitive-generic>) (m <method>))
1539 (add-method! (primitive-generic-generic pg) m))
1541 (define-method (add-method! obj (m <method>))
1542 (goops-error "~S is not a valid generic function" obj))
1545 ;;; {Access to meta objects}
1551 (define-method (method-source (m <method>))
1552 (let* ((spec (map* class-name (slot-ref m 'specializers)))
1553 (src (procedure-source (slot-ref m 'procedure))))
1555 (let ((args (cadr src))
1558 (cons (map* list args spec)
1561 (define-method (method-formals (m <method>))
1562 (slot-ref m 'formals))
1567 (define slot-definition-name car)
1569 (define slot-definition-options cdr)
1571 (define (slot-definition-allocation s)
1572 (get-keyword #:allocation (cdr s) #:instance))
1574 (define (slot-definition-getter s)
1575 (get-keyword #:getter (cdr s) #f))
1577 (define (slot-definition-setter s)
1578 (get-keyword #:setter (cdr s) #f))
1580 (define (slot-definition-accessor s)
1581 (get-keyword #:accessor (cdr s) #f))
1583 (define (slot-definition-init-value s)
1584 ;; can be #f, so we can't use #f as non-value
1585 (get-keyword #:init-value (cdr s) (make-unbound)))
1587 (define (slot-definition-init-form s)
1588 (get-keyword #:init-form (cdr s) (make-unbound)))
1590 (define (slot-definition-init-thunk s)
1591 (get-keyword #:init-thunk (cdr s) #f))
1593 (define (slot-definition-init-keyword s)
1594 (get-keyword #:init-keyword (cdr s) #f))
1596 (define (class-slot-definition class slot-name)
1597 (assq slot-name (class-slots class)))
1599 (define (slot-init-function class slot-name)
1600 (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))
1602 (define (accessor-method-slot-definition obj)
1603 "Return the slot definition of the accessor @var{obj}."
1604 (slot-ref obj 'slot-definition))
1608 ;;; {Standard methods used by the C runtime}
1611 ;;; Methods to compare objects
1614 ;; Have to do this in a strange order because equal? is used in the
1615 ;; add-method! implementation; we need to make sure that when the
1616 ;; primitive is extended, that the generic has a method. =
1617 (define g-equal? (make-generic 'equal?))
1618 ;; When this generic gets called, we will have already checked eq? and
1619 ;; eqv? -- the purpose of this generic is to extend equality. So by
1620 ;; default, there is no extension, thus the #f return.
1621 (add-method! g-equal? (method (x y) #f))
1622 (set-primitive-generic! equal? g-equal?)
1625 ;;; methods to display/write an object
1628 ; Code for writing objects must test that the slots they use are
1629 ; bound. Otherwise a slot-unbound method will be called and will
1630 ; conduct to an infinite loop.
1633 (define (display-address o file)
1634 (display (number->string (object-address o) 16) file))
1636 (define-method (write o file)
1637 (display "#<instance " file)
1638 (display-address o file)
1641 (define write-object (primitive-generic-generic write))
1643 (define-method (write (o <object>) file)
1644 (let ((class (class-of o)))
1645 (if (slot-bound? class 'name)
1648 (display (class-name class) file)
1649 (display #\space file)
1650 (display-address o file)
1654 (define-method (write (class <class>) file)
1655 (let ((meta (class-of class)))
1656 (if (and (slot-bound? class 'name)
1657 (slot-bound? meta 'name))
1660 (display (class-name meta) file)
1661 (display #\space file)
1662 (display (class-name class) file)
1663 (display #\space file)
1664 (display-address class file)
1668 (define-method (write (gf <generic>) file)
1669 (let ((meta (class-of gf)))
1670 (if (and (slot-bound? meta 'name)
1671 (slot-bound? gf 'methods))
1674 (display (class-name meta) file)
1675 (let ((name (generic-function-name gf)))
1678 (display #\space file)
1679 (display name file))))
1681 (display (length (generic-function-methods gf)) file)
1682 (display ")>" file))
1685 (define-method (write (o <method>) file)
1686 (let ((meta (class-of o)))
1687 (if (and (slot-bound? meta 'name)
1688 (slot-bound? o 'specializers))
1691 (display (class-name meta) file)
1692 (display #\space file)
1693 (display (map* (lambda (spec)
1694 (if (slot-bound? spec 'name)
1695 (slot-ref spec 'name)
1697 (method-specializers o))
1699 (display #\space file)
1700 (display-address o file)
1704 ;; Display (do the same thing as write by default)
1705 (define-method (display o file)
1706 (write-object o file))
1709 ;;; Handling of duplicate bindings in the module system
1712 (define (find-subclass super name)
1713 (let lp ((classes (class-direct-subclasses super)))
1716 (error "class not found" name))
1717 ((and (slot-bound? (car classes) 'name)
1718 (eq? (class-name (car classes)) name))
1721 (lp (cdr classes))))))
1724 (define <module> (find-subclass <top> '<module>))
1726 (define-method (merge-generics (module <module>)
1736 (define-method (merge-generics (module <module>)
1744 (and (not (eq? val1 val2))
1745 (make-variable (make-extended-generic (list val2 val1) name))))
1747 (define-method (merge-generics (module <module>)
1754 (gf <extended-generic>))
1755 (and (not (memq val2 (slot-ref gf 'extends)))
1759 (cons val2 (delq! val2 (slot-ref gf 'extends))))
1762 (cons gf (delq! gf (slot-ref val2 'extended-by))))
1763 (invalidate-method-cache! gf)
1766 (module-define! duplicate-handlers 'merge-generics merge-generics)
1768 (define-method (merge-accessors (module <module>)
1778 (define-method (merge-accessors (module <module>)
1786 (merge-generics module name int1 val1 int2 val2 var val))
1788 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
1794 (define (class-slot-g-n-s class slot-name)
1795 (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
1796 (getters-n-setters (struct-ref class class-index-getters-n-setters))
1797 (g-n-s (cddr (or (assq slot-name getters-n-setters)
1798 (slot-missing class slot-name)))))
1799 (if (not (memq (slot-definition-allocation this-slot)
1800 '(#:class #:each-subclass)))
1801 (slot-missing class slot-name))
1804 (define (class-slot-ref class slot)
1805 (let ((x ((car (class-slot-g-n-s class slot)) #f)))
1807 (slot-unbound class slot)
1810 (define (class-slot-set! class slot value)
1811 ((cadr (class-slot-g-n-s class slot)) #f value))
1813 (define-method (slot-unbound (c <class>) (o <object>) s)
1814 (goops-error "Slot `~S' is unbound in object ~S" s o))
1816 (define-method (slot-unbound (c <class>) s)
1817 (goops-error "Slot `~S' is unbound in class ~S" s c))
1819 (define-method (slot-unbound (o <object>))
1820 (goops-error "Unbound slot in object ~S" o))
1822 (define-method (slot-missing (c <class>) (o <object>) s)
1823 (goops-error "No slot with name `~S' in object ~S" s o))
1825 (define-method (slot-missing (c <class>) s)
1826 (goops-error "No class slot with name `~S' in class ~S" s c))
1829 (define-method (slot-missing (c <class>) (o <object>) s value)
1830 (slot-missing c o s))
1832 ;;; Methods for the possible error we can encounter when calling a gf
1834 (define-method (no-next-method (gf <generic>) args)
1835 (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
1837 (define-method (no-applicable-method (gf <generic>) args)
1838 (goops-error "No applicable method for ~S in call ~S"
1839 gf (cons (generic-function-name gf) args)))
1841 (define-method (no-method (gf <generic>) args)
1842 (goops-error "No method defined for ~S" gf))
1845 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
1848 (define-method (shallow-clone (self <object>))
1849 (let ((clone (%allocate-instance (class-of self) '()))
1850 (slots (map slot-definition-name
1851 (class-slots (class-of self)))))
1852 (for-each (lambda (slot)
1853 (if (slot-bound? self slot)
1854 (slot-set! clone slot (slot-ref self slot))))
1858 (define-method (deep-clone (self <object>))
1859 (let ((clone (%allocate-instance (class-of self) '()))
1860 (slots (map slot-definition-name
1861 (class-slots (class-of self)))))
1862 (for-each (lambda (slot)
1863 (if (slot-bound? self slot)
1864 (slot-set! clone slot
1865 (let ((value (slot-ref self slot)))
1866 (if (instance? value)
1873 ;;; {Class redefinition utilities}
1876 ;;; (class-redefinition OLD NEW)
1879 ;;; Has correct the following conditions:
1883 ;;; 1. New accessor specializers refer to new header
1887 ;;; 1. New class cpl refers to the new class header
1888 ;;; 2. Old class header exists on old super classes direct-subclass lists
1889 ;;; 3. New class header exists on new super classes direct-subclass lists
1891 (define-method (class-redefinition (old <class>) (new <class>))
1892 ;; Work on direct methods:
1893 ;; 1. Remove accessor methods from the old class
1894 ;; 2. Patch the occurences of new in the specializers by old
1895 ;; 3. Displace the methods from old to new
1896 (remove-class-accessors! old) ;; -1-
1897 (let ((methods (class-direct-methods new)))
1898 (for-each (lambda (m)
1899 (update-direct-method! m new old)) ;; -2-
1902 class-index-direct-methods
1903 (append methods (class-direct-methods old))))
1905 ;; Substitute old for new in new cpl
1906 (set-car! (struct-ref new class-index-cpl) old)
1908 ;; Remove the old class from the direct-subclasses list of its super classes
1909 (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
1910 (delv! old (class-direct-subclasses c))))
1911 (class-direct-supers old))
1913 ;; Replace the new class with the old in the direct-subclasses of the supers
1914 (for-each (lambda (c)
1915 (struct-set! c class-index-direct-subclasses
1916 (cons old (delv! new (class-direct-subclasses c)))))
1917 (class-direct-supers new))
1919 ;; Swap object headers
1920 (%modify-class old new)
1924 ;; Redefine all the subclasses of old to take into account modification
1927 (update-direct-subclass! c new old))
1928 (class-direct-subclasses new))
1930 ;; Invalidate class so that subsequent instances slot accesses invoke
1931 ;; change-object-class
1932 (struct-set! new class-index-redefined old)
1933 (%invalidate-class new) ;must come after slot-set!
1938 ;;; remove-class-accessors!
1941 (define-method (remove-class-accessors! (c <class>))
1942 (for-each (lambda (m)
1943 (if (is-a? m <accessor-method>)
1944 (let ((gf (slot-ref m 'generic-function)))
1945 ;; remove the method from its GF
1946 (slot-set! gf 'methods
1947 (delq1! m (slot-ref gf 'methods)))
1948 (invalidate-method-cache! gf)
1949 ;; remove the method from its specializers
1950 (remove-method-in-classes! m))))
1951 (class-direct-methods c)))
1954 ;;; update-direct-method!
1957 (define-method (update-direct-method! (m <method>)
1960 (let loop ((l (method-specializers m)))
1961 ;; Note: the <top> in dotted list is never used.
1962 ;; So we can work as if we had only proper lists.
1965 (if (eqv? (car l) old)
1970 ;;; update-direct-subclass!
1973 (define-method (update-direct-subclass! (c <class>)
1976 (class-redefinition c
1977 (make-class (class-direct-supers c)
1978 (class-direct-slots c)
1979 #:name (class-name c)
1980 #:metaclass (class-of c))))
1983 ;;; {Utilities for INITIALIZE methods}
1986 ;;; compute-slot-accessors
1988 (define (compute-slot-accessors class slots)
1991 (let ((getter-function (slot-definition-getter s))
1992 (setter-function (slot-definition-setter s))
1993 (accessor (slot-definition-accessor s)))
1995 (add-method! getter-function
1996 (compute-getter-method class g-n-s)))
1998 (add-method! setter-function
1999 (compute-setter-method class g-n-s)))
2002 (add-method! accessor
2003 (compute-getter-method class g-n-s))
2004 (add-method! (setter accessor)
2005 (compute-setter-method class g-n-s))))))
2006 slots (struct-ref class class-index-getters-n-setters)))
2008 (define-method (compute-getter-method (class <class>) slotdef)
2009 (let ((init-thunk (cadr slotdef))
2010 (g-n-s (cddr slotdef)))
2011 (make <accessor-method>
2012 #:specializers (list class)
2013 #:procedure (cond ((pair? g-n-s)
2014 (make-generic-bound-check-getter (car g-n-s)))
2016 (standard-get g-n-s))
2018 (bound-check-get g-n-s)))
2019 #:slot-definition slotdef)))
2021 (define-method (compute-setter-method (class <class>) slotdef)
2022 (let ((g-n-s (cddr slotdef)))
2023 (make <accessor-method>
2024 #:specializers (list class <top>)
2025 #:procedure (if (pair? g-n-s)
2027 (standard-set g-n-s))
2028 #:slot-definition slotdef)))
2030 (define (make-generic-bound-check-getter proc)
2032 (let ((val (proc o)))
2037 ;;; Pre-generate getters and setters for the first 20 slots.
2038 (define-syntax define-standard-accessor-method
2040 (define num-standard-pre-cache 20)
2042 ((_ ((proc n) arg ...) body)
2044 (let ((cache (vector #,@(map (lambda (n*)
2048 (iota num-standard-pre-cache)))))
2050 (if (< n #,num-standard-pre-cache)
2051 (vector-ref cache n)
2052 (lambda (arg ...) body)))))))))
2054 (define-standard-accessor-method ((bound-check-get n) o)
2055 (let ((x (struct-ref o n)))
2060 (define-standard-accessor-method ((standard-get n) o)
2063 (define-standard-accessor-method ((standard-set n) o v)
2064 (struct-set! o n v))
2066 ;;; compute-getters-n-setters
2068 (define (compute-getters-n-setters class slots)
2070 (define (compute-slot-init-function name s)
2071 (or (let ((thunk (slot-definition-init-thunk s)))
2075 (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
2076 name class thunk))))
2077 (let ((init (slot-definition-init-value s)))
2078 (and (not (unbound? init))
2079 (lambda () init)))))
2081 (define (verify-accessors slot l)
2082 (cond ((integer? l))
2083 ((not (and (list? l) (= (length l) 2)))
2084 (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
2089 (if (not (procedure? get))
2090 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
2092 (if (not (procedure? set))
2093 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
2094 slot class set))))))
2097 ;; The strange treatment of nfields is due to backward compatibility.
2098 (let* ((index (slot-ref class 'nfields))
2099 (g-n-s (compute-get-n-set class s))
2100 (size (- (slot-ref class 'nfields) index))
2101 (name (slot-definition-name s)))
2102 ;; NOTE: The following is interdependent with C macros
2103 ;; defined above goops.c:scm_sys_prep_layout_x.
2105 ;; For simple instance slots, we have the simplest form
2106 ;; '(name init-function . index)
2107 ;; For other slots we have
2108 ;; '(name init-function getter setter . alloc)
2110 ;; '(index size) for instance allocated slots
2111 ;; '() for other slots
2112 (verify-accessors name g-n-s)
2113 (case (slot-definition-allocation s)
2114 ((#:each-subclass #:class)
2115 (unless (and (zero? size) (pair? g-n-s))
2116 (error "Class-allocated slots should not reserve fields"))
2117 ;; Don't initialize the slot; that's handled when the slot
2118 ;; is allocated, in compute-get-n-set.
2119 (cons name (cons #f g-n-s)))
2122 (cons (compute-slot-init-function name s)
2123 (if (or (integer? g-n-s)
2126 (append g-n-s (list index size)))))))))
2132 ;; Replace the bootstrap compute-cpl with this definition.
2134 (make <generic> #:name 'compute-cpl))
2136 (define-method (compute-cpl (class <class>))
2137 (compute-std-cpl class class-direct-supers))
2139 ;;; compute-get-n-set
2141 (define-method (compute-get-n-set (class <class>) s)
2142 (define (class-slot-init-value)
2143 (let ((thunk (slot-definition-init-thunk s)))
2146 (slot-definition-init-value s))))
2148 (case (slot-definition-allocation s)
2149 ((#:instance) ;; Instance slot
2150 ;; get-n-set is just its offset
2151 (let ((already-allocated (struct-ref class class-index-nfields)))
2152 (struct-set! class class-index-nfields (+ already-allocated 1))
2155 ((#:class) ;; Class slot
2156 ;; Class-slots accessors are implemented as 2 closures around
2157 ;; a Scheme variable. As instance slots, class slots must be
2158 ;; unbound at init time.
2159 (let ((name (slot-definition-name s)))
2160 (if (memq name (map slot-definition-name (class-direct-slots class)))
2161 ;; This slot is direct; create a new shared variable
2162 (make-closure-variable class (class-slot-init-value))
2163 ;; Slot is inherited. Find its definition in superclass
2164 (let loop ((l (cdr (class-precedence-list class))))
2165 (let ((r (assoc name
2167 class-index-getters-n-setters))))
2170 (loop (cdr l))))))))
2172 ((#:each-subclass) ;; slot shared by instances of direct subclass.
2173 ;; (Thomas Buerger, April 1998)
2174 (make-closure-variable class (class-slot-init-value)))
2176 ((#:virtual) ;; No allocation
2177 ;; slot-ref and slot-set! function must be given by the user
2178 (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
2179 (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
2180 (if (not (and get set))
2181 (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
2184 (else (next-method))))
2186 (define (make-closure-variable class value)
2187 (list (lambda (o) value)
2188 (lambda (o v) (set! value v))))
2190 (define-method (compute-get-n-set (o <object>) s)
2191 (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
2193 (define-method (compute-slots (class <class>))
2194 (build-slots-list (class-direct-slots class)
2195 (class-precedence-list class)))
2201 (define-method (initialize (object <object>) initargs)
2202 (%initialize-object object initargs))
2204 (define-method (initialize (class <class>) initargs)
2206 (let ((dslots (get-keyword #:slots initargs '()))
2207 (supers (get-keyword #:dsupers initargs '())))
2208 (let ((name (get-keyword #:name initargs '???)))
2209 (struct-set! class class-index-name name))
2210 (struct-set! class class-index-direct-supers supers)
2211 (struct-set! class class-index-direct-slots dslots)
2212 (struct-set! class class-index-direct-subclasses '())
2213 (struct-set! class class-index-direct-methods '())
2214 (struct-set! class class-index-cpl (compute-cpl class))
2215 (struct-set! class class-index-redefined #f)
2216 (let ((slots (compute-slots class)))
2217 (struct-set! class class-index-slots slots)
2218 (struct-set! class class-index-nfields 0)
2219 (let ((getters-n-setters (compute-getters-n-setters class slots)))
2220 (struct-set! class class-index-getters-n-setters getters-n-setters))
2221 ;; Build getters - setters - accessors
2222 (compute-slot-accessors class slots))
2224 ;; Update the "direct-subclasses" of each inherited classes
2225 (for-each (lambda (x)
2226 (let ((dsubs (struct-ref x class-index-direct-subclasses)))
2227 (struct-set! x class-index-direct-subclasses
2228 (cons class dsubs))))
2231 ;; Support for the underlying structs:
2233 ;; Set the layout slot
2234 (%prep-layout! class)
2235 ;; Inherit class flags (invisible on scheme level) from supers
2236 (%inherit-magic! class supers)))
2238 (define (initialize-object-procedure object initargs)
2239 (let ((proc (get-keyword #:procedure initargs #f)))
2242 (apply slot-set! object 'procedure proc))
2244 (slot-set! object 'procedure proc)))))
2246 (define-method (initialize (applicable-struct <applicable-struct>) initargs)
2248 (initialize-object-procedure applicable-struct initargs))
2250 (define-method (initialize (applicable-struct <applicable-struct-with-setter>)
2253 (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f)))
2255 (define-method (initialize (generic <generic>) initargs)
2256 (let ((previous-definition (get-keyword #:default initargs #f))
2257 (name (get-keyword #:name initargs #f)))
2259 (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
2261 (apply previous-definition args)))
2264 (set-procedure-property! generic 'name name))
2265 (invalidate-method-cache! generic)))
2267 (define-method (initialize (eg <extended-generic>) initargs)
2269 (slot-set! eg 'extends (get-keyword #:extends initargs '())))
2271 (define dummy-procedure (lambda args *unspecified*))
2273 (define-method (initialize (method <method>) initargs)
2275 (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
2276 (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
2277 (slot-set! method 'procedure
2278 (get-keyword #:procedure initargs #f))
2279 (slot-set! method 'formals (get-keyword #:formals initargs '()))
2280 (slot-set! method 'body (get-keyword #:body initargs '()))
2281 (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
2288 (define (change-object-class old-instance old-class new-class)
2289 (let ((new-instance (allocate-instance new-class '())))
2290 ;; Initialize the slots of the new instance
2291 (for-each (lambda (slot)
2292 (if (and (slot-exists-using-class? old-class old-instance slot)
2293 (eq? (slot-definition-allocation
2294 (class-slot-definition old-class slot))
2296 (slot-bound-using-class? old-class old-instance slot))
2297 ;; Slot was present and allocated in old instance; copy it
2298 (slot-set-using-class!
2302 (slot-ref-using-class old-class old-instance slot))
2303 ;; slot was absent; initialize it with its default value
2304 (let ((init (slot-init-function new-class slot)))
2306 (slot-set-using-class!
2310 (apply init '()))))))
2311 (map slot-definition-name (class-slots new-class)))
2312 ;; Exchange old and new instance in place to keep pointers valid
2313 (%modify-instance old-instance new-instance)
2314 ;; Allow class specific updates of instances (which now are swapped)
2315 (update-instance-for-different-class new-instance old-instance)
2319 (define-method (update-instance-for-different-class (old-instance <object>)
2322 ;;not really important what we do, we just need a default method
2325 (define-method (change-class (old-instance <object>) (new-class <class>))
2326 (change-object-class old-instance (class-of old-instance) new-class))
2331 ;;; A new definition which overwrites the previous one which was built-in
2334 (define-method (allocate-instance (class <class>) initargs)
2335 (%allocate-instance class initargs))
2337 (define-method (make-instance (class <class>) . initargs)
2338 (let ((instance (allocate-instance class initargs)))
2339 (initialize instance initargs)
2342 (define make make-instance)
2347 ;;; Protocol for calling standard generic functions. This protocol is
2348 ;;; not used for real <generic> functions (in this case we use a
2349 ;;; completely C hard-coded protocol). Apply-generic is used by
2350 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
2351 ;;; The code below is similar to the first MOP described in AMOP. In
2352 ;;; particular, it doesn't used the currified approach to gf
2353 ;;; call. There are 2 reasons for that:
2354 ;;; - the protocol below is exposed to mimic completely the one written in C
2355 ;;; - the currified protocol would be imho inefficient in C.
2358 (define-method (apply-generic (gf <generic>) args)
2359 (if (null? (slot-ref gf 'methods))
2360 (no-method gf args))
2361 (let ((methods (compute-applicable-methods gf args)))
2363 (apply-methods gf (sort-applicable-methods gf methods args) args)
2364 (no-applicable-method gf args))))
2366 ;; compute-applicable-methods is bound to %compute-applicable-methods.
2368 (define %%compute-applicable-methods
2369 (make <generic> #:name 'compute-applicable-methods))
2371 (define-method (%%compute-applicable-methods (gf <generic>) args)
2372 (%compute-applicable-methods gf args))
2374 (set! compute-applicable-methods %%compute-applicable-methods)
2376 (define-method (sort-applicable-methods (gf <generic>) methods args)
2377 (%sort-applicable-methods methods (map class-of args)))
2379 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
2380 (%method-more-specific? m1 m2 targs))
2382 (define-method (apply-method (gf <generic>) methods build-next args)
2383 (apply (method-procedure (car methods))
2384 (build-next (cdr methods) args)
2387 (define-method (apply-methods (gf <generic>) (l <list>) args)
2388 (letrec ((next (lambda (procs args)
2390 (let ((a (if (null? new-args) args new-args)))
2392 (no-next-method gf a)
2393 (apply-method gf procs next a)))))))
2394 (apply-method gf l next args)))
2396 ;; We don't want the following procedure to turn up in backtraces:
2397 (for-each (lambda (proc)
2398 (set-procedure-property! proc 'system-procedure #t))
2402 no-applicable-method
2407 ;;; {<composite-metaclass> and <active-metaclass>}
2410 ;(autoload "active-slot" <active-metaclass>)
2411 ;(autoload "composite-slot" <composite-metaclass>)
2412 ;(export <composite-metaclass> <active-metaclass>)
2420 ;; duplicate the standard list->set function but using eq instead of
2421 ;; eqv which really sucks a lot, uselessly here
2423 (define (list2set l)
2428 ((memq (car l) res) (loop (cdr l) res))
2429 (else (loop (cdr l) (cons (car l) res))))))
2431 (define (class-subclasses c)
2432 (letrec ((allsubs (lambda (c)
2433 (cons c (mapappend allsubs
2434 (class-direct-subclasses c))))))
2435 (list2set (cdr (allsubs c)))))
2437 (define (class-methods c)
2438 (list2set (mapappend class-direct-methods
2439 (cons c (class-subclasses c)))))
2442 ;;; {Final initialization}
2445 ;; Tell C code that the main bulk of Goops has been loaded
2452 ;;; {SMOB and port classes}
2455 (define <arbiter> (find-subclass <top> '<arbiter>))
2456 (define <promise> (find-subclass <top> '<promise>))
2457 (define <thread> (find-subclass <top> '<thread>))
2458 (define <mutex> (find-subclass <top> '<mutex>))
2459 (define <condition-variable> (find-subclass <top> '<condition-variable>))
2460 (define <regexp> (find-subclass <top> '<regexp>))
2461 (define <hook> (find-subclass <top> '<hook>))
2462 (define <bitvector> (find-subclass <top> '<bitvector>))
2463 (define <random-state> (find-subclass <top> '<random-state>))
2464 (define <async> (find-subclass <top> '<async>))
2465 (define <directory> (find-subclass <top> '<directory>))
2466 (define <array> (find-subclass <top> '<array>))
2467 (define <character-set> (find-subclass <top> '<character-set>))
2468 (define <dynamic-object> (find-subclass <top> '<dynamic-object>))
2469 (define <guardian> (find-subclass <applicable> '<guardian>))
2470 (define <macro> (find-subclass <top> '<macro>))
2472 (define (define-class-subtree class)
2473 (define! (class-name class) class)
2474 (for-each define-class-subtree (class-direct-subclasses class)))
2476 (define-class-subtree (find-subclass <port> '<file-port>))