1 ;;;; goops.scm -- The Guile Object-Oriented Programming System
3 ;;;; Copyright (C) 1998-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 ((language tree-il primitives)
31 :select (add-interesting-primitive!))
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.
42 <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
43 <read-only-slot> <self-slot> <protected-opaque-slot>
44 <protected-hidden-slot> <protected-read-only-slot>
45 <scm-slot> <int-slot> <float-slot> <double-slot>
47 ;; Methods are implementations of generic functions.
48 <method> <accessor-method>
50 ;; Applicable objects, either procedures or applicable structs.
51 <procedure-class> <applicable>
52 <procedure> <primitive-generic>
54 ;; Applicable structs.
55 <applicable-struct-class> <applicable-struct-with-setter-class>
56 <applicable-struct> <applicable-struct-with-setter>
57 <generic> <extended-generic>
58 <generic-with-setter> <extended-generic-with-setter>
59 <accessor> <extended-accessor>
61 ;; Types with their own allocated typecodes.
62 <boolean> <char> <list> <pair> <null> <string> <symbol>
63 <vector> <bytevector> <uvec> <foreign> <hashtable>
64 <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
68 <number> <complex> <real> <integer> <fraction>
73 ;; Particular SMOB data types. All SMOB types have
74 ;; corresponding classes, which may be obtained via class-of,
75 ;; once you have an instance. Perhaps FIXME to provide a
76 ;; smob-type-name->class procedure.
77 <arbiter> <promise> <thread> <mutex> <condition-variable>
78 <regexp> <hook> <bitvector> <random-state> <async>
79 <directory> <array> <character-set>
80 <dynamic-object> <guardian> <macro>
86 <port> <input-port> <output-port> <input-output-port>
88 ;; Like SMOB types, all port types have their own classes,
89 ;; which can be accessed via `class-of' once you have an
90 ;; instance. Here we export bindings just for file ports.
92 <file-input-port> <file-output-port> <file-input-output-port>
95 ensure-metaclass ensure-metaclass-with-supers
97 make-generic ensure-generic
99 make-accessor ensure-accessor
101 class-slot-ref class-slot-set! slot-unbound slot-missing
102 slot-definition-name slot-definition-options
103 slot-definition-allocation
105 slot-definition-getter slot-definition-setter
106 slot-definition-accessor
107 slot-definition-init-value slot-definition-init-form
108 slot-definition-init-thunk slot-definition-init-keyword
109 slot-init-function class-slot-definition
111 compute-cpl compute-std-cpl compute-get-n-set compute-slots
112 compute-getter-method compute-setter-method
113 allocate-instance initialize make-instance make
114 no-next-method no-applicable-method no-method
115 change-class update-instance-for-different-class
116 shallow-clone deep-clone
118 apply-generic apply-method apply-methods
119 compute-applicable-methods %compute-applicable-methods
120 method-more-specific? sort-applicable-methods
121 class-subclasses class-methods
123 min-fixnum max-fixnum
126 slot-ref slot-set! slot-bound? slot-exists?
127 class-name class-direct-supers class-direct-subclasses
128 class-direct-methods class-direct-slots class-precedence-list
130 generic-function-name
131 generic-function-methods method-generic-function
132 method-specializers method-formals
133 primitive-generic-generic enable-primitive-generic!
134 method-procedure accessor-method-slot-definition
135 make find-method get-keyword))
139 ;;; Booting GOOPS is a tortuous process. We begin by loading a small
140 ;;; set of primitives from C.
142 (eval-when (expand load eval)
143 (load-extension (string-append "libguile-" (effective-version))
144 "scm_init_goops_builtins")
145 (add-interesting-primitive! 'class-of))
151 ;;; We then define the slots that must appear in all classes (<class>
152 ;;; objects) and slot definitions (<slot> objects). These slots must
153 ;;; appear in order. We'll use this list to statically compute offsets
154 ;;; for the various fields, to compute the struct layout for <class>
155 ;;; instances, and to compute the slot definition lists for <class>.
156 ;;; Because the list is needed at expansion-time, we define it as a
159 (define-syntax macro-fold-left
161 ((_ folder seed ()) seed)
162 ((_ folder seed (head . tail))
163 (macro-fold-left folder (folder head seed) tail))))
165 (define-syntax macro-fold-right
167 ((_ folder seed ()) seed)
168 ((_ folder seed (head . tail))
169 (folder head (macro-fold-right folder seed tail)))))
171 (define-syntax-rule (define-macro-folder macro-folder value ...)
172 (define-syntax macro-folder
176 ;; The datum->syntax makes it as if each `value' were present
177 ;; in the initial form, which allows them to be used as
178 ;; (components of) introduced identifiers.
179 #`(fold visit seed #,(datum->syntax #'visit '(value ...))))))))
181 (define-macro-folder fold-class-slots
182 (layout #:class <protected-read-only-slot>)
183 (flags #:class <hidden-slot>)
184 (self #:class <self-slot>)
185 (instance-finalizer #:class <hidden-slot>)
187 (name #:class <protected-hidden-slot>)
188 (nfields #:class <hidden-slot>)
189 (%reserved #:class <hidden-slot>)
198 (define-macro-folder fold-slot-slots
199 (name #:init-keyword #:name)
200 (allocation #:init-keyword #:allocation #:init-value #:instance)
201 (init-keyword #:init-keyword #:init-keyword #:init-value #f)
202 (init-form #:init-keyword #:init-form)
203 (init-value #:init-keyword #:init-value)
204 (init-thunk #:init-keyword #:init-thunk #:init-value #f)
206 (getter #:init-keyword #:getter #:init-value #f)
207 (setter #:init-keyword #:setter #:init-value #f)
208 (accessor #:init-keyword #:accessor #:init-value #f)
209 ;; These last don't have #:init-keyword because they are meant to be
210 ;; set by `allocate-slots', not in compute-effective-slot-definition.
211 (slot-ref/raw #:init-value #f)
212 (slot-ref #:init-value #f)
213 (slot-set! #:init-value #f)
214 (index #:init-value #f)
215 (size #:init-value #f))
218 ;;; Statically define variables for slot offsets: `class-index-layout'
219 ;;; will be 0, `class-index-flags' will be 1, and so on, and the same
220 ;;; for `slot-index-name' and such for <slot>.
222 (let-syntax ((define-slot-indexer
224 ((_ define-index prefix)
225 (define-syntax define-index
227 (define (id-append ctx a b)
228 (datum->syntax ctx (symbol-append (syntax->datum a)
230 (define (tail-length tail)
233 ((visit head tail) (1+ (tail-length #'tail)))))
237 (define-syntax #,(id-append #'name #'prefix #'name)
238 (identifier-syntax #,(tail-length #'tail)))
240 (define-slot-indexer define-class-index class-index-)
241 (define-slot-indexer define-slot-index slot-index-)
242 (fold-class-slots macro-fold-left define-class-index (begin))
243 (fold-slot-slots macro-fold-left define-slot-index (begin)))
246 ;;; Structs that are vtables have a "flags" slot, which corresponds to
247 ;;; class-index-flags. `vtable-flag-vtable' indicates that instances of
248 ;;; a vtable are themselves vtables, and `vtable-flag-validated'
249 ;;; indicates that the struct's layout has been validated. goops.c
250 ;;; defines a few additional flags: one to indicate that a vtable is
251 ;;; actually a class, one to indicate that the class is "valid" (meaning
252 ;;; that it hasn't been redefined), and one to indicate that instances
253 ;;; of a class are slot definition objects (<slot> instances).
255 (define vtable-flag-goops-metaclass
256 (logior vtable-flag-vtable vtable-flag-goops-class))
258 (define-inlinable (class-add-flags! class flags)
259 (struct-set! class class-index-flags
260 (logior flags (struct-ref class class-index-flags))))
262 (define-inlinable (class-clear-flags! class flags)
263 (struct-set! class class-index-flags
264 (logand (lognot flags) (struct-ref class class-index-flags))))
266 (define-inlinable (class-has-flags? class flags)
268 (logand (struct-ref class class-index-flags) flags)))
270 (define-inlinable (class? obj)
271 (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
273 (define-inlinable (slot? obj)
275 (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
277 (define-inlinable (instance? obj)
278 (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
281 ;;; Now that we know the slots that must be present in classes, and
282 ;;; their offsets, we can create the root of the class hierarchy.
284 ;;; Note that the `direct-supers', `direct-slots', `cpl', and `slots'
285 ;;; fields will be updated later, once we can create slot definition
286 ;;; objects and once we have definitions for <top> and <object>.
289 (let-syntax ((cons-layout
290 ;; A simple way to compute class layout for the concrete
291 ;; types used in <class>.
292 (syntax-rules (<protected-read-only-slot>
295 <protected-hidden-slot>)
297 (string-append "pw" tail))
298 ((_ (name #:class <protected-read-only-slot>) tail)
299 (string-append "pr" tail))
300 ((_ (name #:class <self-slot>) tail)
301 (string-append "sr" tail))
302 ((_ (name #:class <hidden-slot>) tail)
303 (string-append "uh" tail))
304 ((_ (name #:class <protected-hidden-slot>) tail)
305 (string-append "ph" tail)))))
306 (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
307 (nfields (/ (string-length layout) 2))
308 (<class> (%make-vtable-vtable layout)))
309 (class-add-flags! <class> (logior vtable-flag-goops-class
310 vtable-flag-goops-valid))
311 (struct-set! <class> class-index-name '<class>)
312 (struct-set! <class> class-index-nfields nfields)
313 (struct-set! <class> class-index-direct-supers '())
314 (struct-set! <class> class-index-direct-slots '())
315 (struct-set! <class> class-index-direct-subclasses '())
316 (struct-set! <class> class-index-direct-methods '())
317 (struct-set! <class> class-index-cpl '())
318 (struct-set! <class> class-index-slots '())
319 (struct-set! <class> class-index-redefined #f)
323 ;;; Accessors to fields of <class>.
325 (define-syntax-rule (define-class-accessor name docstring field)
330 (scm-error 'wrong-type-arg #f "Not a class: ~S"
332 (struct-ref val field))))
334 (define-class-accessor class-name
335 "Return the class name of @var{obj}."
337 (define-class-accessor class-direct-supers
338 "Return the direct superclasses of the class @var{obj}."
339 class-index-direct-supers)
340 (define-class-accessor class-direct-slots
341 "Return the direct slots of the class @var{obj}."
342 class-index-direct-slots)
343 (define-class-accessor class-direct-subclasses
344 "Return the direct subclasses of the class @var{obj}."
345 class-index-direct-subclasses)
346 (define-class-accessor class-direct-methods
347 "Return the direct methods of the class @var{obj}."
348 class-index-direct-methods)
349 (define-class-accessor class-precedence-list
350 "Return the class precedence list of the class @var{obj}."
352 (define-class-accessor class-slots
353 "Return the slot list of the class @var{obj}."
356 (define (class-subclasses c)
357 "Compute a list of all subclasses of @var{c}, direct and indirect."
358 (define (all-subclasses c)
359 (cons c (append-map all-subclasses
360 (class-direct-subclasses c))))
361 (delete-duplicates (cdr (all-subclasses c)) eq?))
363 (define (class-methods c)
364 "Compute a list of all methods that specialize on @var{c} or
365 subclasses of @var{c}."
366 (delete-duplicates (append-map class-direct-methods
367 (cons c (class-subclasses c)))
370 (define (is-a? obj class)
371 "Return @code{#t} if @var{obj} is an instance of @var{class}, or
372 @code{#f} otherwise."
373 (and (memq class (class-precedence-list (class-of obj))) #t))
379 ;;; At this point, <class> is missing slot definitions, but we can't
380 ;;; create slot definitions until we have a slot definition class.
381 ;;; Continue with manual object creation until we're able to bootstrap
382 ;;; more of the protocol. Again, the CPL and class hierarchy slots
383 ;;; remain uninitialized.
385 (define* (get-keyword key l #:optional default)
386 "Determine an associated value for the keyword @var{key} from the list
387 @var{l}. The list @var{l} has to consist of an even number of elements,
388 where, starting with the first, every second element is a keyword,
389 followed by its associated value. If @var{l} does not hold a value for
390 @var{key}, the value @var{default} is returned."
391 (unless (keyword? key)
392 (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
397 (unless (keyword? kw)
398 (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
399 (if (eq? kw key) arg (lp l))))))
401 (define *unbound* (list 'unbound))
403 (define-inlinable (unbound? x)
406 (define (%allocate-instance class)
407 (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
408 (%clear-fields! obj *unbound*)
412 (let-syntax ((cons-layout
413 ;; All slots are "pw" in <slot>.
415 ((_ _ tail) (string-append "pw" tail)))))
416 (let* ((layout (fold-slot-slots macro-fold-right cons-layout ""))
417 (nfields (/ (string-length layout) 2))
418 (<slot> (make-struct/no-tail <class> (make-struct-layout layout))))
419 (class-add-flags! <slot> (logior vtable-flag-goops-class
420 vtable-flag-goops-slot
421 vtable-flag-goops-valid))
422 (struct-set! <slot> class-index-name '<slot>)
423 (struct-set! <slot> class-index-nfields nfields)
424 (struct-set! <slot> class-index-direct-supers '())
425 (struct-set! <slot> class-index-direct-slots '())
426 (struct-set! <slot> class-index-direct-subclasses '())
427 (struct-set! <slot> class-index-direct-methods '())
428 (struct-set! <slot> class-index-cpl (list <slot>))
429 (struct-set! <slot> class-index-slots '())
430 (struct-set! <slot> class-index-redefined #f)
433 ;;; Access to slot objects is performance-sensitive for slot-ref, so in
434 ;;; addition to the type-checking accessors that we export, we also
435 ;;; define some internal inlined helpers that just do an unchecked
436 ;;; struct-ref in cases where we know the object must be a slot, as
437 ;;; when accessing class-slots.
439 (define-syntax-rule (define-slot-accessor name docstring %name field)
441 (define-syntax-rule (%name obj)
442 (struct-ref obj field))
446 (scm-error 'wrong-type-arg #f "Not a slot: ~S"
450 (define-slot-accessor slot-definition-name
451 "Return the name of @var{obj}."
452 %slot-definition-name slot-index-name)
453 (define-slot-accessor slot-definition-allocation
454 "Return the allocation of the slot @var{obj}."
455 %slot-definition-allocation slot-index-allocation)
456 (define-slot-accessor slot-definition-init-keyword
457 "Return the init keyword of the slot @var{obj}, or @code{#f}."
458 %slot-definition-init-keyword slot-index-init-keyword)
459 (define-slot-accessor slot-definition-init-form
460 "Return the init form of the slot @var{obj}, or the unbound value"
461 %slot-definition-init-form slot-index-init-form)
462 (define-slot-accessor slot-definition-init-value
463 "Return the init value of the slot @var{obj}, or the unbound value."
464 %slot-definition-init-value slot-index-init-value)
465 (define-slot-accessor slot-definition-init-thunk
466 "Return the init thunk of the slot @var{obj}, or @code{#f}."
467 %slot-definition-init-thunk slot-index-init-thunk)
468 (define-slot-accessor slot-definition-options
469 "Return the initargs given when creating the slot @var{obj}."
470 %slot-definition-options slot-index-options)
471 (define-slot-accessor slot-definition-getter
472 "Return the getter of the slot @var{obj}, or @code{#f}."
473 %slot-definition-getter slot-index-getter)
474 (define-slot-accessor slot-definition-setter
475 "Return the setter of the slot @var{obj}, or @code{#f}."
476 %slot-definition-setter slot-index-setter)
477 (define-slot-accessor slot-definition-accessor
478 "Return the accessor of the slot @var{obj}, or @code{#f}."
479 %slot-definition-accessor slot-index-accessor)
480 (define-slot-accessor slot-definition-slot-ref/raw
481 "Return the raw slot-ref procedure of the slot @var{obj}."
482 %slot-definition-slot-ref/raw slot-index-slot-ref/raw)
483 (define-slot-accessor slot-definition-slot-ref
484 "Return the slot-ref procedure of the slot @var{obj}."
485 %slot-definition-slot-ref slot-index-slot-ref)
486 (define-slot-accessor slot-definition-slot-set!
487 "Return the slot-set! procedure of the slot @var{obj}."
488 %slot-definition-slot-set! slot-index-slot-set!)
489 (define-slot-accessor slot-definition-index
490 "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."
491 %slot-definition-index slot-index-index)
492 (define-slot-accessor slot-definition-size
493 "Return the number fields used by the slot @var{obj}, or @code{#f}."
494 %slot-definition-size slot-index-size)
497 (define (direct-slot-definition-class class initargs)
498 (get-keyword #:class initargs <slot>))
501 (define (make-slot class initargs)
502 (let ((slot (make-struct/no-tail class)))
503 (define-syntax-rule (init-slot offset kw default)
504 (struct-set! slot offset (get-keyword kw initargs default)))
505 (init-slot slot-index-name #:name #f)
506 (init-slot slot-index-allocation #:allocation #:instance)
507 (init-slot slot-index-init-keyword #:init-keyword #f)
508 (init-slot slot-index-init-form #:init-form *unbound*)
509 (init-slot slot-index-init-value #:init-value *unbound*)
510 (struct-set! slot slot-index-init-thunk
511 (or (get-keyword #:init-thunk initargs #f)
512 (let ((val (%slot-definition-init-value slot)))
516 (struct-set! slot slot-index-options initargs)
517 (init-slot slot-index-getter #:getter #f)
518 (init-slot slot-index-setter #:setter #f)
519 (init-slot slot-index-accessor #:accessor #f)
520 (struct-set! slot slot-index-slot-ref/raw #f)
521 (struct-set! slot slot-index-slot-ref #f)
522 (struct-set! slot slot-index-slot-set! #f)
523 (struct-set! slot slot-index-index #f)
524 (struct-set! slot slot-index-size #f)
528 (define (make class . args)
529 (unless (memq <slot> (class-precedence-list class))
530 (error "Unsupported class: ~S" class))
531 (make-slot class args))
534 (define (compute-direct-slot-definition class initargs)
535 (apply make (direct-slot-definition-class class initargs) initargs))
537 (define (compute-direct-slot-definition-initargs class slot-spec)
539 ((? symbol? name) (list #:name name))
540 (((? symbol? name) . initargs)
542 ;; If there is an #:init-form, the `class' macro will have
543 ;; already added an #:init-thunk. Still, if there isn't an
544 ;; #:init-thunk already but we do have an #:init-value,
545 ;; synthesize an #:init-thunk initarg. This will ensure
546 ;; that the #:init-thunk gets passed on to the effective
547 ;; slot definition too.
548 (if (get-keyword #:init-thunk initargs)
550 (let ((value (get-keyword #:init-value initargs *unbound*)))
553 (cons* #:init-thunk (lambda () value) initargs))))))))
556 (define-syntax cons-slot
558 ((_ (name #:class class) tail)
559 ;; Special case to avoid referencing specialized <slot> kinds,
560 ;; which are not defined yet.
561 (cons (list 'name) tail))
562 ((_ (name . initargs) tail)
563 (cons (list 'name . initargs) tail))))
564 (define-syntax-rule (initialize-direct-slots! class fold-slots)
565 (let ((specs (fold-slots macro-fold-right cons-slot '())))
566 (define (make-direct-slot-definition spec)
567 (let ((initargs (compute-direct-slot-definition-initargs class spec)))
568 (compute-direct-slot-definition class initargs)))
569 (struct-set! class class-index-direct-slots
570 (map make-direct-slot-definition specs))))
572 (initialize-direct-slots! <class> fold-class-slots)
573 (initialize-direct-slots! <slot> fold-slot-slots))
579 ;;; OK, at this point we have initialized `direct-slots' on both <class>
580 ;;; and <slot>. We need to define a standard way to make subclasses:
581 ;;; how to compute the precedence list of subclasses, how to compute the
582 ;;; list of slots in a subclass, and what layout to use for instances of
585 (define (compute-std-cpl c get-direct-supers)
586 "The standard class precedence list computation algorithm."
587 (define (only-non-null lst)
588 (filter (lambda (l) (not (null? l))) lst))
590 (define (merge-lists reversed-partial-result inputs)
592 ((every null? inputs)
593 (reverse! reversed-partial-result))
595 (let* ((candidate (lambda (c)
596 (and (not (any (lambda (l)
600 (candidate-car (lambda (l)
602 (candidate (car l)))))
603 (next (any candidate-car inputs)))
605 (goops-error "merge-lists: Inconsistent precedence graph"))
606 (let ((remove-next (lambda (l)
607 (if (eq? (car l) next)
610 (merge-lists (cons next reversed-partial-result)
611 (only-non-null (map remove-next inputs))))))))
612 (let ((c-direct-supers (get-direct-supers c)))
613 (merge-lists (list c)
614 (only-non-null (append (map class-precedence-list
616 (list c-direct-supers))))))
618 ;; This version of compute-cpl is replaced with a generic function once
620 (define (compute-cpl class)
621 (compute-std-cpl class class-direct-supers))
623 (define (effective-slot-definition-class class slot)
626 (define (compute-effective-slot-definition class slot)
627 ;; FIXME: Support slot being a list of slots, as in CLOS.
629 (effective-slot-definition-class class slot)
630 (slot-definition-options slot)))
632 (define (build-slots-list dslots cpl)
633 (define (slot-memq slot slots)
634 (let ((name (%slot-definition-name slot)))
635 (let lp ((slots slots))
639 (or (eq? (%slot-definition-name slot) name) (lp slots)))))))
640 (define (check-cpl slots static-slots)
641 (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
642 (scm-error 'misc-error #f
643 "a predefined static inherited field cannot be redefined"
645 (define (remove-duplicate-slots slots)
646 (let lp ((slots (reverse slots)) (res '()) (seen '()))
650 (let ((name (%slot-definition-name slot)))
653 (lp slots (cons slot res) (cons name seen))))))))
654 ;; For subclases of <class> and <slot>, we need to ensure that the
655 ;; <class> or <slot> slots come first.
656 (let* ((static-slots (cond
658 (when (memq <slot> cpl) (error "invalid class"))
659 (struct-ref <class> class-index-slots))
661 (struct-ref <slot> class-index-slots))
664 (check-cpl dslots static-slots))
665 (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
667 (() (remove-duplicate-slots (append static-slots res)))
669 (let ((new-slots (struct-ref head class-index-direct-slots)))
672 (lp cpl (append new-slots res) static-slots))
673 ((or (eq? head <class>) (eq? head <slot>))
674 ;; Move static slots to the head of the list.
675 (lp cpl res new-slots))
677 (check-cpl new-slots static-slots)
678 (lp cpl (append new-slots res) static-slots)))))))))
681 (define (compute-get-n-set class slot)
682 (let ((index (struct-ref class class-index-nfields)))
683 (struct-set! class class-index-nfields (1+ index))
686 ;;; Pre-generate getters and setters for the first 20 slots.
687 (define-syntax define-standard-accessor-method
689 (define num-standard-pre-cache 20)
691 ((_ ((proc n) arg ...) body)
693 (let ((cache (vector #,@(map (lambda (n*)
697 (iota num-standard-pre-cache)))))
699 (if (< n #,num-standard-pre-cache)
701 (lambda (arg ...) body)))))))))
703 (define-standard-accessor-method ((bound-check-get n) o)
704 (let ((x (struct-ref o n)))
709 (define-standard-accessor-method ((standard-get n) o)
712 (define-standard-accessor-method ((standard-set n) o v)
715 (define (allocate-slots class slots)
716 "Transform the computed list of direct slot definitions @var{slots}
717 into a corresponding list of effective slot definitions, allocating
719 (define (make-effective-slot-definition slot)
720 ;; `compute-get-n-set' is expected to mutate `nfields' if it
721 ;; allocates a field to the object. Pretty strange, but we preserve
722 ;; the behavior for backward compatibility.
723 (let* ((slot (compute-effective-slot-definition class slot))
724 (name (%slot-definition-name slot))
725 (index (struct-ref class class-index-nfields))
726 (g-n-s (compute-get-n-set class slot))
727 (size (- (struct-ref class class-index-nfields) index)))
733 (error "unexpected return from compute-get-n-set"))
734 (values (standard-get g-n-s)
735 (if (slot-definition-init-thunk slot)
737 (bound-check-get g-n-s))
738 (standard-set g-n-s)))
739 (((? procedure? get) (? procedure? set))
742 (let ((value (get o)))
744 (slot-unbound class o name)
747 (lambda (get/raw get set)
748 (struct-set! slot slot-index-slot-ref/raw get/raw)
749 (struct-set! slot slot-index-slot-ref get)
750 (struct-set! slot slot-index-slot-set! set)
751 (struct-set! slot slot-index-index index)
752 (struct-set! slot slot-index-size size)))
754 (struct-set! class class-index-nfields 0)
755 (map-in-order make-effective-slot-definition slots))
757 (define (%compute-layout slots nfields is-class?)
758 (define (slot-protection-and-kind slot)
759 (define (subclass? class parent)
760 (memq parent (class-precedence-list class)))
761 (let ((type (kw-arg-ref (%slot-definition-options slot) #:class)))
762 (if (and type (subclass? type <foreign-slot>))
764 ((subclass? type <self-slot>) #\s)
765 ((subclass? type <protected-slot>) #\p)
768 ((subclass? type <opaque-slot>) #\o)
769 ((subclass? type <read-only-slot>) #\r)
770 ((subclass? type <hidden-slot>) #\h)
773 (let ((layout (make-string (* nfields 2))))
774 (let lp ((n 0) (slots slots))
777 (unless (= n nfields) (error "bad nfields"))
779 (let ((class-layout (struct-ref <class> class-index-layout)))
780 (unless (string-prefix? (symbol->string class-layout) layout)
781 (error "bad layout for class"))))
784 (unless (= n (%slot-definition-index slot)) (error "bad allocation"))
785 (call-with-values (lambda () (slot-protection-and-kind slot))
786 (lambda (protection kind)
787 (let init ((n n) (size (%slot-definition-size slot)))
789 ((zero? size) (lp n slots))
791 (unless (< n nfields) (error "bad nfields"))
792 (string-set! layout (* n 2) protection)
793 (string-set! layout (1+ (* n 2)) kind)
794 (init (1+ n) (1- size))))))))))))
800 ;;; With all of this, we are now able to define subclasses of <class>.
802 (define (%prep-layout! class)
803 (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
804 (layout (%compute-layout (struct-ref class class-index-slots)
805 (struct-ref class class-index-nfields)
807 (%init-layout! class layout)))
809 (define (make-standard-class class name dsupers dslots)
810 (let ((z (make-struct/no-tail class)))
811 (define (make-direct-slot-definition dslot)
812 (let ((initargs (compute-direct-slot-definition-initargs z dslot)))
813 (compute-direct-slot-definition z initargs)))
815 (struct-set! z class-index-name name)
816 (struct-set! z class-index-nfields 0)
817 (struct-set! z class-index-direct-supers dsupers)
818 (struct-set! z class-index-direct-subclasses '())
819 (struct-set! z class-index-direct-methods '())
820 (struct-set! z class-index-redefined #f)
821 (let ((cpl (compute-cpl z)))
822 (struct-set! z class-index-cpl cpl)
823 (when (memq <slot> cpl)
824 (class-add-flags! z vtable-flag-goops-slot))
825 (let* ((dslots (map make-direct-slot-definition dslots))
826 (slots (allocate-slots z (build-slots-list dslots cpl))))
827 (struct-set! z class-index-direct-slots dslots)
828 (struct-set! z class-index-slots slots)))
831 (let ((subclasses (struct-ref super class-index-direct-subclasses)))
832 (struct-set! super class-index-direct-subclasses
833 (cons z subclasses))))
838 (define-syntax define-standard-class
840 ((define-standard-class name (super ...) #:metaclass meta slot ...)
842 (make-standard-class meta 'name (list super ...) '(slot ...))))
843 ((define-standard-class name (super ...) slot ...)
844 (define-standard-class name (super ...) #:metaclass <class> slot ...))))
850 ;;; Sweet! Now we can define <top> and <object>, and finish
851 ;;; initializing the `direct-subclasses', `direct-supers', and `cpl'
852 ;;; slots of <class>.
854 (define-standard-class <top> ())
855 (define-standard-class <object> (<top>))
857 ;; The inheritance links for <top>, <object>, <class>, and <slot> were
858 ;; partially initialized. Correct them here.
859 (struct-set! <object> class-index-direct-subclasses (list <slot> <class>))
860 (struct-set! <class> class-index-direct-supers (list <object>))
861 (struct-set! <slot> class-index-direct-supers (list <object>))
862 (struct-set! <class> class-index-cpl (list <class> <object> <top>))
863 (struct-set! <slot> class-index-cpl (list <slot> <object> <top>))
869 ;;; We can also define the various slot types, and finish initializing
870 ;;; `direct-slots' and `slots' on <class> and <slot>.
872 (define-standard-class <foreign-slot> (<slot>))
873 (define-standard-class <protected-slot> (<foreign-slot>))
874 (define-standard-class <hidden-slot> (<foreign-slot>))
875 (define-standard-class <opaque-slot> (<foreign-slot>))
876 (define-standard-class <read-only-slot> (<foreign-slot>))
877 (define-standard-class <self-slot> (<read-only-slot>))
878 (define-standard-class <protected-opaque-slot> (<protected-slot>
880 (define-standard-class <protected-hidden-slot> (<protected-slot>
882 (define-standard-class <protected-read-only-slot> (<protected-slot>
884 (define-standard-class <scm-slot> (<protected-slot>))
885 (define-standard-class <int-slot> (<foreign-slot>))
886 (define-standard-class <float-slot> (<foreign-slot>))
887 (define-standard-class <double-slot> (<foreign-slot>))
893 ;;; Finally! Initialize `direct-slots' and `slots' on <class>, and
894 ;;; `slots' on <slot>.
897 (define-syntax-rule (cons-slot (name . initargs) tail)
898 (cons (list 'name . initargs) tail))
899 (define-syntax-rule (initialize-direct-slots! class fold-slots)
900 (let ((specs (fold-slots macro-fold-right cons-slot '())))
901 (define (make-direct-slot-definition spec)
902 (let ((initargs (compute-direct-slot-definition-initargs class spec)))
903 (compute-direct-slot-definition class initargs)))
904 (struct-set! class class-index-direct-slots
905 (map make-direct-slot-definition specs))))
906 (define (initialize-slots! class)
907 (let ((slots (build-slots-list (class-direct-slots class)
908 (class-precedence-list class))))
909 (struct-set! class class-index-slots (allocate-slots class slots))))
911 ;; Finish initializing <class> with the specialized slot kinds.
912 (initialize-direct-slots! <class> fold-class-slots)
914 (initialize-slots! <class>)
915 (initialize-slots! <slot>))
921 ;;; Now, to build out the class hierarchy.
924 (define-standard-class <procedure-class> (<class>))
926 (define-standard-class <applicable-struct-class>
928 (class-add-flags! <applicable-struct-class>
929 vtable-flag-applicable-vtable)
931 (define-standard-class <applicable-struct-with-setter-class>
932 (<applicable-struct-class>))
933 (class-add-flags! <applicable-struct-with-setter-class>
934 vtable-flag-setter-vtable)
936 (define-standard-class <applicable> (<top>))
937 (define-standard-class <applicable-struct> (<object> <applicable>)
938 #:metaclass <applicable-struct-class>
940 (define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
941 #:metaclass <applicable-struct-with-setter-class>
943 (define-standard-class <generic> (<applicable-struct>)
944 #:metaclass <applicable-struct-class>
946 (n-specialized #:init-value 0)
947 (extended-by #:init-value ())
949 (define-standard-class <extended-generic> (<generic>)
950 #:metaclass <applicable-struct-class>
951 (extends #:init-value ()))
952 (define-standard-class <generic-with-setter> (<generic>
953 <applicable-struct-with-setter>)
954 #:metaclass <applicable-struct-with-setter-class>)
955 (define-standard-class <accessor> (<generic-with-setter>)
956 #:metaclass <applicable-struct-with-setter-class>)
957 (define-standard-class <extended-generic-with-setter> (<extended-generic>
958 <generic-with-setter>)
959 #:metaclass <applicable-struct-with-setter-class>)
960 (define-standard-class <extended-accessor> (<accessor>
961 <extended-generic-with-setter>)
962 #:metaclass <applicable-struct-with-setter-class>)
964 (define-standard-class <method> (<object>)
971 (define-standard-class <accessor-method> (<method>)
972 (slot-definition #:init-keyword #:slot-definition))
974 (define-standard-class <boolean> (<top>))
975 (define-standard-class <char> (<top>))
976 (define-standard-class <list> (<top>))
977 ;; Not all pairs are lists, but there is code out there that relies on
978 ;; (is-a? '(1 2 3) <list>) to work. Terrible. How to fix?
979 (define-standard-class <pair> (<list>))
980 (define-standard-class <null> (<list>))
981 (define-standard-class <string> (<top>))
982 (define-standard-class <symbol> (<top>))
983 (define-standard-class <vector> (<top>))
984 (define-standard-class <foreign> (<top>))
985 (define-standard-class <hashtable> (<top>))
986 (define-standard-class <fluid> (<top>))
987 (define-standard-class <dynamic-state> (<top>))
988 (define-standard-class <frame> (<top>))
989 (define-standard-class <vm-continuation> (<top>))
990 (define-standard-class <bytevector> (<top>))
991 (define-standard-class <uvec> (<bytevector>))
992 (define-standard-class <array> (<top>))
993 (define-standard-class <bitvector> (<top>))
994 (define-standard-class <number> (<top>))
995 (define-standard-class <complex> (<number>))
996 (define-standard-class <real> (<complex>))
997 (define-standard-class <integer> (<real>))
998 (define-standard-class <fraction> (<real>))
999 (define-standard-class <keyword> (<top>))
1000 (define-standard-class <unknown> (<top>))
1001 (define-standard-class <procedure> (<applicable>)
1002 #:metaclass <procedure-class>)
1003 (define-standard-class <primitive-generic> (<procedure>)
1004 #:metaclass <procedure-class>)
1005 (define-standard-class <port> (<top>))
1006 (define-standard-class <input-port> (<port>))
1007 (define-standard-class <output-port> (<port>))
1008 (define-standard-class <input-output-port> (<input-port> <output-port>))
1010 (define (inherit-applicable! class)
1011 "An internal routine to redefine a SMOB class that was added after
1012 GOOPS was loaded, and on which scm_set_smob_apply installed an apply
1014 ;; Why not use class-redefinition? We would, except that loading the
1015 ;; compiler to compile effective methods can happen while GOOPS has
1016 ;; only been partially loaded, and loading the compiler might cause
1017 ;; SMOB types to be defined that need this facility. Instead we make
1018 ;; a very specific hack, not a general solution. Probably the right
1019 ;; solution is to avoid using the compiler, but that is another kettle
1021 (unless (memq <applicable> (class-precedence-list class))
1022 (unless (null? (class-slots class))
1023 (error "SMOB object has slots?"))
1026 (let ((subclasses (struct-ref super class-index-direct-subclasses)))
1027 (struct-set! super class-index-direct-subclasses
1028 (delq class subclasses))))
1029 (struct-ref class class-index-direct-supers))
1030 (struct-set! class class-index-direct-supers (list <applicable>))
1031 (struct-set! class class-index-cpl (compute-cpl class))
1032 (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
1033 (struct-set! <applicable> class-index-direct-subclasses
1034 (cons class subclasses)))))
1040 ;;; At this point we have defined the class hierarchy, and it's time to
1041 ;;; move on to instance allocation and generics. Once we have generics,
1042 ;;; we'll fill out the metaobject protocol.
1044 ;;; Here we define a limited version of `make', so that we can allocate
1045 ;;; instances of specific classes. This definition will be replaced
1048 (define (%invalidate-method-cache! gf)
1049 (slot-set! gf 'effective-methods '())
1050 (recompute-generic-function-dispatch-procedure! gf))
1053 (define (invalidate-method-cache! gf)
1054 (%invalidate-method-cache! gf))
1056 (define (make class . args)
1058 ((or (eq? class <generic>) (eq? class <accessor>))
1059 (let ((z (make-struct/no-tail class #f '() 0 '())))
1060 (set-procedure-property! z 'name (get-keyword #:name args #f))
1061 (invalidate-method-cache! z)
1062 (when (eq? class <accessor>)
1063 (let ((setter (get-keyword #:setter args #f)))
1065 (slot-set! z 'setter setter))))
1068 (let ((z (%allocate-instance class)))
1070 ((or (eq? class <method>) (eq? class <accessor-method>))
1071 (for-each (match-lambda
1073 (slot-set! z slot (get-keyword kw args default))))
1074 '((#:generic-function generic-function #f)
1075 (#:specializers specializers ())
1076 (#:procedure procedure #f)
1077 (#:formals formals ())
1079 (#:make-procedure make-procedure #f))))
1080 ((memq <class> (class-precedence-list class))
1081 (class-add-flags! z (logior vtable-flag-goops-class
1082 vtable-flag-goops-valid))
1083 (for-each (match-lambda
1085 (slot-set! z slot (get-keyword kw args default))))
1087 (#:dsupers direct-supers ())
1088 (#:slots direct-slots ()))))
1090 (error "boot `make' does not support this class" class)))
1099 ;;; Before we go on, some notes about class redefinition. In GOOPS,
1100 ;;; classes can be redefined. Redefinition of a class marks the class
1101 ;;; as invalid, and instances will be lazily migrated over to the new
1102 ;;; representation as they are accessed. Migration happens when
1103 ;;; `class-of' is called on an instance. For more technical details on
1104 ;;; object redefinition, see struct.h.
1106 ;;; In the following interfaces, class-of handles the redefinition
1107 ;;; protocol. I would think though that there is some thread-unsafety
1108 ;;; here though as the { class, object data } pair needs to be accessed
1109 ;;; atomically, not the { class, object } pair.
1111 (define-inlinable (%class-slot-definition class slot-name kt kf)
1112 (let lp ((slots (struct-ref class class-index-slots)))
1115 (if (eq? (%slot-definition-name slot) slot-name)
1120 (define (class-slot-definition class slot-name)
1121 (unless (class? class)
1122 (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f))
1123 (%class-slot-definition class slot-name
1124 (lambda (slot) slot)
1127 (define (slot-ref obj slot-name)
1128 "Return the value from @var{obj}'s slot with the nam var{slot_name}."
1129 (let ((class (class-of obj)))
1130 (define (have-slot slot)
1131 ((%slot-definition-slot-ref slot) obj))
1133 (unless (symbol? slot-name)
1134 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
1135 (list slot-name) #f))
1136 (let ((val (slot-missing class obj slot-name)))
1138 (slot-unbound class obj slot-name)
1140 (%class-slot-definition class slot-name have-slot no-slot)))
1142 (define (slot-set! obj slot-name value)
1143 "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
1144 (let ((class (class-of obj)))
1145 (define (have-slot slot)
1146 ((%slot-definition-slot-set! slot) obj value))
1148 (unless (symbol? slot-name)
1149 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
1150 (list slot-name) #f))
1151 (slot-missing class obj slot-name value))
1153 (%class-slot-definition class slot-name have-slot no-slot)))
1155 (define (slot-bound? obj slot-name)
1156 "Return the value from @var{obj}'s slot with the nam var{slot_name}."
1157 (let ((class (class-of obj)))
1158 (define (have-slot slot)
1159 (not (unbound? ((%slot-definition-slot-ref/raw slot) obj))))
1161 (unless (symbol? slot-name)
1162 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
1163 (list slot-name) #f))
1164 (not (unbound? (slot-missing class obj slot-name))))
1165 (%class-slot-definition class slot-name have-slot no-slot)))
1167 (define (slot-exists? obj slot-name)
1168 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
1169 (define (have-slot slot) #t)
1171 (unless (symbol? slot-name)
1172 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
1173 (list slot-name) #f))
1175 (%class-slot-definition (class-of obj) slot-name have-slot no-slot))
1178 (define (check-slot-args class obj slot-name)
1179 (unless (eq? class (class-of obj))
1180 (scm-error 'wrong-type-arg #f "~S is not the class of ~S"
1181 (list class obj) #f))
1182 (unless (symbol? slot-name)
1183 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
1184 (list slot-name) #f)))
1186 (define (slot-ref-using-class class obj slot-name)
1187 (issue-deprecation-warning "slot-ref-using-class is deprecated. "
1188 "Use slot-ref instead.")
1189 (check-slot-args class obj slot-name)
1190 (slot-ref obj slot-name))
1192 (define (slot-set-using-class! class obj slot-name value)
1193 (issue-deprecation-warning "slot-set-using-class! is deprecated. "
1194 "Use slot-set! instead.")
1195 (check-slot-args class obj slot-name)
1196 (slot-set! obj slot-name value))
1198 (define (slot-bound-using-class? class obj slot-name)
1199 (issue-deprecation-warning "slot-bound-using-class? is deprecated. "
1200 "Use slot-bound? instead.")
1201 (check-slot-args class obj slot-name)
1202 (slot-bound? obj slot-name))
1204 (define (slot-exists-using-class? class obj slot-name)
1205 (issue-deprecation-warning "slot-exists-using-class? is deprecated. "
1206 "Use slot-exists? instead.")
1207 (check-slot-args class obj slot-name)
1208 (slot-exists? obj slot-name)))
1214 ;;; Method accessors.
1216 (define (method-generic-function obj)
1217 "Return the generic function for the method @var{obj}."
1218 (unless (is-a? obj <method>)
1219 (scm-error 'wrong-type-arg #f "Not a method: ~S"
1221 (slot-ref obj 'generic-function))
1223 (define (method-specializers obj)
1224 "Return specializers of the method @var{obj}."
1225 (unless (is-a? obj <method>)
1226 (scm-error 'wrong-type-arg #f "Not a method: ~S"
1228 (slot-ref obj 'specializers))
1230 (define (method-procedure obj)
1231 "Return the procedure of the method @var{obj}."
1232 (unless (is-a? obj <method>)
1233 (scm-error 'wrong-type-arg #f "Not a method: ~S"
1235 (slot-ref obj 'procedure))
1241 ;;; Generic functions!
1243 ;;; Generic functions have an applicable-methods cache associated with
1244 ;;; them. Every distinct set of types that is dispatched through a
1245 ;;; generic adds an entry to the cache. A composite dispatch procedure
1246 ;;; is recomputed every time an entry gets added to the cache, or when
1247 ;;; the cache is invalidated.
1249 ;;; In steady-state, this dispatch procedure is never regenerated; but
1250 ;;; during warm-up there is some churn.
1252 ;;; So what is the deal if warm-up happens in a multithreaded context?
1253 ;;; There is indeed a window between missing the cache for a certain set
1254 ;;; of arguments, and then updating the cache with the newly computed
1255 ;;; applicable methods. One of the updaters is liable to lose their new
1258 ;;; This is actually OK though, because a subsequent cache miss for the
1259 ;;; race loser will just cause memoization to try again. The cache will
1260 ;;; eventually be consistent. We're not mutating the old part of the
1261 ;;; cache, just consing on the new entry.
1263 ;;; It doesn't even matter if the dispatch procedure and the cache are
1264 ;;; inconsistent -- most likely the type-set that lost the dispatch
1265 ;;; procedure race will simply re-trigger a memoization, but since the
1266 ;;; winner isn't in the effective-methods cache, it will likely also
1267 ;;; re-trigger a memoization, and the cache will finally be consistent.
1268 ;;; As you can see there is a possibility for ping-pong effects, but
1269 ;;; it's unlikely given the shortness of the window between slot-set!
1272 ;;; We probably do need to use atomic access primitives to correctly
1273 ;;; handle concurrency, but that's a more general Guile concern.
1276 (define-syntax arity-case
1279 ;; (arity-case n 2 foo bar)
1285 ((arity-case n max form alternate)
1286 (let ((max (syntax->datum #'max)))
1289 (let ((ids (map (lambda (n)
1290 (let* ((n (+ (char->integer #\a) n))
1291 (c (integer->char n)))
1292 (datum->syntax #'here (symbol c))))
1294 #`(((#,n) (form #,@ids))
1298 (else alternate)))))))
1301 ;;; These dispatchers are set as the "procedure" field of <generic>
1302 ;;; instances. Unlike CLOS, in GOOPS a generic function can have
1303 ;;; multiple arities.
1305 ;;; We pre-generate fast dispatchers for applications of up to 20
1306 ;;; arguments. More arguments than that will go through slower generic
1307 ;;; routines that cons arguments into a rest list.
1309 (define (multiple-arity-dispatcher fv miss)
1310 (define-syntax dispatch
1312 (define (build-clauses args)
1313 (let ((len (length (syntax->datum args))))
1314 #`((#,args ((vector-ref fv #,len) . #,args))
1315 . #,(syntax-case args ()
1317 ((arg ... _) (build-clauses #'(arg ...)))))))
1321 #,@(build-clauses #'(arg ...))
1322 (args (apply miss args)))))))
1323 (arity-case (vector-length fv) 20 dispatch
1325 (let ((nargs (length args)))
1326 (if (< nargs (vector-length fv))
1327 (apply (vector-ref fv nargs) args)
1328 (apply miss args))))))
1331 ;;; The above multiple-arity-dispatcher is entirely sufficient, and
1332 ;;; should be fast enough. Still, for no good reason we also have an
1333 ;;; arity dispatcher for generics that are only called with one arity.
1335 (define (single-arity-dispatcher f nargs miss)
1336 (define-syntax-rule (dispatch arg ...)
1338 ((arg ...) (f arg ...))
1339 (args (apply miss args))))
1340 (arity-case nargs 20 dispatch
1342 (if (eqv? (length args) nargs)
1344 (apply miss args)))))
1347 ;;; The guts of generic function dispatch are here. Once we've selected
1348 ;;; an arity, we need to map from arguments to effective method. Until
1349 ;;; we have `eqv?' specializers, this map is entirely a function of the
1350 ;;; types (classes) of the arguments. So, we look in the cache to see
1351 ;;; if we have seen this set of concrete types, and if so we apply the
1352 ;;; previously computed effective method. Otherwise we miss the cache,
1353 ;;; so we'll have to compute the right answer for this set of types, add
1354 ;;; the mapping to the cache, and apply the newly computed method.
1356 ;;; The cached mapping is invalidated whenever a new method is defined
1357 ;;; on this generic, or whenever the class hierarchy of any method
1358 ;;; specializer changes.
1360 (define (single-arity-cache-dispatch cache nargs cache-miss)
1363 (((typev . cmethod) . cache)
1365 ((eqv? nargs (vector-length typev))
1366 (let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss)))
1367 (define (type-ref n)
1368 (and (< n nargs) (vector-ref typev n)))
1369 (define-syntax args-match?
1372 ((args-match? (arg type) (arg* type*) ...)
1373 ;; Check that the arg has the exact type that we saw. It
1374 ;; could be that `type' is #f, which indicates the end of
1375 ;; the specializers list. Once all specializers have been
1376 ;; examined, we don't need to look at any more arguments
1377 ;; to know that this is a cache hit.
1379 (and (eq? (class-of arg) type)
1380 (args-match? (arg* type*) ...))))))
1381 (define-syntax dispatch
1383 (define (bind-types types k)
1384 (let lp ((types types) (n 0))
1385 (syntax-case types ()
1388 #`(let ((type (type-ref #,n)))
1389 #,(lp #'types (1+ n)))))))
1392 (with-syntax (((type ...) (generate-temporaries #'(arg ...))))
1397 (if (args-match? (arg type) ...)
1399 (cache-miss arg ...))))))))))
1400 (arity-case nargs 20 dispatch
1402 (define (args-match? args)
1403 (let lp ((args args) (n 0))
1406 (or (not (vector-ref typev n))
1407 (and (eq? (vector-ref typev n) (class-of arg))
1410 (if (args-match? args)
1411 (apply cmethod args)
1412 (apply cache-miss args))))))
1414 (single-arity-cache-dispatch cache nargs cache-miss))))))
1416 (define (compute-generic-function-dispatch-procedure gf)
1417 (define (seen-arities cache)
1418 (let lp ((arities 0) (cache cache))
1421 (((typev . cmethod) . cache)
1422 (lp (logior arities (ash 1 (vector-length typev)))
1424 (define (cache-miss . args)
1425 (memoize-generic-function-application! gf args)
1427 (let* ((cache (slot-ref gf 'effective-methods))
1428 (arities (seen-arities cache))
1429 (max-arity (let lp ((max -1))
1430 (if (< arities (ash 1 (1+ max)))
1435 ;; Nothing in the cache.
1437 ((= arities (ash 1 max-arity))
1438 ;; Only one arity in the cache.
1439 (let* ((nargs max-arity)
1440 (f (single-arity-cache-dispatch cache nargs cache-miss)))
1441 (single-arity-dispatcher f nargs cache-miss)))
1443 ;; Multiple arities.
1444 (let ((fv (make-vector (1+ max-arity) #f)))
1446 (when (<= n max-arity)
1447 (let ((f (single-arity-cache-dispatch cache n cache-miss)))
1448 (vector-set! fv n f)
1450 (multiple-arity-dispatcher fv cache-miss))))))
1452 (define (recompute-generic-function-dispatch-procedure! gf)
1453 (slot-set! gf 'procedure
1454 (compute-generic-function-dispatch-procedure gf)))
1456 (define (memoize-effective-method! gf args applicable)
1457 (define (record-types args)
1458 (let ((typev (make-vector (length args) #f)))
1459 (let lp ((n 0) (args args))
1460 (when (and (< n (slot-ref gf 'n-specialized))
1464 (vector-set! typev n (class-of arg))
1465 (lp (1+ n) args)))))
1467 (let* ((typev (record-types args))
1468 (compute-effective-method (if (eq? (class-of gf) <generic>)
1469 %compute-effective-method
1470 compute-effective-method))
1471 (cmethod (compute-effective-method gf applicable typev))
1472 (cache (acons typev cmethod (slot-ref gf 'effective-methods))))
1473 (slot-set! gf 'effective-methods cache)
1474 (recompute-generic-function-dispatch-procedure! gf)
1478 ;;; If a method refers to `next-method' in its body, that method will be
1479 ;;; able to dispatch to the next most specific method. The exact
1480 ;;; `next-method' implementation is only known at runtime, as it is a
1481 ;;; function of which precise argument types are being dispatched, which
1482 ;;; might be subclasses of the method's declared specializers.
1484 ;;; Guile implements `next-method' by binding it as a closure variable.
1485 ;;; An effective method is bound to a specific `next-method' by the
1486 ;;; `make-procedure' slot of a <method>, which returns the new closure.
1488 (define (%compute-specialized-effective-method gf method types next-method)
1489 (match (slot-ref method 'make-procedure)
1490 (#f (method-procedure method))
1491 (make-procedure (make-procedure next-method))))
1493 (define (compute-specialized-effective-method gf method types next-method)
1494 (%compute-specialized-effective-method gf method types next-method))
1496 (define (%compute-effective-method gf methods types)
1499 (let ((compute-specialized-effective-method
1500 (if (and (eq? (class-of gf) <generic>)
1501 (eq? (class-of method) <method>))
1502 %compute-specialized-effective-method
1503 compute-specialized-effective-method)))
1504 (compute-specialized-effective-method
1509 (no-next-method gf args)))
1511 (let ((compute-effective-method (if (eq? (class-of gf) <generic>)
1512 %compute-effective-method
1513 compute-effective-method)))
1514 (compute-effective-method gf methods types)))))))))
1516 ;; Boot definition; overrided with a generic later.
1517 (define (compute-effective-method gf methods types)
1518 (%compute-effective-method gf methods types))
1524 (define (memoize-generic-function-application! gf args)
1525 (let ((applicable ((if (eq? (class-of gf) <generic>)
1526 %compute-applicable-methods
1527 compute-applicable-methods)
1530 (memoize-effective-method! gf args applicable))
1532 (no-applicable-method gf args)))))
1534 (define no-applicable-method
1535 (make <generic> #:name 'no-applicable-method))
1539 ;; Then load the rest of GOOPS
1542 ;; FIXME: deprecate.
1543 (define min-fixnum (- (expt 2 29)))
1544 (define max-fixnum (- (expt 2 29) 1))
1549 (define (goops-error format-string . args)
1550 (scm-error 'goops-error #f format-string args '()))
1556 (define ensure-metaclass-with-supers
1557 (let ((table-of-metas '()))
1558 (lambda (meta-supers)
1559 (let ((entry (assoc meta-supers table-of-metas)))
1561 ;; Found a previously created metaclass
1563 ;; Create a new meta-class which inherit from "meta-supers"
1564 (let ((new (make <class> #:dsupers meta-supers
1566 #:name (gensym "metaclass"))))
1567 (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
1570 (define (ensure-metaclass supers)
1573 (let* ((all-metas (map (lambda (x) (class-of x)) supers))
1574 (all-cpls (append-map (lambda (m)
1575 (cdr (class-precedence-list m)))
1578 ;; Find the most specific metaclasses. The new metaclass will be
1579 ;; a subclass of these.
1582 (when (and (not (member meta all-cpls))
1583 (not (member meta needed-metas)))
1584 (set! needed-metas (append needed-metas (list meta)))))
1586 ;; Now return a subclass of the metaclasses we found.
1587 (if (null? (cdr needed-metas))
1588 (car needed-metas) ; If there's only one, just use it.
1589 (ensure-metaclass-with-supers needed-metas)))))
1595 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
1597 ;;; SLOT-DEFINITION ::= INSTANCE-OF-<SLOT> | (SLOT-NAME OPTION ...)
1598 ;;; OPTION ::= KEYWORD VALUE
1601 (define (make-class supers slots . options)
1602 (define (find-duplicate l)
1606 (if (memq head tail)
1608 (find-duplicate tail)))))
1609 (define (slot-spec->name slot-spec)
1611 (((? symbol? name) . args) name)
1612 ;; We can get here when redefining classes.
1613 ((? slot? slot) (%slot-definition-name slot))))
1615 (let* ((name (get-keyword #:name options *unbound*))
1616 (supers (if (not (or-map (lambda (class)
1618 (class-precedence-list class)))
1620 (append supers (list <object>))
1622 (metaclass (or (get-keyword #:metaclass options #f)
1623 (ensure-metaclass supers))))
1625 ;; Verify that all direct slots are different and that we don't inherit
1626 ;; several time from the same class
1627 (let ((tmp1 (find-duplicate supers))
1628 (tmp2 (find-duplicate (map slot-spec->name slots))))
1630 (goops-error "make-class: super class ~S is duplicate in class ~S"
1633 (goops-error "make-class: slot ~S is duplicate in class ~S"
1636 ;; Everything seems correct, build the class
1637 (apply make metaclass
1643 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
1645 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
1646 ;;; OPTION ::= KEYWORD VALUE
1648 (define-syntax class
1650 (define (parse-options options)
1651 (syntax-case options ()
1653 ((kw arg . options) (keyword? (syntax->datum #'kw))
1654 (with-syntax ((options (parse-options #'options)))
1655 (syntax-case #'kw ()
1657 #'(kw 'arg #:init-thunk (lambda () arg) . options))
1659 #'(kw arg . options)))))))
1660 (define (check-valid-kwargs args)
1661 (syntax-case args ()
1663 ((kw arg . args) (keyword? (syntax->datum #'kw))
1664 #`(kw arg . #,(check-valid-kwargs #'args)))))
1665 (define (parse-slots-and-kwargs args)
1666 (syntax-case args ()
1669 ((kw . _) (keyword? (syntax->datum #'kw))
1670 #`(() #,(check-valid-kwargs args)))
1671 (((name option ...) args ...)
1672 (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
1673 ((option ...) (parse-options #'(option ...))))
1674 #'(((list 'name option ...) . slots) kwargs)))
1675 ((name args ...) (symbol? (syntax->datum #'name))
1676 (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
1677 #'(('(name) . slots) kwargs)))))
1679 ((class (super ...) arg ...)
1680 (with-syntax ((((slot-def ...) (option ...))
1681 (parse-slots-and-kwargs #'(arg ...))))
1682 #'(make-class (list super ...)
1686 (define-syntax define-class-pre-definition
1689 ((_ (k arg rest ...) out ...)
1690 (keyword? (syntax->datum #'k))
1691 (case (syntax->datum #'k)
1692 ((#:getter #:setter)
1693 #'(define-class-pre-definition (rest ...)
1695 (when (or (not (defined? 'arg))
1696 (not (is-a? arg <generic>)))
1699 (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
1701 #'(define-class-pre-definition (rest ...)
1703 (when (or (not (defined? 'arg))
1704 (not (is-a? arg <accessor>)))
1707 (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
1709 #'(define-class-pre-definition (rest ...) out ...))))
1711 #'(begin out ...)))))
1713 ;; Some slot options require extra definitions to be made. In
1714 ;; particular, we want to make sure that the generic function objects
1715 ;; which represent accessors exist before `make-class' tries to add
1717 (define-syntax define-class-pre-definitions
1722 ((_ (slot rest ...) out ...)
1723 (keyword? (syntax->datum #'slot))
1725 ((_ (slot rest ...) out ...)
1726 (identifier? #'slot)
1727 #'(define-class-pre-definitions (rest ...)
1729 ((_ ((slotname slotopt ...) rest ...) out ...)
1730 #'(define-class-pre-definitions (rest ...)
1731 out ... (define-class-pre-definition (slotopt ...)))))))
1733 (define-syntax-rule (define-class name supers slot ...)
1735 (define-class-pre-definitions (slot ...))
1736 (if (and (defined? 'name)
1737 (is-a? name <class>)
1738 (memq <object> (class-precedence-list name)))
1739 (class-redefinition name
1740 (class supers slot ... #:name 'name))
1741 (toplevel-define! 'name (class supers slot ... #:name 'name)))))
1743 (define-syntax-rule (standard-define-class arg ...)
1744 (define-class arg ...))
1747 ;;; {Generic functions and accessors}
1750 ;; Apparently the desired semantics are that we extend previous
1751 ;; procedural definitions, but that if `name' was already a generic, we
1752 ;; overwrite its definition.
1753 (define-syntax define-generic
1756 ((define-generic name) (symbol? (syntax->datum #'name))
1758 (if (and (defined? 'name) (is-a? name <generic>))
1759 (make <generic> #:name 'name)
1760 (ensure-generic (if (defined? 'name) name #f) 'name)))))))
1762 (define-syntax define-extended-generic
1765 ((define-extended-generic name val) (symbol? (syntax->datum #'name))
1766 #'(define name (make-extended-generic val 'name))))))
1768 (define-syntax define-extended-generics
1770 (define (id-append ctx a b)
1771 (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
1773 ((define-extended-generic (name ...) #:prefix (prefix ...))
1774 (and (and-map symbol? (syntax->datum #'(name ...)))
1775 (and-map symbol? (syntax->datum #'(prefix ...))))
1776 (with-syntax ((((val ...)) (map (lambda (name)
1777 (map (lambda (prefix)
1778 (id-append name prefix name))
1782 (define-extended-generic name (list val ...))
1785 (define* (make-generic #:optional name)
1786 (make <generic> #:name name))
1788 (define* (make-extended-generic gfs #:optional name)
1789 (let* ((gfs (if (list? gfs) gfs (list gfs)))
1790 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
1792 (let* ((sname (and name (make-setter-name name)))
1794 (append-map (lambda (gf)
1795 (if (is-a? gf <generic-with-setter>)
1796 (list (ensure-generic (setter gf)
1800 (es (make <extended-generic-with-setter>
1803 #:setter (make <extended-generic>
1805 #:extends setters))))
1806 (extended-by! setters (setter es))
1808 (make <extended-generic>
1811 (extended-by! gfs ans)
1814 (define (extended-by! gfs eg)
1815 (for-each (lambda (gf)
1816 (slot-set! gf 'extended-by
1817 (cons eg (slot-ref gf 'extended-by))))
1819 (invalidate-method-cache! eg))
1821 (define (not-extended-by! gfs eg)
1822 (for-each (lambda (gf)
1823 (slot-set! gf 'extended-by
1824 (delq! eg (slot-ref gf 'extended-by))))
1826 (invalidate-method-cache! eg))
1828 (define* (ensure-generic old-definition #:optional name)
1829 (cond ((is-a? old-definition <generic>) old-definition)
1830 ((procedure-with-setter? old-definition)
1831 (make <generic-with-setter>
1833 #:default (procedure old-definition)
1834 #:setter (setter old-definition)))
1835 ((procedure? old-definition)
1836 (if (generic-capability? old-definition) old-definition
1837 (make <generic> #:name name #:default old-definition)))
1838 (else (make <generic> #:name name))))
1840 ;; same semantics as <generic>
1841 (define-syntax-rule (define-accessor name)
1843 (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
1844 ((is-a? name <accessor>) (make <accessor> #:name 'name))
1845 (else (ensure-accessor name 'name)))))
1847 (define (make-setter-name name)
1848 (string->symbol (string-append "setter:" (symbol->string name))))
1850 (define* (make-accessor #:optional name)
1853 #:setter (make <generic>
1854 #:name (and name (make-setter-name name)))))
1856 (define* (ensure-accessor proc #:optional name)
1857 (cond ((and (is-a? proc <accessor>)
1858 (is-a? (setter proc) <generic>))
1860 ((is-a? proc <generic-with-setter>)
1861 (upgrade-accessor proc (setter proc)))
1862 ((is-a? proc <generic>)
1863 (upgrade-accessor proc (make-generic name)))
1864 ((procedure-with-setter? proc)
1867 #:default (procedure proc)
1868 #:setter (ensure-generic (setter proc) name)))
1870 (ensure-accessor (if (generic-capability? proc)
1871 (make <generic> #:name name #:default proc)
1872 (ensure-generic proc name))
1875 (make-accessor name))))
1877 (define (upgrade-accessor generic setter)
1878 (let ((methods (slot-ref generic 'methods))
1879 (gws (make (if (is-a? generic <extended-generic>)
1880 <extended-generic-with-setter>
1882 #:name (generic-function-name generic)
1883 #:extended-by (slot-ref generic 'extended-by)
1885 (when (is-a? generic <extended-generic>)
1886 (let ((gfs (slot-ref generic 'extends)))
1887 (not-extended-by! gfs generic)
1888 (slot-set! gws 'extends gfs)
1889 (extended-by! gfs gws)))
1890 ;; Steal old methods
1891 (for-each (lambda (method)
1892 (slot-set! method 'generic-function gws))
1894 (slot-set! gws 'methods methods)
1895 (invalidate-method-cache! gws)
1902 ;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
1903 ;; element longer than the other when we have a dotted parameter
1904 ;; list). For instance, with the call
1910 ;; (define-method M (a . l) ....)
1911 ;; (define-method M (a) ....)
1913 ;; we consider that the second method is more specific.
1915 ;; Precondition: `a' and `b' are methods and are applicable to `types'.
1916 (define (%method-more-specific? a b types)
1917 (let lp ((a-specializers (method-specializers a))
1918 (b-specializers (method-specializers b))
1921 ;; (a) less specific than (a b ...) or (a . b)
1922 ((null? a-specializers) #t)
1923 ;; (a b ...) or (a . b) less specific than (a)
1924 ((null? b-specializers) #f)
1925 ;; (a . b) less specific than (a b ...)
1926 ((not (pair? a-specializers)) #f)
1927 ;; (a b ...) more specific than (a . b)
1928 ((not (pair? b-specializers)) #t)
1930 (let ((a-specializer (car a-specializers))
1931 (b-specializer (car b-specializers))
1932 (a-specializers (cdr a-specializers))
1933 (b-specializers (cdr b-specializers))
1935 (types (cdr types)))
1936 (if (eq? a-specializer b-specializer)
1937 (lp a-specializers b-specializers types)
1938 (let lp ((cpl (class-precedence-list type)))
1939 (let ((elt (car cpl)))
1941 ((eq? a-specializer elt) #t)
1942 ((eq? b-specializer elt) #f)
1943 (else (lp (cdr cpl))))))))))))
1945 (define (%sort-applicable-methods methods types)
1946 (sort methods (lambda (a b) (%method-more-specific? a b types))))
1948 (define (generic-function-methods obj)
1949 "Return the methods of the generic function @var{obj}."
1950 (define (fold-upward method-lists gf)
1952 ((is-a? gf <extended-generic>)
1953 (let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends)))
1957 (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
1959 (else method-lists)))
1960 (define (fold-downward method-lists gf)
1961 (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
1962 (gfs (slot-ref gf 'extended-by)))
1966 (lp (fold-downward method-lists gf) gfs)))))
1967 (unless (is-a? obj <generic>)
1968 (scm-error 'wrong-type-arg #f "Not a generic: ~S"
1970 (concatenate (fold-downward (fold-upward '() obj) obj)))
1972 (define (%compute-applicable-methods gf args)
1973 (define (method-applicable? m types)
1974 (let lp ((specs (method-specializers m)) (types types))
1976 ((null? specs) (null? types))
1977 ((not (pair? specs)) #t)
1980 (and (memq (car specs) (class-precedence-list (car types)))
1981 (lp (cdr specs) (cdr types)))))))
1982 (let ((n (length args))
1983 (types (map class-of args)))
1984 (let lp ((methods (generic-function-methods gf))
1987 (and (not (null? applicable))
1988 (%sort-applicable-methods applicable types))
1989 (let ((m (car methods)))
1991 (if (method-applicable? m types)
1995 (define compute-applicable-methods %compute-applicable-methods)
1997 (define (toplevel-define! name val)
1998 (module-define! (current-module) name val))
2000 (define-syntax define-method
2001 (syntax-rules (setter)
2002 ((_ ((setter name) . args) body ...)
2004 (when (or (not (defined? 'name))
2005 (not (is-a? name <accessor>)))
2006 (toplevel-define! 'name
2008 (if (defined? 'name) name #f) 'name)))
2009 (add-method! (setter name) (method args body ...))))
2010 ((_ (name . args) body ...)
2012 ;; FIXME: this code is how it always was, but it's quite cracky:
2013 ;; it will only define the generic function if it was undefined
2014 ;; before (ok), or *was defined to #f*. The latter is crack. But
2015 ;; there are bootstrap issues about fixing this -- change it to
2016 ;; (is-a? name <generic>) and see.
2017 (when (or (not (defined? 'name))
2019 (toplevel-define! 'name (make <generic> #:name 'name)))
2020 (add-method! name (method args body ...))))))
2022 (define-syntax method
2024 (define (parse-args args)
2025 (let lp ((ls args) (formals '()) (specializers '()))
2028 (and (identifier? #'f) (identifier? #'s))
2031 (cons #'s specializers)))
2036 (cons #'<top> specializers)))
2038 (list (reverse formals)
2039 (reverse (cons #''() specializers))))
2041 (identifier? #'tail)
2042 (list (append (reverse formals) #'tail)
2043 (reverse (cons #'<top> specializers)))))))
2045 (define (find-free-id exp referent)
2048 (or (find-free-id #'x referent)
2049 (find-free-id #'y referent)))
2052 (let ((id (datum->syntax #'x referent)))
2053 (and (free-identifier=? #'x id) id)))
2056 (define (compute-procedure formals body)
2057 (syntax-case body ()
2059 (with-syntax ((formals formals))
2060 #'(lambda formals body0 ...)))))
2062 (define (->proper args)
2063 (let lp ((ls args) (out '()))
2065 ((x . xs) (lp #'xs (cons #'x out)))
2067 (tail (reverse (cons #'tail out))))))
2069 (define (compute-make-procedure formals body next-method)
2070 (syntax-case body ()
2072 (with-syntax ((next-method next-method))
2073 (syntax-case formals ()
2075 #'(lambda (real-next-method)
2076 (lambda (formal ...)
2077 (let ((next-method (lambda args
2079 (real-next-method formal ...)
2080 (apply real-next-method args)))))
2083 (with-syntax (((formal ...) (->proper #'formals)))
2084 #'(lambda (real-next-method)
2086 (let ((next-method (lambda args
2088 (apply real-next-method formal ...)
2089 (apply real-next-method args)))))
2092 (define (compute-procedures formals body)
2093 ;; So, our use of this is broken, because it operates on the
2094 ;; pre-expansion source code. It's equivalent to just searching
2095 ;; for referent in the datums. Ah well.
2096 (let ((id (find-free-id body 'next-method)))
2098 ;; return a make-procedure
2100 (compute-make-procedure formals body id))
2101 (values (compute-procedure formals body)
2105 ((_ args) #'(method args (if #f #f)))
2106 ((_ args body0 body1 ...)
2107 (with-syntax (((formals (specializer ...)) (parse-args #'args)))
2110 (compute-procedures #'formals #'(body0 body1 ...)))
2111 (lambda (procedure make-procedure)
2112 (with-syntax ((procedure procedure)
2113 (make-procedure make-procedure))
2115 #:specializers (cons* specializer ...)
2117 #:body '(body0 body1 ...)
2118 #:make-procedure make-procedure
2119 #:procedure procedure)))))))))
2124 ;;; These are useful when dealing with method specializers, which might
2125 ;;; have a rest argument.
2128 (define (map* fn . l) ; A map which accepts dotted lists (arg lists
2129 (cond ; must be "isomorph"
2130 ((null? (car l)) '())
2131 ((pair? (car l)) (cons (apply fn (map car l))
2132 (apply map* fn (map cdr l))))
2133 (else (apply fn l))))
2135 (define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
2136 (cond ; must be "isomorph"
2137 ((null? (car l)) '())
2138 ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
2139 (else (apply fn l))))
2141 (define (length* ls)
2144 ((not (pair? ls)) n)))
2150 (define (add-method-in-classes! m)
2151 ;; Add method in all the classes which appears in its specializers list
2152 (for-each* (lambda (x)
2153 (let ((dm (class-direct-methods x)))
2155 (struct-set! x class-index-direct-methods (cons m dm)))))
2156 (method-specializers m)))
2158 (define (remove-method-in-classes! m)
2159 ;; Remove method in all the classes which appears in its specializers list
2160 (for-each* (lambda (x)
2162 class-index-direct-methods
2163 (delv! m (class-direct-methods x))))
2164 (method-specializers m)))
2166 (define (compute-new-list-of-methods gf new)
2167 (let ((new-spec (method-specializers new))
2168 (methods (slot-ref gf 'methods)))
2169 (let loop ((l methods))
2172 (if (equal? (method-specializers (car l)) new-spec)
2174 ;; This spec. list already exists. Remove old method from dependents
2175 (remove-method-in-classes! (car l))
2180 (define (method-n-specializers m)
2181 (length* (slot-ref m 'specializers)))
2183 (define (calculate-n-specialized gf)
2184 (fold (lambda (m n) (max n (method-n-specializers m)))
2186 (generic-function-methods gf)))
2188 (define (invalidate-method-cache! gf)
2189 (slot-set! gf 'n-specialized (calculate-n-specialized gf))
2190 (%invalidate-method-cache! gf)
2191 (for-each (lambda (gf) (invalidate-method-cache! gf))
2192 (slot-ref gf 'extended-by)))
2194 (define internal-add-method!
2195 (method ((gf <generic>) (m <method>))
2196 (slot-set! m 'generic-function gf)
2197 (slot-set! gf 'methods (compute-new-list-of-methods gf m))
2198 (invalidate-method-cache! gf)
2199 (add-method-in-classes! m)
2202 (define-generic add-method!)
2204 ((method-procedure internal-add-method!) add-method! internal-add-method!)
2206 (define-method (add-method! (proc <procedure>) (m <method>))
2207 (if (generic-capability? proc)
2209 (enable-primitive-generic! proc)
2210 (add-method! proc m))
2213 (define-method (add-method! (pg <primitive-generic>) (m <method>))
2214 (add-method! (primitive-generic-generic pg) m))
2216 (define-method (add-method! obj (m <method>))
2217 (goops-error "~S is not a valid generic function" obj))
2220 ;;; {Access to meta objects}
2226 (define-method (method-source (m <method>))
2227 (let* ((spec (map* class-name (slot-ref m 'specializers)))
2228 (src (procedure-source (slot-ref m 'procedure))))
2230 (let ((args (cadr src))
2233 (cons (map* list args spec)
2236 (define-method (method-formals (m <method>))
2237 (slot-ref m 'formals))
2242 (define (slot-init-function class slot-name)
2243 (%slot-definition-init-thunk (or (class-slot-definition class slot-name)
2244 (error "slot not found" slot-name))))
2246 (define (accessor-method-slot-definition obj)
2247 "Return the slot definition of the accessor @var{obj}."
2248 (slot-ref obj 'slot-definition))
2252 ;;; {Standard methods used by the C runtime}
2255 ;;; Methods to compare objects
2258 ;; Have to do this in a strange order because equal? is used in the
2259 ;; add-method! implementation; we need to make sure that when the
2260 ;; primitive is extended, that the generic has a method. =
2261 (define g-equal? (make-generic 'equal?))
2262 ;; When this generic gets called, we will have already checked eq? and
2263 ;; eqv? -- the purpose of this generic is to extend equality. So by
2264 ;; default, there is no extension, thus the #f return.
2265 (add-method! g-equal? (method (x y) #f))
2266 (set-primitive-generic! equal? g-equal?)
2269 ;;; methods to display/write an object
2272 ; Code for writing objects must test that the slots they use are
2273 ; bound. Otherwise a slot-unbound method will be called and will
2274 ; conduct to an infinite loop.
2277 (define (display-address o file)
2278 (display (number->string (object-address o) 16) file))
2280 (define-method (write o file)
2281 (display "#<instance " file)
2282 (display-address o file)
2285 (define write-object (primitive-generic-generic write))
2287 (define-method (write (o <object>) file)
2288 (let ((class (class-of o)))
2289 (if (slot-bound? class 'name)
2292 (display (class-name class) file)
2293 (display #\space file)
2294 (display-address o file)
2298 (define-method (write (slot <slot>) file)
2299 (let ((class (class-of slot)))
2300 (if (and (slot-bound? class 'name)
2301 (slot-bound? slot 'name))
2304 (display (class-name class) file)
2305 (display #\space file)
2306 (display (%slot-definition-name slot) file)
2307 (display #\space file)
2308 (display-address slot file)
2312 (define-method (write (class <class>) file)
2313 (let ((meta (class-of class)))
2314 (if (and (slot-bound? class 'name)
2315 (slot-bound? meta 'name))
2318 (display (class-name meta) file)
2319 (display #\space file)
2320 (display (class-name class) file)
2321 (display #\space file)
2322 (display-address class file)
2326 (define-method (write (gf <generic>) file)
2327 (let ((meta (class-of gf)))
2328 (if (and (slot-bound? meta 'name)
2329 (slot-bound? gf 'methods))
2332 (display (class-name meta) file)
2333 (let ((name (generic-function-name gf)))
2336 (display #\space file)
2337 (display name file))))
2339 (display (length (generic-function-methods gf)) file)
2340 (display ")>" file))
2343 (define-method (write (o <method>) file)
2344 (let ((meta (class-of o)))
2345 (if (and (slot-bound? meta 'name)
2346 (slot-bound? o 'specializers))
2349 (display (class-name meta) file)
2350 (display #\space file)
2351 (display (map* (lambda (spec)
2352 (if (slot-bound? spec 'name)
2353 (slot-ref spec 'name)
2355 (method-specializers o))
2357 (display #\space file)
2358 (display-address o file)
2362 ;; Display (do the same thing as write by default)
2363 (define-method (display o file)
2364 (write-object o file))
2367 ;;; Handling of duplicate bindings in the module system
2370 (define (find-subclass super name)
2371 (let lp ((classes (class-direct-subclasses super)))
2374 (error "class not found" name))
2375 ((and (slot-bound? (car classes) 'name)
2376 (eq? (class-name (car classes)) name))
2379 (lp (cdr classes))))))
2382 (define <module> (find-subclass <top> '<module>))
2384 (define-method (merge-generics (module <module>)
2394 (define-method (merge-generics (module <module>)
2402 (and (not (eq? val1 val2))
2403 (make-variable (make-extended-generic (list val2 val1) name))))
2405 (define-method (merge-generics (module <module>)
2412 (gf <extended-generic>))
2413 (and (not (memq val2 (slot-ref gf 'extends)))
2417 (cons val2 (delq! val2 (slot-ref gf 'extends))))
2420 (cons gf (delq! gf (slot-ref val2 'extended-by))))
2421 (invalidate-method-cache! gf)
2424 (module-define! duplicate-handlers 'merge-generics merge-generics)
2426 (define-method (merge-accessors (module <module>)
2436 (define-method (merge-accessors (module <module>)
2444 (merge-generics module name int1 val1 int2 val2 var val))
2446 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
2452 (define (class-slot-ref class slot-name)
2453 (let ((slot (class-slot-definition class slot-name)))
2454 (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
2455 (slot-missing class slot-name))
2456 (let ((x ((%slot-definition-slot-ref/raw slot) #f)))
2458 (slot-unbound class slot-name)
2461 (define (class-slot-set! class slot-name value)
2462 (let ((slot (class-slot-definition class slot-name)))
2463 (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
2464 (slot-missing class slot-name))
2465 ((%slot-definition-slot-set! slot) #f value)))
2467 (define-method (slot-unbound (c <class>) (o <object>) s)
2468 (goops-error "Slot `~S' is unbound in object ~S" s o))
2470 (define-method (slot-unbound (c <class>) s)
2471 (goops-error "Slot `~S' is unbound in class ~S" s c))
2473 (define-method (slot-unbound (o <object>))
2474 (goops-error "Unbound slot in object ~S" o))
2476 (define-method (slot-missing (c <class>) (o <object>) s)
2477 (goops-error "No slot with name `~S' in object ~S" s o))
2479 (define-method (slot-missing (c <class>) s)
2480 (goops-error "No class slot with name `~S' in class ~S" s c))
2483 (define-method (slot-missing (c <class>) (o <object>) s value)
2484 (slot-missing c o s))
2486 ;;; Methods for the possible error we can encounter when calling a gf
2488 (define-method (no-next-method (gf <generic>) args)
2489 (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
2491 (define-method (no-applicable-method (gf <generic>) args)
2492 (goops-error "No applicable method for ~S in call ~S"
2493 gf (cons (generic-function-name gf) args)))
2495 (define-method (no-method (gf <generic>) args)
2496 (goops-error "No method defined for ~S" gf))
2499 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
2502 (define-method (shallow-clone (self <object>))
2503 (let* ((class (class-of self))
2504 (clone (%allocate-instance class))
2505 (slots (map slot-definition-name (class-slots class))))
2506 (for-each (lambda (slot)
2507 (when (slot-bound? self slot)
2508 (slot-set! clone slot (slot-ref self slot))))
2512 (define-method (deep-clone (self <object>))
2513 (let* ((class (class-of self))
2514 (clone (%allocate-instance class))
2515 (slots (map slot-definition-name (class-slots class))))
2516 (for-each (lambda (slot)
2517 (when (slot-bound? self slot)
2518 (slot-set! clone slot
2519 (let ((value (slot-ref self slot)))
2520 (if (instance? value)
2527 ;;; {Class redefinition utilities}
2530 ;;; (class-redefinition OLD NEW)
2533 ;;; Has correct the following conditions:
2537 ;;; 1. New accessor specializers refer to new header
2541 ;;; 1. New class cpl refers to the new class header
2542 ;;; 2. Old class header exists on old super classes direct-subclass lists
2543 ;;; 3. New class header exists on new super classes direct-subclass lists
2545 (define-method (class-redefinition (old <class>) (new <class>))
2546 ;; Work on direct methods:
2547 ;; 1. Remove accessor methods from the old class
2548 ;; 2. Patch the occurences of new in the specializers by old
2549 ;; 3. Displace the methods from old to new
2550 (remove-class-accessors! old) ;; -1-
2551 (let ((methods (class-direct-methods new)))
2552 (for-each (lambda (m)
2553 (update-direct-method! m new old)) ;; -2-
2556 class-index-direct-methods
2557 (append methods (class-direct-methods old))))
2559 ;; Substitute old for new in new cpl
2560 (set-car! (struct-ref new class-index-cpl) old)
2562 ;; Remove the old class from the direct-subclasses list of its super classes
2563 (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
2564 (delv! old (class-direct-subclasses c))))
2565 (class-direct-supers old))
2567 ;; Replace the new class with the old in the direct-subclasses of the supers
2568 (for-each (lambda (c)
2569 (struct-set! c class-index-direct-subclasses
2570 (cons old (delv! new (class-direct-subclasses c)))))
2571 (class-direct-supers new))
2573 ;; Swap object headers
2574 (%modify-class old new)
2578 ;; Redefine all the subclasses of old to take into account modification
2581 (update-direct-subclass! c new old))
2582 (class-direct-subclasses new))
2584 ;; Invalidate class so that subsequent instances slot accesses invoke
2585 ;; change-object-class
2586 (struct-set! new class-index-redefined old)
2587 (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set!
2592 ;;; remove-class-accessors!
2595 (define-method (remove-class-accessors! (c <class>))
2596 (for-each (lambda (m)
2597 (when (is-a? m <accessor-method>)
2598 (let ((gf (slot-ref m 'generic-function)))
2599 ;; remove the method from its GF
2600 (slot-set! gf 'methods
2601 (delq1! m (slot-ref gf 'methods)))
2602 (invalidate-method-cache! gf)
2603 ;; remove the method from its specializers
2604 (remove-method-in-classes! m))))
2605 (class-direct-methods c)))
2608 ;;; update-direct-method!
2611 (define-method (update-direct-method! (m <method>)
2614 (let loop ((l (method-specializers m)))
2615 ;; Note: the <top> in dotted list is never used.
2616 ;; So we can work as if we had only proper lists.
2618 (when (eqv? (car l) old)
2623 ;;; update-direct-subclass!
2626 (define-method (update-direct-subclass! (c <class>)
2629 (class-redefinition c
2630 (make-class (class-direct-supers c)
2631 (class-direct-slots c)
2632 #:name (class-name c)
2633 #:metaclass (class-of c))))
2636 ;;; {Utilities for INITIALIZE methods}
2639 ;;; compute-slot-accessors
2641 (define (compute-slot-accessors class slots)
2644 (let ((getter (%slot-definition-getter slot))
2645 (setter (%slot-definition-setter slot))
2646 (accessor-setter setter)
2647 (accessor (%slot-definition-accessor slot)))
2649 (add-method! getter (compute-getter-method class slot)))
2651 (add-method! setter (compute-setter-method class slot)))
2653 (add-method! accessor (compute-getter-method class slot))
2654 (add-method! (accessor-setter accessor)
2655 (compute-setter-method class slot)))))
2658 (define-method (compute-getter-method (class <class>) slot)
2659 (let ((name (slot-definition-name slot)))
2660 (make <accessor-method>
2661 #:specializers (list class)
2662 #:procedure (lambda (o) (slot-ref o name))
2663 #:slot-definition slot)))
2665 (define-method (compute-setter-method (class <class>) slot)
2666 (let ((name (slot-definition-name slot)))
2667 (make <accessor-method>
2668 #:specializers (list class <top>)
2669 #:procedure (lambda (o v) (slot-set! o name v))
2670 #:slot-definition slot)))
2672 (define (make-generic-bound-check-getter proc)
2674 (let ((val (proc o)))
2682 ;; Replace the bootstrap compute-cpl with this definition.
2684 (make <generic> #:name 'compute-cpl))
2686 (define-method (compute-cpl (class <class>))
2687 (compute-std-cpl class class-direct-supers))
2689 ;;; compute-get-n-set
2691 (define compute-get-n-set
2692 (make <generic> #:name 'compute-get-n-set))
2694 (define-method (compute-get-n-set (class <class>) s)
2695 (define (class-slot-init-value)
2696 (let ((thunk (slot-definition-init-thunk s)))
2699 (slot-definition-init-value s))))
2701 (define (make-closure-variable class value)
2702 (list (lambda (o) value)
2703 (lambda (o v) (set! value v))))
2705 (case (slot-definition-allocation s)
2706 ((#:instance) ;; Instance slot
2707 ;; get-n-set is just its offset
2708 (let ((already-allocated (struct-ref class class-index-nfields)))
2709 (struct-set! class class-index-nfields (+ already-allocated 1))
2712 ((#:class) ;; Class slot
2713 ;; Class-slots accessors are implemented as 2 closures around
2714 ;; a Scheme variable. As instance slots, class slots must be
2715 ;; unbound at init time.
2716 (let ((name (slot-definition-name s)))
2717 (if (memq name (map slot-definition-name (class-direct-slots class)))
2718 ;; This slot is direct; create a new shared variable
2719 (make-closure-variable class (class-slot-init-value))
2720 ;; Slot is inherited. Find its definition in superclass
2721 (let lp ((cpl (cdr (class-precedence-list class))))
2724 (let ((s (class-slot-definition super name)))
2726 (list (slot-definition-slot-ref s)
2727 (slot-definition-slot-set! s))
2728 ;; Multiple inheritance means that we might have
2729 ;; to look deeper in the CPL.
2732 ((#:each-subclass) ;; slot shared by instances of direct subclass.
2733 ;; (Thomas Buerger, April 1998)
2734 (make-closure-variable class (class-slot-init-value)))
2736 ((#:virtual) ;; No allocation
2737 ;; slot-ref and slot-set! function must be given by the user
2738 (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
2739 (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
2740 (unless (and get set)
2741 (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" s))
2743 (else (next-method))))
2745 (define-method (compute-get-n-set (o <object>) s)
2746 (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
2748 (define-method (compute-slots (class <class>))
2749 (build-slots-list (class-direct-slots class)
2750 (class-precedence-list class)))
2756 ;; FIXME: This could be much more efficient.
2757 (define (%initialize-object obj initargs)
2758 "Initialize the object @var{obj} with the given arguments
2760 (define (valid-initargs? initargs)
2763 (((? keyword?) _ . initargs) (valid-initargs? initargs))
2765 (unless (instance? obj)
2766 (scm-error 'wrong-type-arg #f "Not an object: ~S"
2768 (unless (valid-initargs? initargs)
2769 (scm-error 'wrong-type-arg #f "Invalid initargs: ~S"
2770 (list initargs) #f))
2771 (let ((class (class-of obj)))
2772 (define (get-initarg kw)
2774 ;; Inlined get-keyword to avoid checking initargs for validity
2776 (let lp ((initargs initargs))
2778 ((kw* val . initargs)
2784 (let lp ((slots (struct-ref class class-index-slots)))
2788 (define (initialize-slot! value)
2789 ((%slot-definition-slot-set! slot) obj value))
2790 (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
2792 ((not (unbound? initarg))
2793 (initialize-slot! initarg))
2794 ((%slot-definition-init-thunk slot)
2795 => (lambda (init-thunk)
2796 (unless (memq (slot-definition-allocation slot)
2797 '(#:class #:each-subclass))
2798 (initialize-slot! (init-thunk)))))))
2801 (define-method (initialize (object <object>) initargs)
2802 (%initialize-object object initargs))
2804 (define-method (initialize (slot <slot>) initargs)
2806 (struct-set! slot slot-index-options initargs)
2807 (let ((init-thunk (%slot-definition-init-thunk slot)))
2809 (unless (thunk? init-thunk)
2810 (goops-error "Bad init-thunk for slot `~S': ~S"
2811 (%slot-definition-name slot) init-thunk)))))
2813 (define-method (initialize (class <class>) initargs)
2814 (define (make-direct-slot-definition dslot)
2815 (let ((initargs (compute-direct-slot-definition-initargs class dslot)))
2816 (compute-direct-slot-definition class initargs)))
2819 (class-add-flags! class (logior vtable-flag-goops-class
2820 vtable-flag-goops-valid))
2821 (struct-set! class class-index-name (get-keyword #:name initargs '???))
2822 (struct-set! class class-index-nfields 0)
2823 (struct-set! class class-index-direct-supers
2824 (get-keyword #:dsupers initargs '()))
2825 (struct-set! class class-index-direct-subclasses '())
2826 (struct-set! class class-index-direct-methods '())
2827 (struct-set! class class-index-redefined #f)
2828 (struct-set! class class-index-cpl (compute-cpl class))
2829 (struct-set! class class-index-direct-slots
2833 (make-direct-slot-definition slot)))
2834 (get-keyword #:slots initargs '())))
2835 (struct-set! class class-index-slots
2836 (allocate-slots class (compute-slots class)))
2839 (when (memq <slot> (struct-ref class class-index-cpl))
2840 (class-add-flags! class vtable-flag-goops-slot))
2842 ;; Build getters - setters - accessors
2843 (compute-slot-accessors class (struct-ref class class-index-slots))
2845 ;; Update the "direct-subclasses" of each inherited classes
2846 (for-each (lambda (x)
2847 (let ((dsubs (struct-ref x class-index-direct-subclasses)))
2848 (struct-set! x class-index-direct-subclasses
2849 (cons class dsubs))))
2850 (struct-ref class class-index-direct-supers))
2852 ;; Compute struct layout of instances, set the `layout' slot, and
2853 ;; update class flags.
2854 (%prep-layout! class))
2856 (define (initialize-object-procedure object initargs)
2857 (let ((proc (get-keyword #:procedure initargs #f)))
2860 (apply slot-set! object 'procedure proc))
2862 (slot-set! object 'procedure proc)))))
2864 (define-method (initialize (applicable-struct <applicable-struct>) initargs)
2866 (initialize-object-procedure applicable-struct initargs))
2868 (define-method (initialize (applicable-struct <applicable-struct-with-setter>)
2871 (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f)))
2873 (define-method (initialize (generic <generic>) initargs)
2874 (let ((previous-definition (get-keyword #:default initargs #f))
2875 (name (get-keyword #:name initargs #f)))
2877 (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
2879 (apply previous-definition args)))
2882 (set-procedure-property! generic 'name name))
2883 (invalidate-method-cache! generic)))
2885 (define-method (initialize (eg <extended-generic>) initargs)
2887 (slot-set! eg 'extends (get-keyword #:extends initargs '())))
2889 (define dummy-procedure (lambda args *unspecified*))
2891 (define-method (initialize (method <method>) initargs)
2893 (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
2894 (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
2895 (slot-set! method 'procedure
2896 (get-keyword #:procedure initargs #f))
2897 (slot-set! method 'formals (get-keyword #:formals initargs '()))
2898 (slot-set! method 'body (get-keyword #:body initargs '()))
2899 (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
2906 (define (change-object-class old-instance old-class new-class)
2907 (let ((new-instance (allocate-instance new-class '())))
2908 ;; Initialize the slots of the new instance
2911 (if (and (slot-exists? old-instance slot)
2912 (eq? (%slot-definition-allocation
2913 (class-slot-definition old-class slot))
2915 (slot-bound? old-instance slot))
2916 ;; Slot was present and allocated in old instance; copy it
2917 (slot-set! new-instance slot (slot-ref old-instance slot))
2918 ;; slot was absent; initialize it with its default value
2919 (let ((init (slot-init-function new-class slot)))
2921 (slot-set! new-instance slot (init))))))
2922 (map slot-definition-name (class-slots new-class)))
2923 ;; Exchange old and new instance in place to keep pointers valid
2924 (%modify-instance old-instance new-instance)
2925 ;; Allow class specific updates of instances (which now are swapped)
2926 (update-instance-for-different-class new-instance old-instance)
2930 (define-method (update-instance-for-different-class (old-instance <object>)
2933 ;;not really important what we do, we just need a default method
2936 (define-method (change-class (old-instance <object>) (new-class <class>))
2937 (change-object-class old-instance (class-of old-instance) new-class))
2942 ;;; A new definition which overwrites the previous one which was built-in
2945 (define-method (allocate-instance (class <class>) initargs)
2946 (%allocate-instance class))
2948 (define-method (make-instance (class <class>) . initargs)
2949 (let ((instance (allocate-instance class initargs)))
2950 (initialize instance initargs)
2953 (define make make-instance)
2958 ;;; Protocol for calling generic functions, intended to be used when
2959 ;;; applying subclasses of <generic> and <generic-with-setter>. The
2960 ;;; code below is similar to the first MOP described in AMOP.
2962 ;;; Note that standard generic functions dispatch only on the classes of
2963 ;;; the arguments, and the result of such dispatch can be memoized. The
2964 ;;; `dispatch-generic-function-application-from-cache' routine
2965 ;;; implements this. `apply-generic' isn't called currently; the
2966 ;;; generic function MOP was never fully implemented in GOOPS. However
2967 ;;; now that GOOPS is implemented entirely in Scheme (2015) it's much
2968 ;;; easier to complete this work. Contributions gladly accepted!
2969 ;;; Please read the AMOP first though :)
2971 ;;; The protocol is:
2973 ;;; + apply-generic (gf args)
2974 ;;; + compute-applicable-methods (gf args ...)
2975 ;;; + sort-applicable-methods (gf methods args)
2976 ;;; + apply-methods (gf methods args)
2978 ;;; apply-methods calls make-next-method to build the "continuation" of
2979 ;;; a method. Applying a next-method will call apply-next-method which
2980 ;;; in turn will call apply again to call effectively the following
2981 ;;; method. (This paragraph is out of date but is kept so that maybe it
2982 ;;; illuminates some future hack.)
2985 (define-method (apply-generic (gf <generic>) args)
2986 (when (null? (slot-ref gf 'methods))
2987 (no-method gf args))
2988 (let ((methods (compute-applicable-methods gf args)))
2990 (apply-methods gf (sort-applicable-methods gf methods args) args)
2991 (no-applicable-method gf args))))
2993 ;; compute-applicable-methods is bound to %compute-applicable-methods.
2994 (define compute-applicable-methods
2995 (let ((gf (make <generic> #:name 'compute-applicable-methods)))
2996 (add-method! gf (method ((gf <generic>) args)
2997 (%compute-applicable-methods gf args)))
3000 (define-method (sort-applicable-methods (gf <generic>) methods args)
3001 (%sort-applicable-methods methods (map class-of args)))
3003 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
3004 (%method-more-specific? m1 m2 targs))
3006 (define compute-effective-method
3007 (let ((gf (make <generic> #:name 'compute-effective-method)))
3008 (add-method! gf (method ((gf <generic>) methods typev)
3009 (%compute-effective-method gf methods typev)))
3012 (define compute-specialized-effective-method
3013 (let ((gf (make <generic> #:name 'compute-specialized-effective-method)))
3016 (method ((gf <generic>) (method <method>) typev next)
3017 (%compute-specialized-effective-method gf method typev next)))
3020 (define-method (compute-specialized-effective-method (gf <generic>)
3021 (m <accessor-method>)
3024 (let ((name (slot-definition-name (accessor-method-slot-definition m))))
3027 (slot-definition-slot-ref (class-slot-definition class name)))
3029 (slot-definition-slot-set! (class-slot-definition class name)))
3033 (define-method (apply-method (gf <generic>) methods build-next args)
3034 (apply (method-procedure (car methods))
3035 (build-next (cdr methods) args)
3038 (define-method (apply-methods (gf <generic>) (l <list>) args)
3039 (letrec ((next (lambda (procs args)
3041 (let ((a (if (null? new-args) args new-args)))
3043 (no-next-method gf a)
3044 (apply-method gf procs next a)))))))
3045 (apply-method gf l next args)))
3047 ;; We don't want the following procedure to turn up in backtraces:
3048 (for-each (lambda (proc)
3049 (set-procedure-property! proc 'system-procedure #t))
3053 no-applicable-method
3058 ;;; {Final initialization}
3061 ;; Tell C code that the main bulk of Goops has been loaded
3068 ;;; {SMOB and port classes}
3071 (define <arbiter> (find-subclass <top> '<arbiter>))
3072 (define <promise> (find-subclass <top> '<promise>))
3073 (define <thread> (find-subclass <top> '<thread>))
3074 (define <mutex> (find-subclass <top> '<mutex>))
3075 (define <condition-variable> (find-subclass <top> '<condition-variable>))
3076 (define <regexp> (find-subclass <top> '<regexp>))
3077 (define <hook> (find-subclass <top> '<hook>))
3078 (define <bitvector> (find-subclass <top> '<bitvector>))
3079 (define <random-state> (find-subclass <top> '<random-state>))
3080 (define <async> (find-subclass <top> '<async>))
3081 (define <directory> (find-subclass <top> '<directory>))
3082 (define <array> (find-subclass <top> '<array>))
3083 (define <character-set> (find-subclass <top> '<character-set>))
3084 (define <dynamic-object> (find-subclass <top> '<dynamic-object>))
3085 (define <guardian> (find-subclass <applicable> '<guardian>))
3086 (define <macro> (find-subclass <top> '<macro>))
3088 (define (define-class-subtree class)
3089 (define! (class-name class) class)
3090 (for-each define-class-subtree (class-direct-subclasses class)))
3092 (define-class-subtree (find-subclass <port> '<file-port>))