3 ;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
4 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 ;;;; This file was based upon stklos.stk from the STk distribution
24 ;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
27 (define-module (oop goops)
28 #:use-module (srfi srfi-1)
29 #:use-module (ice-9 match)
30 #:use-module (system base target)
31 #:use-module ((language tree-il primitives)
32 :select (add-interesting-primitive!))
33 #:export-syntax (define-class class standard-define-class
34 define-generic define-accessor define-method
35 define-extended-generic define-extended-generics
37 #: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)
140 ;;; Booting GOOPS is a tortuous process. We begin by loading a small
141 ;;; set of primitives from C.
143 (eval-when (expand load eval)
144 (load-extension (string-append "libguile-" (effective-version))
145 "scm_init_goops_builtins")
146 (add-interesting-primitive! 'class-of))
152 ;;; We then define the slots that must appear in all classes (<class>
153 ;;; objects) and slot definitions (<slot> objects). These slots must
154 ;;; appear in order. We'll use this list to statically compute offsets
155 ;;; for the various fields, to compute the struct layout for <class>
156 ;;; instances, and to compute the slot definition lists for <class>.
157 ;;; Because the list is needed at expansion-time, we define it as a
160 (define-syntax macro-fold-left
162 ((_ folder seed ()) seed)
163 ((_ folder seed (head . tail))
164 (macro-fold-left folder (folder head seed) tail))))
166 (define-syntax macro-fold-right
168 ((_ folder seed ()) seed)
169 ((_ folder seed (head . tail))
170 (folder head (macro-fold-right folder seed tail)))))
172 (define-syntax-rule (define-macro-folder macro-folder value ...)
173 (define-syntax macro-folder
177 ;; The datum->syntax makes it as if each `value' were present
178 ;; in the initial form, which allows them to be used as
179 ;; (components of) introduced identifiers.
180 #`(fold visit seed #,(datum->syntax #'visit '(value ...))))))))
182 (define-macro-folder fold-class-slots
183 (layout <protected-read-only-slot>)
184 (flags <hidden-slot>)
186 (instance-finalizer <hidden-slot>)
188 (name <protected-hidden-slot>)
189 (nfields <hidden-slot>)
190 (%reserved <hidden-slot>)
200 (define-macro-folder fold-slot-slots
201 (name #:init-keyword #:name)
202 (allocation #:init-keyword #:allocation #:init-value #:instance)
203 (init-form #:init-keyword #:init-form)
204 (init-thunk #:init-keyword #:init-thunk #:init-value #f)
206 (getter #:init-keyword #:getter)
207 (setter #:init-keyword #:setter)
208 (index #:init-keyword #:index)
209 (size #:init-keyword #:size))
212 ;;; Statically define variables for slot offsets: `class-index-layout'
213 ;;; will be 0, `class-index-flags' will be 1, and so on, and the same
214 ;;; for `slot-index-name' and such for <slot>.
216 (let-syntax ((define-slot-indexer
218 ((_ define-index prefix)
219 (define-syntax define-index
221 (define (id-append ctx a b)
222 (datum->syntax ctx (symbol-append (syntax->datum a)
224 (define (tail-length tail)
227 ((visit head tail) (1+ (tail-length #'tail)))))
231 (define-syntax #,(id-append #'name #'prefix #'name)
232 (identifier-syntax #,(tail-length #'tail)))
234 (define-slot-indexer define-class-index class-index-)
235 (define-slot-indexer define-slot-index slot-index-)
236 (fold-class-slots macro-fold-left define-class-index (begin))
237 (fold-slot-slots macro-fold-left define-slot-index (begin)))
240 ;;; Structs that are vtables have a "flags" slot, which corresponds to
241 ;;; class-index-flags. `vtable-flag-vtable' indicates that instances of
242 ;;; a vtable are themselves vtables, and `vtable-flag-validated'
243 ;;; indicates that the struct's layout has been validated. goops.c
244 ;;; defines a couple of additional flags: one to indicate that a vtable
245 ;;; is actually a class, and one to indicate that the class is "valid",
246 ;;; meaning that it hasn't been redefined.
248 (define vtable-flag-goops-metaclass
249 (logior vtable-flag-vtable vtable-flag-goops-class))
251 (define-inlinable (class-add-flags! class flags)
252 (struct-set! class class-index-flags
253 (logior flags (struct-ref class class-index-flags))))
255 (define-inlinable (class-clear-flags! class flags)
256 (struct-set! class class-index-flags
257 (logand (lognot flags) (struct-ref class class-index-flags))))
259 (define-inlinable (class-has-flags? class flags)
261 (logand (struct-ref class class-index-flags) flags)))
263 (define-inlinable (class? obj)
264 (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
266 (define-inlinable (instance? obj)
267 (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
270 ;;; Now that we know the slots that must be present in classes, and
271 ;;; their offsets, we can create the root of the class hierarchy.
273 ;;; Note that the `direct-supers', `direct-slots', `cpl', `slots', and
274 ;;; `getters-n-setters' fields will be updated later, once we have
275 ;;; definitions for the specialized slot types like <read-only-slot> and
276 ;;; once we have definitions for <top> and <object>.
279 (let-syntax ((cons-layout
280 ;; A simple way to compute class layout for the concrete
281 ;; types used in <class>.
282 (syntax-rules (<protected-read-only-slot>
285 <protected-hidden-slot>)
287 (string-append "pw" tail))
288 ((_ (name <protected-read-only-slot>) tail)
289 (string-append "pr" tail))
290 ((_ (name <self-slot>) tail)
291 (string-append "sr" tail))
292 ((_ (name <hidden-slot>) tail)
293 (string-append "uh" tail))
294 ((_ (name <protected-hidden-slot>) tail)
295 (string-append "ph" tail))))
298 ((_ (name) tail) (cons (list 'name) tail))
299 ((_ (name class) tail) (cons (list 'name) tail)))))
300 (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
301 (slots (fold-class-slots macro-fold-right cons-slot '()))
302 (<class> (%make-vtable-vtable layout)))
303 (class-add-flags! <class> (logior vtable-flag-goops-class
304 vtable-flag-goops-valid))
305 (struct-set! <class> class-index-name '<class>)
306 (struct-set! <class> class-index-nfields (length slots))
307 (struct-set! <class> class-index-direct-supers '())
308 (struct-set! <class> class-index-direct-slots slots)
309 (struct-set! <class> class-index-direct-subclasses '())
310 (struct-set! <class> class-index-direct-methods '())
311 (struct-set! <class> class-index-cpl '())
312 (struct-set! <class> class-index-slots slots)
313 (struct-set! <class> class-index-getters-n-setters '())
314 (struct-set! <class> class-index-redefined #f)
318 ;;; Accessors to fields of <class>.
320 (define-syntax-rule (define-class-accessor name docstring field)
325 (scm-error 'wrong-type-arg #f "Not a class: ~S"
327 (struct-ref val field))))
329 (define-class-accessor class-name
330 "Return the class name of @var{obj}."
332 (define-class-accessor class-direct-supers
333 "Return the direct superclasses of the class @var{obj}."
334 class-index-direct-supers)
335 (define-class-accessor class-direct-slots
336 "Return the direct slots of the class @var{obj}."
337 class-index-direct-slots)
338 (define-class-accessor class-direct-subclasses
339 "Return the direct subclasses of the class @var{obj}."
340 class-index-direct-subclasses)
341 (define-class-accessor class-direct-methods
342 "Return the direct methods of the class @var{obj}."
343 class-index-direct-methods)
344 (define-class-accessor class-precedence-list
345 "Return the class precedence list of the class @var{obj}."
347 (define-class-accessor class-slots
348 "Return the slot list of the class @var{obj}."
351 (define (class-subclasses c)
352 "Compute a list of all subclasses of @var{c}, direct and indirect."
353 (define (all-subclasses c)
354 (cons c (append-map all-subclasses
355 (class-direct-subclasses c))))
356 (delete-duplicates (cdr (all-subclasses c)) eq?))
358 (define (class-methods c)
359 "Compute a list of all methods that specialize on @var{c} or
360 subclasses of @var{c}."
361 (delete-duplicates (append-map class-direct-methods
362 (cons c (class-subclasses c)))
369 ;;; The "getters-n-setters" define how to access slot values for a
370 ;;; particular class. In general, there are many ways to access slot
371 ;;; values, but for standard classes it's pretty easy: each slot is
372 ;;; associated with a field in the object.
374 (define (%compute-getters-n-setters slots)
375 (define (compute-init-thunk options)
377 ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val)))
378 ((kw-arg-ref options #:init-thunk))
380 (let lp ((slots slots) (n 0))
383 (((name . options) . slots)
384 (let ((init-thunk (compute-init-thunk options)))
385 (cons `(,name ,init-thunk . ,n)
386 (lp slots (1+ n))))))))
388 (struct-set! <class> class-index-getters-n-setters
389 (%compute-getters-n-setters (class-slots <class>)))
395 ;;; At this point, we have <class> but no other objects. We need to
396 ;;; define a standard way to make subclasses: how to compute the
397 ;;; precedence list of subclasses, how to compute the list of slots in a
398 ;;; subclass, and what layout to use for instances of those classes.
401 (define (compute-std-cpl c get-direct-supers)
402 "The standard class precedence list computation algorithm."
403 (define (only-non-null lst)
404 (filter (lambda (l) (not (null? l))) lst))
406 (define (merge-lists reversed-partial-result inputs)
408 ((every null? inputs)
409 (reverse! reversed-partial-result))
411 (let* ((candidate (lambda (c)
412 (and (not (any (lambda (l)
416 (candidate-car (lambda (l)
418 (candidate (car l)))))
419 (next (any candidate-car inputs)))
421 (goops-error "merge-lists: Inconsistent precedence graph"))
422 (let ((remove-next (lambda (l)
423 (if (eq? (car l) next)
426 (merge-lists (cons next reversed-partial-result)
427 (only-non-null (map remove-next inputs))))))))
428 (let ((c-direct-supers (get-direct-supers c)))
429 (merge-lists (list c)
430 (only-non-null (append (map class-precedence-list
432 (list c-direct-supers))))))
434 ;; This version of compute-cpl is replaced with a generic function once
436 (define (compute-cpl class)
437 (compute-std-cpl class class-direct-supers))
439 (define (build-slots-list dslots cpl)
440 (define (check-cpl slots class-slots)
441 (when (or-map (match-lambda ((name . options) (assq name slots)))
443 (scm-error 'misc-error #f
444 "a predefined <class> inherited field cannot be redefined"
446 (define (remove-duplicate-slots slots)
447 (let lp ((slots (reverse slots)) (res '()) (seen '()))
450 (((and slot (name . options)) . slots)
453 (lp slots (cons slot res) (cons name seen)))))))
454 (let* ((class-slots (and (memq <class> cpl)
455 (struct-ref <class> class-index-slots))))
457 (check-cpl dslots class-slots))
458 (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
460 (() (remove-duplicate-slots (append class-slots res)))
462 (let ((new-slots (struct-ref head class-index-direct-slots)))
465 (lp cpl (append new-slots res) class-slots))
467 ;; Move class slots to the head of the list.
468 (lp cpl res new-slots))
470 (check-cpl new-slots class-slots)
471 (lp cpl (append new-slots res) class-slots)))))))))
473 (define (%compute-layout slots getters-n-setters nfields is-class?)
474 (define (instance-allocated? g-n-s)
476 ((name init-thunk . (? exact-integer? index)) #t)
477 ((name init-thunk getter setter index size) #t)
480 (define (allocated-index g-n-s)
482 ((name init-thunk . (? exact-integer? index)) index)
483 ((name init-thunk getter setter index size) index)))
485 (define (allocated-size g-n-s)
487 ((name init-thunk . (? exact-integer? index)) 1)
488 ((name init-thunk getter setter index size) size)))
490 (define (slot-protection-and-kind options)
491 (define (subclass? class parent)
492 (memq parent (class-precedence-list class)))
493 (let ((type (kw-arg-ref options #:class)))
494 (if (and type (subclass? type <foreign-slot>))
496 ((subclass? type <self-slot>) #\s)
497 ((subclass? type <protected-slot>) #\p)
500 ((subclass? type <opaque-slot>) #\o)
501 ((subclass? type <read-only-slot>) #\r)
502 ((subclass? type <hidden-slot>) #\h)
506 (let ((layout (make-string (* nfields 2))))
507 (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
508 (match getters-n-setters
510 (unless (= n nfields) (error "bad nfields"))
511 (unless (null? slots) (error "inconsistent g-n-s/slots"))
513 (let ((class-layout (struct-ref <class> class-index-layout)))
514 (unless (string-prefix? (symbol->string class-layout) layout)
515 (error "bad layout for class"))))
517 ((g-n-s . getters-n-setters)
519 (((name . options) . slots)
521 ((instance-allocated? g-n-s)
522 (unless (< n nfields) (error "bad nfields"))
523 (unless (= n (allocated-index g-n-s)) (error "bad allocation"))
524 (call-with-values (lambda () (slot-protection-and-kind options))
525 (lambda (protection kind)
526 (let init ((n n) (size (allocated-size g-n-s)))
528 ((zero? size) (lp n slots getters-n-setters))
530 (string-set! layout (* n 2) protection)
531 (string-set! layout (1+ (* n 2)) kind)
532 (init (1+ n) (1- size))))))))
534 (lp n slots getters-n-setters))))))))))
540 ;;; With all of this, we are now able to define subclasses of <class>.
542 (define (%prep-layout! class)
543 (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
544 (layout (%compute-layout
545 (struct-ref class class-index-slots)
546 (struct-ref class class-index-getters-n-setters)
547 (struct-ref class class-index-nfields)
549 (%init-layout! class layout)))
551 (define (make-standard-class class name dsupers dslots)
552 (let ((z (make-struct/no-tail class)))
553 (struct-set! z class-index-direct-supers dsupers)
554 (let* ((cpl (compute-cpl z))
555 (dslots (map (lambda (slot)
556 (if (pair? slot) slot (list slot)))
558 (slots (build-slots-list dslots cpl))
559 (nfields (length slots))
560 (g-n-s (%compute-getters-n-setters slots)))
561 (struct-set! z class-index-name name)
562 (struct-set! z class-index-nfields nfields)
563 (struct-set! z class-index-direct-slots dslots)
564 (struct-set! z class-index-direct-subclasses '())
565 (struct-set! z class-index-direct-methods '())
566 (struct-set! z class-index-cpl cpl)
567 (struct-set! z class-index-slots slots)
568 (struct-set! z class-index-getters-n-setters g-n-s)
569 (struct-set! z class-index-redefined #f)
572 (let ((subclasses (struct-ref super class-index-direct-subclasses)))
573 (struct-set! super class-index-direct-subclasses
574 (cons z subclasses))))
579 (define-syntax define-standard-class
581 ((define-standard-class name (super ...) #:metaclass meta slot ...)
583 (make-standard-class meta 'name (list super ...) '(slot ...))))
584 ((define-standard-class name (super ...) slot ...)
585 (define-standard-class name (super ...) #:metaclass <class> slot ...))))
591 ;;; Sweet! Now we can define <top> and <object>, and finish
592 ;;; initializing the `direct-subclasses', `direct-supers', and `cpl'
593 ;;; slots of <class>.
595 (define-standard-class <top> ())
596 (define-standard-class <object> (<top>))
598 ;; <top>, <object>, and <class> were partially initialized. Correct
600 (struct-set! <object> class-index-direct-subclasses (list <class>))
601 (struct-set! <class> class-index-direct-supers (list <object>))
602 (struct-set! <class> class-index-cpl (list <class> <object> <top>))
608 ;;; We can also define the various slot types, and finish initializing
609 ;;; `direct-slots', `slots', and `getters-n-setters' of <class>.
611 (define-standard-class <foreign-slot> (<top>))
612 (define-standard-class <protected-slot> (<foreign-slot>))
613 (define-standard-class <hidden-slot> (<foreign-slot>))
614 (define-standard-class <opaque-slot> (<foreign-slot>))
615 (define-standard-class <read-only-slot> (<foreign-slot>))
616 (define-standard-class <self-slot> (<read-only-slot>))
617 (define-standard-class <protected-opaque-slot> (<protected-slot>
619 (define-standard-class <protected-hidden-slot> (<protected-slot>
621 (define-standard-class <protected-read-only-slot> (<protected-slot>
623 (define-standard-class <scm-slot> (<protected-slot>))
624 (define-standard-class <int-slot> (<foreign-slot>))
625 (define-standard-class <float-slot> (<foreign-slot>))
626 (define-standard-class <double-slot> (<foreign-slot>))
631 (cons (list 'name) tail))
632 ((_ (name class) tail)
633 (cons (list 'name #:class class) tail)))))
634 (let* ((dslots (fold-class-slots macro-fold-right visit '()))
635 (g-n-s (%compute-getters-n-setters dslots)))
636 (struct-set! <class> class-index-direct-slots dslots)
637 (struct-set! <class> class-index-slots dslots)
638 (struct-set! <class> class-index-getters-n-setters g-n-s)))
644 ;;; Now, to build out the class hierarchy.
647 (define-standard-class <procedure-class> (<class>))
649 (define-standard-class <applicable-struct-class>
651 (class-add-flags! <applicable-struct-class>
652 vtable-flag-applicable-vtable)
654 (define-standard-class <applicable-struct-with-setter-class>
655 (<applicable-struct-class>))
656 (class-add-flags! <applicable-struct-with-setter-class>
657 vtable-flag-setter-vtable)
659 (define-standard-class <applicable> (<top>))
660 (define-standard-class <applicable-struct> (<object> <applicable>)
661 #:metaclass <applicable-struct-class>
663 (define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
664 #:metaclass <applicable-struct-with-setter-class>
666 (define-standard-class <generic> (<applicable-struct>)
667 #:metaclass <applicable-struct-class>
669 (n-specialized #:init-value 0)
670 (extended-by #:init-value ())
672 (define-standard-class <extended-generic> (<generic>)
673 #:metaclass <applicable-struct-class>
674 (extends #:init-value ()))
675 (define-standard-class <generic-with-setter> (<generic>
676 <applicable-struct-with-setter>)
677 #:metaclass <applicable-struct-with-setter-class>)
678 (define-standard-class <accessor> (<generic-with-setter>)
679 #:metaclass <applicable-struct-with-setter-class>)
680 (define-standard-class <extended-generic-with-setter> (<extended-generic>
681 <generic-with-setter>)
682 #:metaclass <applicable-struct-with-setter-class>)
683 (define-standard-class <extended-accessor> (<accessor>
684 <extended-generic-with-setter>)
685 #:metaclass <applicable-struct-with-setter-class>)
687 (define-standard-class <method> (<object>)
694 (define-standard-class <accessor-method> (<method>)
695 (slot-definition #:init-keyword #:slot-definition))
697 (define-standard-class <boolean> (<top>))
698 (define-standard-class <char> (<top>))
699 (define-standard-class <list> (<top>))
700 (define-standard-class <pair> (<list>))
701 (define-standard-class <null> (<list>))
702 (define-standard-class <string> (<top>))
703 (define-standard-class <symbol> (<top>))
704 (define-standard-class <vector> (<top>))
705 (define-standard-class <foreign> (<top>))
706 (define-standard-class <hashtable> (<top>))
707 (define-standard-class <fluid> (<top>))
708 (define-standard-class <dynamic-state> (<top>))
709 (define-standard-class <frame> (<top>))
710 (define-standard-class <vm-continuation> (<top>))
711 (define-standard-class <bytevector> (<top>))
712 (define-standard-class <uvec> (<bytevector>))
713 (define-standard-class <array> (<top>))
714 (define-standard-class <bitvector> (<top>))
715 (define-standard-class <number> (<top>))
716 (define-standard-class <complex> (<number>))
717 (define-standard-class <real> (<complex>))
718 (define-standard-class <integer> (<real>))
719 (define-standard-class <fraction> (<real>))
720 (define-standard-class <keyword> (<top>))
721 (define-standard-class <unknown> (<top>))
722 (define-standard-class <procedure> (<applicable>)
723 #:metaclass <procedure-class>)
724 (define-standard-class <primitive-generic> (<procedure>)
725 #:metaclass <procedure-class>)
726 (define-standard-class <port> (<top>))
727 (define-standard-class <input-port> (<port>))
728 (define-standard-class <output-port> (<port>))
729 (define-standard-class <input-output-port> (<input-port> <output-port>))
731 (define (inherit-applicable! class)
732 "An internal routine to redefine a SMOB class that was added after
733 GOOPS was loaded, and on which scm_set_smob_apply installed an apply
735 ;; Why not use class-redefinition? We would, except that loading the
736 ;; compiler to compile effective methods can happen while GOOPS has
737 ;; only been partially loaded, and loading the compiler might cause
738 ;; SMOB types to be defined that need this facility. Instead we make
739 ;; a very specific hack, not a general solution. Probably the right
740 ;; solution is to avoid using the compiler, but that is another kettle
742 (unless (memq <applicable> (class-precedence-list class))
743 (unless (null? (class-slots class))
744 (error "SMOB object has slots?"))
747 (let ((subclasses (struct-ref super class-index-direct-subclasses)))
748 (struct-set! super class-index-direct-subclasses
749 (delq class subclasses))))
750 (struct-ref class class-index-direct-supers))
751 (struct-set! class class-index-direct-supers (list <applicable>))
752 (struct-set! class class-index-cpl (compute-cpl class))
753 (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
754 (struct-set! <applicable> class-index-direct-subclasses
755 (cons class subclasses)))))
761 ;;; At this point we have defined the class hierarchy, and it's time to
762 ;;; move on to instance allocation and generics. Once we have generics,
763 ;;; we'll fill out the metaobject protocol.
765 ;;; Here we define a limited version of `make', so that we can allocate
766 ;;; instances of specific classes. This definition will be replaced
769 (define (%invalidate-method-cache! gf)
770 (slot-set! gf 'procedure (delayed-compile gf))
771 (slot-set! gf 'effective-methods '()))
774 (define (invalidate-method-cache! gf)
775 (%invalidate-method-cache! gf))
777 (define* (get-keyword key l #:optional default)
778 "Determine an associated value for the keyword @var{key} from the list
779 @var{l}. The list @var{l} has to consist of an even number of elements,
780 where, starting with the first, every second element is a keyword,
781 followed by its associated value. If @var{l} does not hold a value for
782 @var{key}, the value @var{default} is returned."
783 (unless (keyword? key)
784 (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
789 (unless (keyword? kw)
790 (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
791 (if (eq? kw key) arg (lp l))))))
793 (define *unbound* (list 'unbound))
795 (define-inlinable (unbound? x)
798 (define (%allocate-instance class)
799 (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
800 (%clear-fields! obj *unbound*)
803 (define (make class . args)
805 ((or (eq? class <generic>) (eq? class <accessor>))
806 (let ((z (make-struct/no-tail class #f '() 0 '())))
807 (set-procedure-property! z 'name (get-keyword #:name args #f))
808 (invalidate-method-cache! z)
809 (when (eq? class <accessor>)
810 (let ((setter (get-keyword #:setter args #f)))
812 (slot-set! z 'setter setter))))
815 (let ((z (%allocate-instance class)))
817 ((or (eq? class <method>) (eq? class <accessor-method>))
818 (for-each (match-lambda
820 (slot-set! z slot (get-keyword kw args default))))
821 '((#:generic-function generic-function #f)
822 (#:specializers specializers ())
823 (#:procedure procedure #f)
824 (#:formals formals ())
826 (#:make-procedure make-procedure #f))))
827 ((memq <class> (class-precedence-list class))
828 (class-add-flags! z (logior vtable-flag-goops-class
829 vtable-flag-goops-valid))
830 (for-each (match-lambda
832 (slot-set! z slot (get-keyword kw args default))))
834 (#:dsupers direct-supers ())
835 (#:slots direct-slots ()))))
837 (error "boot `make' does not support this class" class)))
840 (define (is-a? obj class)
841 "Return @code{#t} if @var{obj} is an instance of @var{class}, or
842 @code{#f} otherwise."
843 (and (memq class (class-precedence-list (class-of obj))) #t))
849 ;;; Slot access. This protocol is a bit of a mess: there's the `slots'
850 ;;; slot, which ostensibly holds "slot definitions" but really just has
851 ;;; specially formatted lists. And then there's the `getters-n-setters'
852 ;;; slot, which mirrors `slots' but should in theory indicates how to
853 ;;; get at slots for a particular instance -- never mind that `slots'
854 ;;; was also computed for a particular instance, and that
855 ;;; `getters-n-setters' is a strangely structured chain of pairs.
856 ;;; Perhaps we can fix this in the future, following the CLOS MOP, to
857 ;;; have proper <effective-slot-definition> objects.
859 (define (get-slot-value-using-name class obj slot-name)
860 (match (assq slot-name (struct-ref class class-index-getters-n-setters))
861 (#f (slot-missing class obj slot-name))
862 ((name init-thunk . (? exact-integer? index))
863 (struct-ref obj index))
864 ((name init-thunk getter setter . _)
867 (define (set-slot-value-using-name! class obj slot-name value)
868 (match (assq slot-name (struct-ref class class-index-getters-n-setters))
869 (#f (slot-missing class obj slot-name value))
870 ((name init-thunk . (? exact-integer? index))
871 (struct-set! obj index value))
872 ((name init-thunk getter setter . _)
873 (setter obj value))))
875 (define (test-slot-existence class obj slot-name)
876 (and (assq slot-name (struct-ref class class-index-getters-n-setters))
880 ;;; Before we go on, some notes about class redefinition. In GOOPS,
881 ;;; classes can be redefined. Redefinition of a class marks the class
882 ;;; as invalid, and instances will be lazily migrated over to the new
883 ;;; representation as they are accessed. Migration happens when
884 ;;; `class-of' is called on an instance. For more technical details on
885 ;;; object redefinition, see struct.h.
887 ;;; In the following interfaces, class-of handles the redefinition
888 ;;; protocol. I would think though that there is some thread-unsafety
889 ;;; here though as the { class, object data } pair needs to be accessed
890 ;;; atomically, not the { class, object } pair.
893 (define (slot-ref obj slot-name)
894 "Return the value from @var{obj}'s slot with the nam var{slot_name}."
895 (unless (symbol? slot-name)
896 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
897 (list slot-name) #f))
898 (let* ((class (class-of obj))
899 (val (get-slot-value-using-name class obj slot-name)))
901 (slot-unbound class obj slot-name)
904 (define (slot-set! obj slot-name value)
905 "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
906 (unless (symbol? slot-name)
907 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
908 (list slot-name) #f))
909 (set-slot-value-using-name! (class-of obj) obj slot-name value))
911 (define (slot-bound? obj slot-name)
912 "Return the value from @var{obj}'s slot with the nam var{slot_name}."
913 (unless (symbol? slot-name)
914 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
915 (list slot-name) #f))
916 (not (unbound? (get-slot-value-using-name (class-of obj) obj slot-name))))
918 (define (slot-exists? obj slot-name)
919 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
920 (unless (symbol? slot-name)
921 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
922 (list slot-name) #f))
923 (test-slot-existence (class-of obj) obj slot-name))
926 (define (check-slot-args class obj slot-name)
927 (unless (eq? class (class-of obj))
928 (scm-error 'wrong-type-arg #f "~S is not the class of ~S"
929 (list class obj) #f))
930 (unless (symbol? slot-name)
931 (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
932 (list slot-name) #f)))
934 (define (slot-ref-using-class class obj slot-name)
935 (issue-deprecation-warning "slot-ref-using-class is deprecated. "
936 "Use slot-ref instead.")
937 (check-slot-args class obj slot-name)
938 (slot-ref obj slot-name))
940 (define (slot-set-using-class! class obj slot-name value)
941 (issue-deprecation-warning "slot-set-using-class! is deprecated. "
942 "Use slot-set! instead.")
943 (check-slot-args class obj slot-name)
944 (slot-set! obj slot-name value))
946 (define (slot-bound-using-class? class obj slot-name)
947 (issue-deprecation-warning "slot-bound-using-class? is deprecated. "
948 "Use slot-bound? instead.")
949 (check-slot-args class obj slot-name)
950 (slot-bound? obj slot-name))
952 (define (slot-exists-using-class? class obj slot-name)
953 (issue-deprecation-warning "slot-exists-using-class? is deprecated. "
954 "Use slot-exists? instead.")
955 (check-slot-args class obj slot-name)
956 (slot-exists? obj slot-name)))
962 ;;; Method accessors.
964 (define (method-generic-function obj)
965 "Return the generic function for the method @var{obj}."
966 (unless (is-a? obj <method>)
967 (scm-error 'wrong-type-arg #f "Not a method: ~S"
969 (slot-ref obj 'generic-function))
971 (define (method-specializers obj)
972 "Return specializers of the method @var{obj}."
973 (unless (is-a? obj <method>)
974 (scm-error 'wrong-type-arg #f "Not a method: ~S"
976 (slot-ref obj 'specializers))
978 (define (method-procedure obj)
979 "Return the procedure of the method @var{obj}."
980 (unless (is-a? obj <method>)
981 (scm-error 'wrong-type-arg #f "Not a method: ~S"
983 (slot-ref obj 'procedure))
989 ;;; Generic functions!
991 (define *dispatch-module* (current-module))
994 ;;; Generic functions have an applicable-methods cache associated with
995 ;;; them. Every distinct set of types that is dispatched through a
996 ;;; generic adds an entry to the cache. This cache gets compiled out to
997 ;;; a dispatch procedure. In steady-state, this dispatch procedure is
998 ;;; never recompiled; but during warm-up there is some churn, both to
999 ;;; the cache and to the dispatch procedure.
1001 ;;; So what is the deal if warm-up happens in a multithreaded context?
1002 ;;; There is indeed a window between missing the cache for a certain set
1003 ;;; of arguments, and then updating the cache with the newly computed
1004 ;;; applicable methods. One of the updaters is liable to lose their new
1007 ;;; This is actually OK though, because a subsequent cache miss for the
1008 ;;; race loser will just cause memoization to try again. The cache will
1009 ;;; eventually be consistent. We're not mutating the old part of the
1010 ;;; cache, just consing on the new entry.
1012 ;;; It doesn't even matter if the dispatch procedure and the cache are
1013 ;;; inconsistent -- most likely the type-set that lost the dispatch
1014 ;;; procedure race will simply re-trigger a memoization, but since the
1015 ;;; winner isn't in the effective-methods cache, it will likely also
1016 ;;; re-trigger a memoization, and the cache will finally be consistent.
1017 ;;; As you can see there is a possibility for ping-pong effects, but
1018 ;;; it's unlikely given the shortness of the window between slot-set!
1019 ;;; invocations. We could add a mutex, but it is strictly unnecessary,
1020 ;;; and would add runtime cost and complexity.
1023 (define (emit-linear-dispatch gf-sym nargs methods free rest?)
1024 (define (gen-syms n stem)
1025 (let lp ((n (1- n)) (syms '()))
1028 (lp (1- n) (cons (gensym stem) syms)))))
1029 (let* ((args (gen-syms nargs "a"))
1030 (types (gen-syms nargs "t")))
1031 (let lp ((methods methods)
1033 (exp `(cache-miss ,gf-sym
1035 `(cons* ,@args rest)
1039 (values `(,(if rest? `(,@args . rest) args)
1040 (let ,(map (lambda (t a)
1041 `(,t (class-of ,a)))
1045 ((#(_ specs _ cmethod) . methods)
1046 (let build-dispatch ((free free)
1052 (let ((m-sym (gensym "p")))
1054 (acons cmethod m-sym free)
1055 `(if (and . ,checks)
1057 `(apply ,m-sym ,@args rest)
1063 (let ((var (assq-ref free spec)))
1065 (build-dispatch free
1068 (cons `(eq? ,type ,var)
1070 (let ((var (gensym "c")))
1071 (build-dispatch (acons spec var free)
1074 (cons `(eq? ,type ,var)
1075 checks)))))))))))))))
1077 (define (compute-dispatch-procedure gf cache)
1079 (let lp ((ls cache) (nreq -1) (nrest -1))
1082 (collate (make-vector (1+ nreq) '())
1083 (make-vector (1+ nrest) '())))
1084 ((#(len specs rest? cmethod) . ls)
1086 (lp ls nreq (max nrest len))
1087 (lp ls (max nreq len) nrest))))))
1088 (define (collate req rest)
1089 (let lp ((ls cache))
1091 (() (emit req rest))
1092 (((and entry #(len specs rest? cmethod)) . ls)
1094 (vector-set! rest len (cons entry (vector-ref rest len)))
1095 (vector-set! req len (cons entry (vector-ref req len))))
1097 (define (emit req rest)
1098 (let ((gf-sym (gensym "g")))
1099 (define (emit-rest n clauses free)
1100 (if (< n (vector-length rest))
1101 (match (vector-ref rest n)
1102 (() (emit-rest (1+ n) clauses free))
1103 ;; FIXME: hash dispatch
1107 (emit-linear-dispatch gf-sym n methods free #t))
1108 (lambda (clause free)
1109 (emit-rest (1+ n) (cons clause clauses) free)))))
1110 (emit-req (1- (vector-length req)) clauses free)))
1111 (define (emit-req n clauses free)
1113 (comp `(lambda ,(map cdr free)
1114 (case-lambda ,@clauses))
1116 (match (vector-ref req n)
1117 (() (emit-req (1- n) clauses free))
1118 ;; FIXME: hash dispatch
1122 (emit-linear-dispatch gf-sym n methods free #f))
1123 (lambda (clause free)
1124 (emit-req (1- n) (cons clause clauses) free)))))))
1127 (if (or (zero? (vector-length rest))
1128 (null? (vector-ref rest 0)))
1129 (list `(args (cache-miss ,gf-sym args)))
1131 (acons gf gf-sym '()))))
1132 (define (comp exp vals)
1133 ;; When cross-compiling Guile itself, the native Guile must generate
1134 ;; code for the host.
1135 (with-target %host-type
1137 (let ((p ((@ (system base compile) compile) exp
1138 #:env *dispatch-module*
1140 #:opts '(#:partial-eval? #f #:cse? #f))))
1146 ;; o/~ ten, nine, eight
1147 ;; sometimes that's just how it goes
1150 ;; get out before it blows o/~
1152 (define timer-init 30)
1153 (define (delayed-compile gf)
1154 (let ((timer timer-init))
1156 (set! timer (1- timer))
1159 (let ((dispatch (compute-dispatch-procedure
1160 gf (slot-ref gf 'effective-methods))))
1161 (slot-set! gf 'procedure dispatch)
1162 (apply dispatch args)))
1164 ;; interestingly, this catches recursive compilation attempts as
1165 ;; well; in that case, timer is negative
1166 (cache-dispatch gf args))))))
1168 (define (cache-dispatch gf args)
1169 (define (map-until n f ls)
1170 (if (or (zero? n) (null? ls))
1172 (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
1173 (define (equal? x y) ; can't use the stock equal? because it's a generic...
1174 (cond ((pair? x) (and (pair? y)
1175 (eq? (car x) (car y))
1176 (equal? (cdr x) (cdr y))))
1177 ((null? x) (null? y))
1179 (if (slot-ref gf 'n-specialized)
1180 (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
1181 (let lp ((cache (slot-ref gf 'effective-methods)))
1182 (cond ((null? cache)
1183 (cache-miss gf args))
1184 ((equal? (vector-ref (car cache) 1) types)
1185 (apply (vector-ref (car cache) 3) args))
1186 (else (lp (cdr cache))))))
1187 (cache-miss gf args)))
1189 (define (cache-miss gf args)
1190 (apply (memoize-method! gf args) args))
1192 (define (memoize-effective-method! gf args applicable)
1193 (define (first-n ls n)
1194 (if (or (zero? n) (null? ls))
1196 (cons (car ls) (first-n (cdr ls) (- n 1)))))
1197 (define (parse n ls)
1199 (memoize n #f (map class-of args)))
1200 ((= n (slot-ref gf 'n-specialized))
1201 (memoize n #t (map class-of (first-n args n))))
1203 (parse (1+ n) (cdr ls)))))
1204 (define (memoize len rest? types)
1205 (let* ((cmethod (compute-cmethod applicable types))
1206 (cache (cons (vector len types rest? cmethod)
1207 (slot-ref gf 'effective-methods))))
1208 (slot-set! gf 'effective-methods cache)
1209 (slot-set! gf 'procedure (delayed-compile gf))
1214 ;;; Compiling next methods into method bodies
1217 ;;; So, for the reader: there basic idea is that, given that the
1218 ;;; semantics of `next-method' depend on the concrete types being
1219 ;;; dispatched, why not compile a specific procedure to handle each type
1220 ;;; combination that we see at runtime.
1222 ;;; In theory we can do much better than a bytecode compilation, because
1223 ;;; we know the *exact* types of the arguments. It's ideal for native
1224 ;;; compilation. A task for the future.
1226 ;;; I think this whole generic application mess would benefit from a
1229 (define (compute-cmethod methods types)
1230 (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
1233 (if (null? (cdr methods))
1235 (no-next-method (method-generic-function (car methods)) args))
1236 (compute-cmethod (cdr methods) types)))
1237 (method-procedure (car methods)))))
1243 (define (memoize-method! gf args)
1244 (let ((applicable ((if (eq? gf compute-applicable-methods)
1245 %compute-applicable-methods
1246 compute-applicable-methods)
1249 (memoize-effective-method! gf args applicable))
1251 (no-applicable-method gf args)))))
1253 (set-procedure-property! memoize-method! 'system-procedure #t)
1255 (define no-applicable-method
1256 (make <generic> #:name 'no-applicable-method))
1260 ;; Then load the rest of GOOPS
1263 ;; FIXME: deprecate.
1264 (define min-fixnum (- (expt 2 29)))
1265 (define max-fixnum (- (expt 2 29) 1))
1270 (define (goops-error format-string . args)
1271 (scm-error 'goops-error #f format-string args '()))
1277 (define ensure-metaclass-with-supers
1278 (let ((table-of-metas '()))
1279 (lambda (meta-supers)
1280 (let ((entry (assoc meta-supers table-of-metas)))
1282 ;; Found a previously created metaclass
1284 ;; Create a new meta-class which inherit from "meta-supers"
1285 (let ((new (make <class> #:dsupers meta-supers
1287 #:name (gensym "metaclass"))))
1288 (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
1291 (define (ensure-metaclass supers)
1294 (let* ((all-metas (map (lambda (x) (class-of x)) supers))
1295 (all-cpls (append-map (lambda (m)
1296 (cdr (class-precedence-list m)))
1299 ;; Find the most specific metaclasses. The new metaclass will be
1300 ;; a subclass of these.
1303 (when (and (not (member meta all-cpls))
1304 (not (member meta needed-metas)))
1305 (set! needed-metas (append needed-metas (list meta)))))
1307 ;; Now return a subclass of the metaclasses we found.
1308 (if (null? (cdr needed-metas))
1309 (car needed-metas) ; If there's only one, just use it.
1310 (ensure-metaclass-with-supers needed-metas)))))
1316 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
1318 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
1319 ;;; OPTION ::= KEYWORD VALUE
1322 (define (make-class supers slots . options)
1323 (define (find-duplicate l)
1327 (if (memq head tail)
1329 (find-duplicate tail)))))
1331 (let* ((name (get-keyword #:name options *unbound*))
1332 (supers (if (not (or-map (lambda (class)
1334 (class-precedence-list class)))
1336 (append supers (list <object>))
1338 (metaclass (or (get-keyword #:metaclass options #f)
1339 (ensure-metaclass supers))))
1341 ;; Verify that all direct slots are different and that we don't inherit
1342 ;; several time from the same class
1343 (let ((tmp1 (find-duplicate supers))
1344 (tmp2 (find-duplicate (map slot-definition-name slots))))
1346 (goops-error "make-class: super class ~S is duplicate in class ~S"
1349 (goops-error "make-class: slot ~S is duplicate in class ~S"
1352 ;; Everything seems correct, build the class
1353 (apply make metaclass
1359 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
1361 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
1362 ;;; OPTION ::= KEYWORD VALUE
1364 (define-syntax class
1366 (define (parse-options options)
1367 (syntax-case options ()
1369 ((kw arg . options) (keyword? (syntax->datum #'kw))
1370 (with-syntax ((options (parse-options #'options)))
1371 (syntax-case #'kw ()
1373 #'(kw 'arg #:init-thunk (lambda () arg) . options))
1375 #'(kw arg . options)))))))
1376 (define (check-valid-kwargs args)
1377 (syntax-case args ()
1379 ((kw arg . args) (keyword? (syntax->datum #'kw))
1380 #`(kw arg . #,(check-valid-kwargs #'args)))))
1381 (define (parse-slots-and-kwargs args)
1382 (syntax-case args ()
1385 ((kw . _) (keyword? (syntax->datum #'kw))
1386 #`(() #,(check-valid-kwargs args)))
1387 (((name option ...) args ...)
1388 (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
1389 ((option ...) (parse-options #'(option ...))))
1390 #'(((list 'name option ...) . slots) kwargs)))
1391 ((name args ...) (symbol? (syntax->datum #'name))
1392 (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
1393 #'(('(name) . slots) kwargs)))))
1395 ((class (super ...) arg ...)
1396 (with-syntax ((((slot-def ...) (option ...))
1397 (parse-slots-and-kwargs #'(arg ...))))
1398 #'(make-class (list super ...)
1402 (define-syntax define-class-pre-definition
1405 ((_ (k arg rest ...) out ...)
1406 (keyword? (syntax->datum #'k))
1407 (case (syntax->datum #'k)
1408 ((#:getter #:setter)
1409 #'(define-class-pre-definition (rest ...)
1411 (when (or (not (defined? 'arg))
1412 (not (is-a? arg <generic>)))
1415 (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
1417 #'(define-class-pre-definition (rest ...)
1419 (when (or (not (defined? 'arg))
1420 (not (is-a? arg <accessor>)))
1423 (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
1425 #'(define-class-pre-definition (rest ...) out ...))))
1427 #'(begin out ...)))))
1429 ;; Some slot options require extra definitions to be made. In
1430 ;; particular, we want to make sure that the generic function objects
1431 ;; which represent accessors exist before `make-class' tries to add
1433 (define-syntax define-class-pre-definitions
1438 ((_ (slot rest ...) out ...)
1439 (keyword? (syntax->datum #'slot))
1441 ((_ (slot rest ...) out ...)
1442 (identifier? #'slot)
1443 #'(define-class-pre-definitions (rest ...)
1445 ((_ ((slotname slotopt ...) rest ...) out ...)
1446 #'(define-class-pre-definitions (rest ...)
1447 out ... (define-class-pre-definition (slotopt ...)))))))
1449 (define-syntax-rule (define-class name supers slot ...)
1451 (define-class-pre-definitions (slot ...))
1452 (if (and (defined? 'name)
1453 (is-a? name <class>)
1454 (memq <object> (class-precedence-list name)))
1455 (class-redefinition name
1456 (class supers slot ... #:name 'name))
1457 (toplevel-define! 'name (class supers slot ... #:name 'name)))))
1459 (define-syntax-rule (standard-define-class arg ...)
1460 (define-class arg ...))
1463 ;;; {Generic functions and accessors}
1466 ;; Apparently the desired semantics are that we extend previous
1467 ;; procedural definitions, but that if `name' was already a generic, we
1468 ;; overwrite its definition.
1469 (define-syntax define-generic
1472 ((define-generic name) (symbol? (syntax->datum #'name))
1474 (if (and (defined? 'name) (is-a? name <generic>))
1475 (make <generic> #:name 'name)
1476 (ensure-generic (if (defined? 'name) name #f) 'name)))))))
1478 (define-syntax define-extended-generic
1481 ((define-extended-generic name val) (symbol? (syntax->datum #'name))
1482 #'(define name (make-extended-generic val 'name))))))
1484 (define-syntax define-extended-generics
1486 (define (id-append ctx a b)
1487 (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
1489 ((define-extended-generic (name ...) #:prefix (prefix ...))
1490 (and (and-map symbol? (syntax->datum #'(name ...)))
1491 (and-map symbol? (syntax->datum #'(prefix ...))))
1492 (with-syntax ((((val ...)) (map (lambda (name)
1493 (map (lambda (prefix)
1494 (id-append name prefix name))
1498 (define-extended-generic name (list val ...))
1501 (define* (make-generic #:optional name)
1502 (make <generic> #:name name))
1504 (define* (make-extended-generic gfs #:optional name)
1505 (let* ((gfs (if (list? gfs) gfs (list gfs)))
1506 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
1508 (let* ((sname (and name (make-setter-name name)))
1510 (append-map (lambda (gf)
1511 (if (is-a? gf <generic-with-setter>)
1512 (list (ensure-generic (setter gf)
1516 (es (make <extended-generic-with-setter>
1519 #:setter (make <extended-generic>
1521 #:extends setters))))
1522 (extended-by! setters (setter es))
1524 (make <extended-generic>
1527 (extended-by! gfs ans)
1530 (define (extended-by! gfs eg)
1531 (for-each (lambda (gf)
1532 (slot-set! gf 'extended-by
1533 (cons eg (slot-ref gf 'extended-by))))
1535 (invalidate-method-cache! eg))
1537 (define (not-extended-by! gfs eg)
1538 (for-each (lambda (gf)
1539 (slot-set! gf 'extended-by
1540 (delq! eg (slot-ref gf 'extended-by))))
1542 (invalidate-method-cache! eg))
1544 (define* (ensure-generic old-definition #:optional name)
1545 (cond ((is-a? old-definition <generic>) old-definition)
1546 ((procedure-with-setter? old-definition)
1547 (make <generic-with-setter>
1549 #:default (procedure old-definition)
1550 #:setter (setter old-definition)))
1551 ((procedure? old-definition)
1552 (if (generic-capability? old-definition) old-definition
1553 (make <generic> #:name name #:default old-definition)))
1554 (else (make <generic> #:name name))))
1556 ;; same semantics as <generic>
1557 (define-syntax-rule (define-accessor name)
1559 (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
1560 ((is-a? name <accessor>) (make <accessor> #:name 'name))
1561 (else (ensure-accessor name 'name)))))
1563 (define (make-setter-name name)
1564 (string->symbol (string-append "setter:" (symbol->string name))))
1566 (define* (make-accessor #:optional name)
1569 #:setter (make <generic>
1570 #:name (and name (make-setter-name name)))))
1572 (define* (ensure-accessor proc #:optional name)
1573 (cond ((and (is-a? proc <accessor>)
1574 (is-a? (setter proc) <generic>))
1576 ((is-a? proc <generic-with-setter>)
1577 (upgrade-accessor proc (setter proc)))
1578 ((is-a? proc <generic>)
1579 (upgrade-accessor proc (make-generic name)))
1580 ((procedure-with-setter? proc)
1583 #:default (procedure proc)
1584 #:setter (ensure-generic (setter proc) name)))
1586 (ensure-accessor (if (generic-capability? proc)
1587 (make <generic> #:name name #:default proc)
1588 (ensure-generic proc name))
1591 (make-accessor name))))
1593 (define (upgrade-accessor generic setter)
1594 (let ((methods (slot-ref generic 'methods))
1595 (gws (make (if (is-a? generic <extended-generic>)
1596 <extended-generic-with-setter>
1598 #:name (generic-function-name generic)
1599 #:extended-by (slot-ref generic 'extended-by)
1601 (when (is-a? generic <extended-generic>)
1602 (let ((gfs (slot-ref generic 'extends)))
1603 (not-extended-by! gfs generic)
1604 (slot-set! gws 'extends gfs)
1605 (extended-by! gfs gws)))
1606 ;; Steal old methods
1607 (for-each (lambda (method)
1608 (slot-set! method 'generic-function gws))
1610 (slot-set! gws 'methods methods)
1611 (invalidate-method-cache! gws)
1618 ;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
1619 ;; element longer than the other when we have a dotted parameter
1620 ;; list). For instance, with the call
1626 ;; (define-method M (a . l) ....)
1627 ;; (define-method M (a) ....)
1629 ;; we consider that the second method is more specific.
1631 ;; Precondition: `a' and `b' are methods and are applicable to `types'.
1632 (define (%method-more-specific? a b types)
1633 (let lp ((a-specializers (method-specializers a))
1634 (b-specializers (method-specializers b))
1637 ;; (a) less specific than (a b ...) or (a . b)
1638 ((null? a-specializers) #t)
1639 ;; (a b ...) or (a . b) less specific than (a)
1640 ((null? b-specializers) #f)
1641 ;; (a . b) less specific than (a b ...)
1642 ((not (pair? a-specializers)) #f)
1643 ;; (a b ...) more specific than (a . b)
1644 ((not (pair? b-specializers)) #t)
1646 (let ((a-specializer (car a-specializers))
1647 (b-specializer (car b-specializers))
1648 (a-specializers (cdr a-specializers))
1649 (b-specializers (cdr b-specializers))
1651 (types (cdr types)))
1652 (if (eq? a-specializer b-specializer)
1653 (lp a-specializers b-specializers types)
1654 (let lp ((cpl (class-precedence-list type)))
1655 (let ((elt (car cpl)))
1657 ((eq? a-specializer elt) #t)
1658 ((eq? b-specializer elt) #f)
1659 (else (lp (cdr cpl))))))))))))
1661 (define (%sort-applicable-methods methods types)
1662 (sort methods (lambda (a b) (%method-more-specific? a b types))))
1664 (define (generic-function-methods obj)
1665 "Return the methods of the generic function @var{obj}."
1666 (define (fold-upward method-lists gf)
1668 ((is-a? gf <extended-generic>)
1669 (let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends)))
1673 (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
1675 (else method-lists)))
1676 (define (fold-downward method-lists gf)
1677 (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
1678 (gfs (slot-ref gf 'extended-by)))
1682 (lp (fold-downward method-lists gf) gfs)))))
1683 (unless (is-a? obj <generic>)
1684 (scm-error 'wrong-type-arg #f "Not a generic: ~S"
1686 (concatenate (fold-downward (fold-upward '() obj) obj)))
1688 (define (%compute-applicable-methods gf args)
1689 (define (method-applicable? m types)
1690 (let lp ((specs (method-specializers m)) (types types))
1692 ((null? specs) (null? types))
1693 ((not (pair? specs)) #t)
1696 (and (memq (car specs) (class-precedence-list (car types)))
1697 (lp (cdr specs) (cdr types)))))))
1698 (let ((n (length args))
1699 (types (map class-of args)))
1700 (let lp ((methods (generic-function-methods gf))
1703 (and (not (null? applicable))
1704 (%sort-applicable-methods applicable types))
1705 (let ((m (car methods)))
1707 (if (method-applicable? m types)
1711 (define compute-applicable-methods %compute-applicable-methods)
1713 (define (toplevel-define! name val)
1714 (module-define! (current-module) name val))
1716 (define-syntax define-method
1717 (syntax-rules (setter)
1718 ((_ ((setter name) . args) body ...)
1720 (when (or (not (defined? 'name))
1721 (not (is-a? name <accessor>)))
1722 (toplevel-define! 'name
1724 (if (defined? 'name) name #f) 'name)))
1725 (add-method! (setter name) (method args body ...))))
1726 ((_ (name . args) body ...)
1728 ;; FIXME: this code is how it always was, but it's quite cracky:
1729 ;; it will only define the generic function if it was undefined
1730 ;; before (ok), or *was defined to #f*. The latter is crack. But
1731 ;; there are bootstrap issues about fixing this -- change it to
1732 ;; (is-a? name <generic>) and see.
1733 (when (or (not (defined? 'name))
1735 (toplevel-define! 'name (make <generic> #:name 'name)))
1736 (add-method! name (method args body ...))))))
1738 (define-syntax method
1740 (define (parse-args args)
1741 (let lp ((ls args) (formals '()) (specializers '()))
1744 (and (identifier? #'f) (identifier? #'s))
1747 (cons #'s specializers)))
1752 (cons #'<top> specializers)))
1754 (list (reverse formals)
1755 (reverse (cons #''() specializers))))
1757 (identifier? #'tail)
1758 (list (append (reverse formals) #'tail)
1759 (reverse (cons #'<top> specializers)))))))
1761 (define (find-free-id exp referent)
1764 (or (find-free-id #'x referent)
1765 (find-free-id #'y referent)))
1768 (let ((id (datum->syntax #'x referent)))
1769 (and (free-identifier=? #'x id) id)))
1772 (define (compute-procedure formals body)
1773 (syntax-case body ()
1775 (with-syntax ((formals formals))
1776 #'(lambda formals body0 ...)))))
1778 (define (->proper args)
1779 (let lp ((ls args) (out '()))
1781 ((x . xs) (lp #'xs (cons #'x out)))
1783 (tail (reverse (cons #'tail out))))))
1785 (define (compute-make-procedure formals body next-method)
1786 (syntax-case body ()
1788 (with-syntax ((next-method next-method))
1789 (syntax-case formals ()
1791 #'(lambda (real-next-method)
1792 (lambda (formal ...)
1793 (let ((next-method (lambda args
1795 (real-next-method formal ...)
1796 (apply real-next-method args)))))
1799 (with-syntax (((formal ...) (->proper #'formals)))
1800 #'(lambda (real-next-method)
1802 (let ((next-method (lambda args
1804 (apply real-next-method formal ...)
1805 (apply real-next-method args)))))
1808 (define (compute-procedures formals body)
1809 ;; So, our use of this is broken, because it operates on the
1810 ;; pre-expansion source code. It's equivalent to just searching
1811 ;; for referent in the datums. Ah well.
1812 (let ((id (find-free-id body 'next-method)))
1814 ;; return a make-procedure
1816 (compute-make-procedure formals body id))
1817 (values (compute-procedure formals body)
1821 ((_ args) #'(method args (if #f #f)))
1822 ((_ args body0 body1 ...)
1823 (with-syntax (((formals (specializer ...)) (parse-args #'args)))
1826 (compute-procedures #'formals #'(body0 body1 ...)))
1827 (lambda (procedure make-procedure)
1828 (with-syntax ((procedure procedure)
1829 (make-procedure make-procedure))
1831 #:specializers (cons* specializer ...)
1833 #:body '(body0 body1 ...)
1834 #:make-procedure make-procedure
1835 #:procedure procedure)))))))))
1840 ;;; These are useful when dealing with method specializers, which might
1841 ;;; have a rest argument.
1844 (define (map* fn . l) ; A map which accepts dotted lists (arg lists
1845 (cond ; must be "isomorph"
1846 ((null? (car l)) '())
1847 ((pair? (car l)) (cons (apply fn (map car l))
1848 (apply map* fn (map cdr l))))
1849 (else (apply fn l))))
1851 (define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
1852 (cond ; must be "isomorph"
1853 ((null? (car l)) '())
1854 ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
1855 (else (apply fn l))))
1857 (define (length* ls)
1860 ((not (pair? ls)) n)))
1866 (define (add-method-in-classes! m)
1867 ;; Add method in all the classes which appears in its specializers list
1868 (for-each* (lambda (x)
1869 (let ((dm (class-direct-methods x)))
1871 (struct-set! x class-index-direct-methods (cons m dm)))))
1872 (method-specializers m)))
1874 (define (remove-method-in-classes! m)
1875 ;; Remove method in all the classes which appears in its specializers list
1876 (for-each* (lambda (x)
1878 class-index-direct-methods
1879 (delv! m (class-direct-methods x))))
1880 (method-specializers m)))
1882 (define (compute-new-list-of-methods gf new)
1883 (let ((new-spec (method-specializers new))
1884 (methods (slot-ref gf 'methods)))
1885 (let loop ((l methods))
1888 (if (equal? (method-specializers (car l)) new-spec)
1890 ;; This spec. list already exists. Remove old method from dependents
1891 (remove-method-in-classes! (car l))
1896 (define (method-n-specializers m)
1897 (length* (slot-ref m 'specializers)))
1899 (define (calculate-n-specialized gf)
1900 (fold (lambda (m n) (max n (method-n-specializers m)))
1902 (generic-function-methods gf)))
1904 (define (invalidate-method-cache! gf)
1905 (%invalidate-method-cache! gf)
1906 (slot-set! gf 'n-specialized (calculate-n-specialized gf))
1907 (for-each (lambda (gf) (invalidate-method-cache! gf))
1908 (slot-ref gf 'extended-by)))
1910 (define internal-add-method!
1911 (method ((gf <generic>) (m <method>))
1912 (slot-set! m 'generic-function gf)
1913 (slot-set! gf 'methods (compute-new-list-of-methods gf m))
1914 (invalidate-method-cache! gf)
1915 (add-method-in-classes! m)
1918 (define-generic add-method!)
1920 ((method-procedure internal-add-method!) add-method! internal-add-method!)
1922 (define-method (add-method! (proc <procedure>) (m <method>))
1923 (if (generic-capability? proc)
1925 (enable-primitive-generic! proc)
1926 (add-method! proc m))
1929 (define-method (add-method! (pg <primitive-generic>) (m <method>))
1930 (add-method! (primitive-generic-generic pg) m))
1932 (define-method (add-method! obj (m <method>))
1933 (goops-error "~S is not a valid generic function" obj))
1936 ;;; {Access to meta objects}
1942 (define-method (method-source (m <method>))
1943 (let* ((spec (map* class-name (slot-ref m 'specializers)))
1944 (src (procedure-source (slot-ref m 'procedure))))
1946 (let ((args (cadr src))
1949 (cons (map* list args spec)
1952 (define-method (method-formals (m <method>))
1953 (slot-ref m 'formals))
1958 (define slot-definition-name car)
1960 (define slot-definition-options cdr)
1962 (define (slot-definition-allocation s)
1963 (get-keyword #:allocation (cdr s) #:instance))
1965 (define (slot-definition-getter s)
1966 (get-keyword #:getter (cdr s) #f))
1968 (define (slot-definition-setter s)
1969 (get-keyword #:setter (cdr s) #f))
1971 (define (slot-definition-accessor s)
1972 (get-keyword #:accessor (cdr s) #f))
1974 (define (slot-definition-init-value s)
1975 ;; can be #f, so we can't use #f as non-value
1976 (get-keyword #:init-value (cdr s) *unbound*))
1978 (define (slot-definition-init-form s)
1979 (get-keyword #:init-form (cdr s) *unbound*))
1981 (define (slot-definition-init-thunk s)
1982 (get-keyword #:init-thunk (cdr s) #f))
1984 (define (slot-definition-init-keyword s)
1985 (get-keyword #:init-keyword (cdr s) #f))
1987 (define (class-slot-definition class slot-name)
1988 (assq slot-name (class-slots class)))
1990 (define (slot-init-function class slot-name)
1991 (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))
1993 (define (accessor-method-slot-definition obj)
1994 "Return the slot definition of the accessor @var{obj}."
1995 (slot-ref obj 'slot-definition))
1999 ;;; {Standard methods used by the C runtime}
2002 ;;; Methods to compare objects
2005 ;; Have to do this in a strange order because equal? is used in the
2006 ;; add-method! implementation; we need to make sure that when the
2007 ;; primitive is extended, that the generic has a method. =
2008 (define g-equal? (make-generic 'equal?))
2009 ;; When this generic gets called, we will have already checked eq? and
2010 ;; eqv? -- the purpose of this generic is to extend equality. So by
2011 ;; default, there is no extension, thus the #f return.
2012 (add-method! g-equal? (method (x y) #f))
2013 (set-primitive-generic! equal? g-equal?)
2016 ;;; methods to display/write an object
2019 ; Code for writing objects must test that the slots they use are
2020 ; bound. Otherwise a slot-unbound method will be called and will
2021 ; conduct to an infinite loop.
2024 (define (display-address o file)
2025 (display (number->string (object-address o) 16) file))
2027 (define-method (write o file)
2028 (display "#<instance " file)
2029 (display-address o file)
2032 (define write-object (primitive-generic-generic write))
2034 (define-method (write (o <object>) file)
2035 (let ((class (class-of o)))
2036 (if (slot-bound? class 'name)
2039 (display (class-name class) file)
2040 (display #\space file)
2041 (display-address o file)
2045 (define-method (write (class <class>) file)
2046 (let ((meta (class-of class)))
2047 (if (and (slot-bound? class 'name)
2048 (slot-bound? meta 'name))
2051 (display (class-name meta) file)
2052 (display #\space file)
2053 (display (class-name class) file)
2054 (display #\space file)
2055 (display-address class file)
2059 (define-method (write (gf <generic>) file)
2060 (let ((meta (class-of gf)))
2061 (if (and (slot-bound? meta 'name)
2062 (slot-bound? gf 'methods))
2065 (display (class-name meta) file)
2066 (let ((name (generic-function-name gf)))
2069 (display #\space file)
2070 (display name file))))
2072 (display (length (generic-function-methods gf)) file)
2073 (display ")>" file))
2076 (define-method (write (o <method>) file)
2077 (let ((meta (class-of o)))
2078 (if (and (slot-bound? meta 'name)
2079 (slot-bound? o 'specializers))
2082 (display (class-name meta) file)
2083 (display #\space file)
2084 (display (map* (lambda (spec)
2085 (if (slot-bound? spec 'name)
2086 (slot-ref spec 'name)
2088 (method-specializers o))
2090 (display #\space file)
2091 (display-address o file)
2095 ;; Display (do the same thing as write by default)
2096 (define-method (display o file)
2097 (write-object o file))
2100 ;;; Handling of duplicate bindings in the module system
2103 (define (find-subclass super name)
2104 (let lp ((classes (class-direct-subclasses super)))
2107 (error "class not found" name))
2108 ((and (slot-bound? (car classes) 'name)
2109 (eq? (class-name (car classes)) name))
2112 (lp (cdr classes))))))
2115 (define <module> (find-subclass <top> '<module>))
2117 (define-method (merge-generics (module <module>)
2127 (define-method (merge-generics (module <module>)
2135 (and (not (eq? val1 val2))
2136 (make-variable (make-extended-generic (list val2 val1) name))))
2138 (define-method (merge-generics (module <module>)
2145 (gf <extended-generic>))
2146 (and (not (memq val2 (slot-ref gf 'extends)))
2150 (cons val2 (delq! val2 (slot-ref gf 'extends))))
2153 (cons gf (delq! gf (slot-ref val2 'extended-by))))
2154 (invalidate-method-cache! gf)
2157 (module-define! duplicate-handlers 'merge-generics merge-generics)
2159 (define-method (merge-accessors (module <module>)
2169 (define-method (merge-accessors (module <module>)
2177 (merge-generics module name int1 val1 int2 val2 var val))
2179 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
2185 (define (class-slot-g-n-s class slot-name)
2186 (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
2187 (getters-n-setters (struct-ref class class-index-getters-n-setters))
2188 (g-n-s (cddr (or (assq slot-name getters-n-setters)
2189 (slot-missing class slot-name)))))
2190 (unless (memq (slot-definition-allocation this-slot)
2191 '(#:class #:each-subclass))
2192 (slot-missing class slot-name))
2195 (define (class-slot-ref class slot)
2196 (let ((x ((car (class-slot-g-n-s class slot)) #f)))
2198 (slot-unbound class slot)
2201 (define (class-slot-set! class slot value)
2202 ((cadr (class-slot-g-n-s class slot)) #f value))
2204 (define-method (slot-unbound (c <class>) (o <object>) s)
2205 (goops-error "Slot `~S' is unbound in object ~S" s o))
2207 (define-method (slot-unbound (c <class>) s)
2208 (goops-error "Slot `~S' is unbound in class ~S" s c))
2210 (define-method (slot-unbound (o <object>))
2211 (goops-error "Unbound slot in object ~S" o))
2213 (define-method (slot-missing (c <class>) (o <object>) s)
2214 (goops-error "No slot with name `~S' in object ~S" s o))
2216 (define-method (slot-missing (c <class>) s)
2217 (goops-error "No class slot with name `~S' in class ~S" s c))
2220 (define-method (slot-missing (c <class>) (o <object>) s value)
2221 (slot-missing c o s))
2223 ;;; Methods for the possible error we can encounter when calling a gf
2225 (define-method (no-next-method (gf <generic>) args)
2226 (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
2228 (define-method (no-applicable-method (gf <generic>) args)
2229 (goops-error "No applicable method for ~S in call ~S"
2230 gf (cons (generic-function-name gf) args)))
2232 (define-method (no-method (gf <generic>) args)
2233 (goops-error "No method defined for ~S" gf))
2236 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
2239 (define-method (shallow-clone (self <object>))
2240 (let* ((class (class-of self))
2241 (clone (%allocate-instance class))
2242 (slots (map slot-definition-name (class-slots class))))
2243 (for-each (lambda (slot)
2244 (when (slot-bound? self slot)
2245 (slot-set! clone slot (slot-ref self slot))))
2249 (define-method (deep-clone (self <object>))
2250 (let* ((class (class-of self))
2251 (clone (%allocate-instance class))
2252 (slots (map slot-definition-name (class-slots class))))
2253 (for-each (lambda (slot)
2254 (when (slot-bound? self slot)
2255 (slot-set! clone slot
2256 (let ((value (slot-ref self slot)))
2257 (if (instance? value)
2264 ;;; {Class redefinition utilities}
2267 ;;; (class-redefinition OLD NEW)
2270 ;;; Has correct the following conditions:
2274 ;;; 1. New accessor specializers refer to new header
2278 ;;; 1. New class cpl refers to the new class header
2279 ;;; 2. Old class header exists on old super classes direct-subclass lists
2280 ;;; 3. New class header exists on new super classes direct-subclass lists
2282 (define-method (class-redefinition (old <class>) (new <class>))
2283 ;; Work on direct methods:
2284 ;; 1. Remove accessor methods from the old class
2285 ;; 2. Patch the occurences of new in the specializers by old
2286 ;; 3. Displace the methods from old to new
2287 (remove-class-accessors! old) ;; -1-
2288 (let ((methods (class-direct-methods new)))
2289 (for-each (lambda (m)
2290 (update-direct-method! m new old)) ;; -2-
2293 class-index-direct-methods
2294 (append methods (class-direct-methods old))))
2296 ;; Substitute old for new in new cpl
2297 (set-car! (struct-ref new class-index-cpl) old)
2299 ;; Remove the old class from the direct-subclasses list of its super classes
2300 (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
2301 (delv! old (class-direct-subclasses c))))
2302 (class-direct-supers old))
2304 ;; Replace the new class with the old in the direct-subclasses of the supers
2305 (for-each (lambda (c)
2306 (struct-set! c class-index-direct-subclasses
2307 (cons old (delv! new (class-direct-subclasses c)))))
2308 (class-direct-supers new))
2310 ;; Swap object headers
2311 (%modify-class old new)
2315 ;; Redefine all the subclasses of old to take into account modification
2318 (update-direct-subclass! c new old))
2319 (class-direct-subclasses new))
2321 ;; Invalidate class so that subsequent instances slot accesses invoke
2322 ;; change-object-class
2323 (struct-set! new class-index-redefined old)
2324 (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set!
2329 ;;; remove-class-accessors!
2332 (define-method (remove-class-accessors! (c <class>))
2333 (for-each (lambda (m)
2334 (when (is-a? m <accessor-method>)
2335 (let ((gf (slot-ref m 'generic-function)))
2336 ;; remove the method from its GF
2337 (slot-set! gf 'methods
2338 (delq1! m (slot-ref gf 'methods)))
2339 (invalidate-method-cache! gf)
2340 ;; remove the method from its specializers
2341 (remove-method-in-classes! m))))
2342 (class-direct-methods c)))
2345 ;;; update-direct-method!
2348 (define-method (update-direct-method! (m <method>)
2351 (let loop ((l (method-specializers m)))
2352 ;; Note: the <top> in dotted list is never used.
2353 ;; So we can work as if we had only proper lists.
2355 (when (eqv? (car l) old)
2360 ;;; update-direct-subclass!
2363 (define-method (update-direct-subclass! (c <class>)
2366 (class-redefinition c
2367 (make-class (class-direct-supers c)
2368 (class-direct-slots c)
2369 #:name (class-name c)
2370 #:metaclass (class-of c))))
2373 ;;; {Utilities for INITIALIZE methods}
2376 ;;; compute-slot-accessors
2378 (define (compute-slot-accessors class slots)
2381 (let ((getter-function (slot-definition-getter s))
2382 (setter-function (slot-definition-setter s))
2383 (accessor (slot-definition-accessor s)))
2385 (add-method! getter-function
2386 (compute-getter-method class g-n-s)))
2388 (add-method! setter-function
2389 (compute-setter-method class g-n-s)))
2392 (add-method! accessor
2393 (compute-getter-method class g-n-s))
2394 (add-method! (setter accessor)
2395 (compute-setter-method class g-n-s))))))
2396 slots (struct-ref class class-index-getters-n-setters)))
2398 (define-method (compute-getter-method (class <class>) slotdef)
2399 (let ((init-thunk (cadr slotdef))
2400 (g-n-s (cddr slotdef)))
2401 (make <accessor-method>
2402 #:specializers (list class)
2403 #:procedure (cond ((pair? g-n-s)
2404 (make-generic-bound-check-getter (car g-n-s)))
2406 (standard-get g-n-s))
2408 (bound-check-get g-n-s)))
2409 #:slot-definition slotdef)))
2411 (define-method (compute-setter-method (class <class>) slotdef)
2412 (let ((g-n-s (cddr slotdef)))
2413 (make <accessor-method>
2414 #:specializers (list class <top>)
2415 #:procedure (if (pair? g-n-s)
2417 (standard-set g-n-s))
2418 #:slot-definition slotdef)))
2420 (define (make-generic-bound-check-getter proc)
2422 (let ((val (proc o)))
2427 ;;; Pre-generate getters and setters for the first 20 slots.
2428 (define-syntax define-standard-accessor-method
2430 (define num-standard-pre-cache 20)
2432 ((_ ((proc n) arg ...) body)
2434 (let ((cache (vector #,@(map (lambda (n*)
2438 (iota num-standard-pre-cache)))))
2440 (if (< n #,num-standard-pre-cache)
2441 (vector-ref cache n)
2442 (lambda (arg ...) body)))))))))
2444 (define-standard-accessor-method ((bound-check-get n) o)
2445 (let ((x (struct-ref o n)))
2450 (define-standard-accessor-method ((standard-get n) o)
2453 (define-standard-accessor-method ((standard-set n) o v)
2454 (struct-set! o n v))
2456 ;;; compute-getters-n-setters
2458 (define (compute-getters-n-setters class slots)
2460 (define (compute-slot-init-function name s)
2461 (or (let ((thunk (slot-definition-init-thunk s)))
2465 (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
2466 name class thunk))))
2467 (let ((init (slot-definition-init-value s)))
2468 (and (not (unbound? init))
2469 (lambda () init)))))
2471 (define (verify-accessors slot l)
2472 (cond ((integer? l))
2473 ((not (and (list? l) (= (length l) 2)))
2474 (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
2479 (unless (procedure? get)
2480 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
2482 (unless (procedure? set)
2483 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
2484 slot class set))))))
2487 ;; The strange treatment of nfields is due to backward compatibility.
2488 (let* ((index (slot-ref class 'nfields))
2489 (g-n-s (compute-get-n-set class s))
2490 (size (- (slot-ref class 'nfields) index))
2491 (name (slot-definition-name s)))
2492 ;; NOTE: The following is interdependent with C macros
2493 ;; defined above goops.c:scm_sys_prep_layout_x.
2495 ;; For simple instance slots, we have the simplest form
2496 ;; '(name init-function . index)
2497 ;; For other slots we have
2498 ;; '(name init-function getter setter . alloc)
2500 ;; '(index size) for instance allocated slots
2501 ;; '() for other slots
2502 (verify-accessors name g-n-s)
2503 (case (slot-definition-allocation s)
2504 ((#:each-subclass #:class)
2505 (unless (and (zero? size) (pair? g-n-s))
2506 (error "Class-allocated slots should not reserve fields"))
2507 ;; Don't initialize the slot; that's handled when the slot
2508 ;; is allocated, in compute-get-n-set.
2509 (cons name (cons #f g-n-s)))
2512 (cons (compute-slot-init-function name s)
2513 (if (or (integer? g-n-s)
2516 (append g-n-s (list index size)))))))))
2522 ;; Replace the bootstrap compute-cpl with this definition.
2524 (make <generic> #:name 'compute-cpl))
2526 (define-method (compute-cpl (class <class>))
2527 (compute-std-cpl class class-direct-supers))
2529 ;;; compute-get-n-set
2531 (define-method (compute-get-n-set (class <class>) s)
2532 (define (class-slot-init-value)
2533 (let ((thunk (slot-definition-init-thunk s)))
2536 (slot-definition-init-value s))))
2538 (case (slot-definition-allocation s)
2539 ((#:instance) ;; Instance slot
2540 ;; get-n-set is just its offset
2541 (let ((already-allocated (struct-ref class class-index-nfields)))
2542 (struct-set! class class-index-nfields (+ already-allocated 1))
2545 ((#:class) ;; Class slot
2546 ;; Class-slots accessors are implemented as 2 closures around
2547 ;; a Scheme variable. As instance slots, class slots must be
2548 ;; unbound at init time.
2549 (let ((name (slot-definition-name s)))
2550 (if (memq name (map slot-definition-name (class-direct-slots class)))
2551 ;; This slot is direct; create a new shared variable
2552 (make-closure-variable class (class-slot-init-value))
2553 ;; Slot is inherited. Find its definition in superclass
2554 (let loop ((l (cdr (class-precedence-list class))))
2555 (let ((r (assoc name
2557 class-index-getters-n-setters))))
2560 (loop (cdr l))))))))
2562 ((#:each-subclass) ;; slot shared by instances of direct subclass.
2563 ;; (Thomas Buerger, April 1998)
2564 (make-closure-variable class (class-slot-init-value)))
2566 ((#:virtual) ;; No allocation
2567 ;; slot-ref and slot-set! function must be given by the user
2568 (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
2569 (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
2570 (unless (and get set)
2571 (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" s))
2573 (else (next-method))))
2575 (define (make-closure-variable class value)
2576 (list (lambda (o) value)
2577 (lambda (o v) (set! value v))))
2579 (define-method (compute-get-n-set (o <object>) s)
2580 (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
2582 (define-method (compute-slots (class <class>))
2583 (build-slots-list (class-direct-slots class)
2584 (class-precedence-list class)))
2590 ;; FIXME: This could be much more efficient.
2591 (define (%initialize-object obj initargs)
2592 "Initialize the object @var{obj} with the given arguments
2594 (unless (instance? obj)
2595 (scm-error 'wrong-type-arg #f "Not an object: ~S"
2597 (unless (even? (length initargs))
2598 (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
2599 (list initargs) #f))
2600 (let ((class (class-of obj)))
2601 (define (get-initarg kw)
2603 (get-keyword kw initargs *unbound*)
2605 (let lp ((get-n-set (struct-ref class class-index-getters-n-setters))
2606 (slots (struct-ref class class-index-slots)))
2609 (((name . options) . slots)
2611 (((_ init-thunk . _) . get-n-set)
2612 (let ((initarg (get-initarg (get-keyword #:init-keyword options))))
2614 ((not (unbound? initarg))
2615 (slot-set! obj name initarg))
2617 (slot-set! obj name (init-thunk)))))
2618 (lp get-n-set slots))))))))
2620 (define-method (initialize (object <object>) initargs)
2621 (%initialize-object object initargs))
2623 (define-method (initialize (class <class>) initargs)
2625 (let ((dslots (get-keyword #:slots initargs '()))
2626 (supers (get-keyword #:dsupers initargs '())))
2627 (class-add-flags! class (logior vtable-flag-goops-class
2628 vtable-flag-goops-valid))
2629 (let ((name (get-keyword #:name initargs '???)))
2630 (struct-set! class class-index-name name))
2631 (struct-set! class class-index-nfields 0)
2632 (struct-set! class class-index-direct-supers supers)
2633 (struct-set! class class-index-direct-slots dslots)
2634 (struct-set! class class-index-direct-subclasses '())
2635 (struct-set! class class-index-direct-methods '())
2636 (struct-set! class class-index-cpl (compute-cpl class))
2637 (struct-set! class class-index-redefined #f)
2638 (let ((slots (compute-slots class)))
2639 (struct-set! class class-index-slots slots)
2640 (let ((getters-n-setters (compute-getters-n-setters class slots)))
2641 (struct-set! class class-index-getters-n-setters getters-n-setters))
2642 ;; Build getters - setters - accessors
2643 (compute-slot-accessors class slots))
2645 ;; Update the "direct-subclasses" of each inherited classes
2646 (for-each (lambda (x)
2647 (let ((dsubs (struct-ref x class-index-direct-subclasses)))
2648 (struct-set! x class-index-direct-subclasses
2649 (cons class dsubs))))
2652 ;; Compute struct layout of instances, set the `layout' slot, and
2653 ;; update class flags.
2654 (%prep-layout! class)))
2656 (define (initialize-object-procedure object initargs)
2657 (let ((proc (get-keyword #:procedure initargs #f)))
2660 (apply slot-set! object 'procedure proc))
2662 (slot-set! object 'procedure proc)))))
2664 (define-method (initialize (applicable-struct <applicable-struct>) initargs)
2666 (initialize-object-procedure applicable-struct initargs))
2668 (define-method (initialize (applicable-struct <applicable-struct-with-setter>)
2671 (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f)))
2673 (define-method (initialize (generic <generic>) initargs)
2674 (let ((previous-definition (get-keyword #:default initargs #f))
2675 (name (get-keyword #:name initargs #f)))
2677 (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
2679 (apply previous-definition args)))
2682 (set-procedure-property! generic 'name name))
2683 (invalidate-method-cache! generic)))
2685 (define-method (initialize (eg <extended-generic>) initargs)
2687 (slot-set! eg 'extends (get-keyword #:extends initargs '())))
2689 (define dummy-procedure (lambda args *unspecified*))
2691 (define-method (initialize (method <method>) initargs)
2693 (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
2694 (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
2695 (slot-set! method 'procedure
2696 (get-keyword #:procedure initargs #f))
2697 (slot-set! method 'formals (get-keyword #:formals initargs '()))
2698 (slot-set! method 'body (get-keyword #:body initargs '()))
2699 (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
2706 (define (change-object-class old-instance old-class new-class)
2707 (let ((new-instance (allocate-instance new-class '())))
2708 ;; Initialize the slots of the new instance
2711 (if (and (slot-exists? old-instance slot)
2712 (eq? (slot-definition-allocation
2713 (class-slot-definition old-class slot))
2715 (slot-bound? old-instance slot))
2716 ;; Slot was present and allocated in old instance; copy it
2717 (slot-set! new-instance slot (slot-ref old-instance slot))
2718 ;; slot was absent; initialize it with its default value
2719 (let ((init (slot-init-function new-class slot)))
2721 (slot-set! new-instance slot (init))))))
2722 (map slot-definition-name (class-slots new-class)))
2723 ;; Exchange old and new instance in place to keep pointers valid
2724 (%modify-instance old-instance new-instance)
2725 ;; Allow class specific updates of instances (which now are swapped)
2726 (update-instance-for-different-class new-instance old-instance)
2730 (define-method (update-instance-for-different-class (old-instance <object>)
2733 ;;not really important what we do, we just need a default method
2736 (define-method (change-class (old-instance <object>) (new-class <class>))
2737 (change-object-class old-instance (class-of old-instance) new-class))
2742 ;;; A new definition which overwrites the previous one which was built-in
2745 (define-method (allocate-instance (class <class>) initargs)
2746 (%allocate-instance class))
2748 (define-method (make-instance (class <class>) . initargs)
2749 (let ((instance (allocate-instance class initargs)))
2750 (initialize instance initargs)
2753 (define make make-instance)
2758 ;;; Protocol for calling generic functions, intended to be used when
2759 ;;; applying subclasses of <generic> and <generic-with-setter>. The
2760 ;;; code below is similar to the first MOP described in AMOP.
2762 ;;; Note that standard generic functions dispatch only on the classes of
2763 ;;; the arguments, and the result of such dispatch can be memoized. The
2764 ;;; `cache-dispatch' routine implements this. `apply-generic' isn't
2765 ;;; called currently; the generic function MOP was never fully
2766 ;;; implemented in GOOPS. However now that GOOPS is implemented
2767 ;;; entirely in Scheme (2015) it's much easier to complete this work.
2768 ;;; Contributions gladly accepted! Please read the AMOP first though :)
2770 ;;; The protocol is:
2772 ;;; + apply-generic (gf args)
2773 ;;; + compute-applicable-methods (gf args ...)
2774 ;;; + sort-applicable-methods (gf methods args)
2775 ;;; + apply-methods (gf methods args)
2777 ;;; apply-methods calls make-next-method to build the "continuation" of
2778 ;;; a method. Applying a next-method will call apply-next-method which
2779 ;;; in turn will call apply again to call effectively the following
2780 ;;; method. (This paragraph is out of date but is kept so that maybe it
2781 ;;; illuminates some future hack.)
2784 (define-method (apply-generic (gf <generic>) args)
2785 (when (null? (slot-ref gf 'methods))
2786 (no-method gf args))
2787 (let ((methods (compute-applicable-methods gf args)))
2789 (apply-methods gf (sort-applicable-methods gf methods args) args)
2790 (no-applicable-method gf args))))
2792 ;; compute-applicable-methods is bound to %compute-applicable-methods.
2794 (define %%compute-applicable-methods
2795 (make <generic> #:name 'compute-applicable-methods))
2797 (define-method (%%compute-applicable-methods (gf <generic>) args)
2798 (%compute-applicable-methods gf args))
2800 (set! compute-applicable-methods %%compute-applicable-methods)
2802 (define-method (sort-applicable-methods (gf <generic>) methods args)
2803 (%sort-applicable-methods methods (map class-of args)))
2805 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
2806 (%method-more-specific? m1 m2 targs))
2808 (define-method (apply-method (gf <generic>) methods build-next args)
2809 (apply (method-procedure (car methods))
2810 (build-next (cdr methods) args)
2813 (define-method (apply-methods (gf <generic>) (l <list>) args)
2814 (letrec ((next (lambda (procs args)
2816 (let ((a (if (null? new-args) args new-args)))
2818 (no-next-method gf a)
2819 (apply-method gf procs next a)))))))
2820 (apply-method gf l next args)))
2822 ;; We don't want the following procedure to turn up in backtraces:
2823 (for-each (lambda (proc)
2824 (set-procedure-property! proc 'system-procedure #t))
2828 no-applicable-method
2833 ;;; {Final initialization}
2836 ;; Tell C code that the main bulk of Goops has been loaded
2843 ;;; {SMOB and port classes}
2846 (define <arbiter> (find-subclass <top> '<arbiter>))
2847 (define <promise> (find-subclass <top> '<promise>))
2848 (define <thread> (find-subclass <top> '<thread>))
2849 (define <mutex> (find-subclass <top> '<mutex>))
2850 (define <condition-variable> (find-subclass <top> '<condition-variable>))
2851 (define <regexp> (find-subclass <top> '<regexp>))
2852 (define <hook> (find-subclass <top> '<hook>))
2853 (define <bitvector> (find-subclass <top> '<bitvector>))
2854 (define <random-state> (find-subclass <top> '<random-state>))
2855 (define <async> (find-subclass <top> '<async>))
2856 (define <directory> (find-subclass <top> '<directory>))
2857 (define <array> (find-subclass <top> '<array>))
2858 (define <character-set> (find-subclass <top> '<character-set>))
2859 (define <dynamic-object> (find-subclass <top> '<dynamic-object>))
2860 (define <guardian> (find-subclass <applicable> '<guardian>))
2861 (define <macro> (find-subclass <top> '<macro>))
2863 (define (define-class-subtree class)
2864 (define! (class-name class) class)
2865 (for-each define-class-subtree (class-direct-subclasses class)))
2867 (define-class-subtree (find-subclass <port> '<file-port>))