+\f
+
+;;;
+;;; We then define the slots that must appear in all classes (<class>
+;;; objects) and slot definitions (<slot> objects). These slots must
+;;; appear in order. We'll use this list to statically compute offsets
+;;; for the various fields, to compute the struct layout for <class>
+;;; instances, and to compute the slot definition lists for <class>.
+;;; Because the list is needed at expansion-time, we define it as a
+;;; macro.
+;;;
+(define-syntax macro-fold-left
+ (syntax-rules ()
+ ((_ folder seed ()) seed)
+ ((_ folder seed (head . tail))
+ (macro-fold-left folder (folder head seed) tail))))
+
+(define-syntax macro-fold-right
+ (syntax-rules ()
+ ((_ folder seed ()) seed)
+ ((_ folder seed (head . tail))
+ (folder head (macro-fold-right folder seed tail)))))
+
+(define-syntax-rule (define-macro-folder macro-folder value ...)
+ (define-syntax macro-folder
+ (lambda (x)
+ (syntax-case x ()
+ ((_ fold visit seed)
+ ;; The datum->syntax makes it as if each `value' were present
+ ;; in the initial form, which allows them to be used as
+ ;; (components of) introduced identifiers.
+ #`(fold visit seed #,(datum->syntax #'visit '(value ...))))))))
+
+(define-macro-folder fold-class-slots
+ (layout #:class <protected-read-only-slot>)
+ (flags #:class <hidden-slot>)
+ (self #:class <self-slot>)
+ (instance-finalizer #:class <hidden-slot>)
+ (print)
+ (name #:class <protected-hidden-slot>)
+ (nfields #:class <hidden-slot>)
+ (%reserved #:class <hidden-slot>)
+ (redefined)
+ (direct-supers)
+ (direct-slots)
+ (direct-subclasses)
+ (direct-methods)
+ (cpl)
+ (slots))
+
+(define-macro-folder fold-slot-slots
+ (name #:init-keyword #:name)
+ (allocation #:init-keyword #:allocation #:init-value #:instance)
+ (init-keyword #:init-keyword #:init-keyword #:init-value #f)
+ (init-form #:init-keyword #:init-form)
+ (init-value #:init-keyword #:init-value)
+ (init-thunk #:init-keyword #:init-thunk #:init-value #f)
+ (options)
+ (getter #:init-keyword #:getter #:init-value #f)
+ (setter #:init-keyword #:setter #:init-value #f)
+ (accessor #:init-keyword #:accessor #:init-value #f)
+ ;; These last don't have #:init-keyword because they are meant to be
+ ;; set by `allocate-slots', not in compute-effective-slot-definition.
+ (slot-ref #:init-value #f)
+ (slot-set! #:init-value #f)
+ (index #:init-value #f)
+ (size #:init-value #f))
+
+;;;
+;;; Statically define variables for slot offsets: `class-index-layout'
+;;; will be 0, `class-index-flags' will be 1, and so on, and the same
+;;; for `slot-index-name' and such for <slot>.
+;;;
+(let-syntax ((define-slot-indexer
+ (syntax-rules ()
+ ((_ define-index prefix)
+ (define-syntax define-index
+ (lambda (x)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a)
+ (syntax->datum b))))
+ (define (tail-length tail)
+ (syntax-case tail ()
+ ((begin) 0)
+ ((visit head tail) (1+ (tail-length #'tail)))))
+ (syntax-case x ()
+ ((_ (name . _) tail)
+ #`(begin
+ (define-syntax #,(id-append #'name #'prefix #'name)
+ (identifier-syntax #,(tail-length #'tail)))
+ tail)))))))))
+ (define-slot-indexer define-class-index class-index-)
+ (define-slot-indexer define-slot-index slot-index-)
+ (fold-class-slots macro-fold-left define-class-index (begin))
+ (fold-slot-slots macro-fold-left define-slot-index (begin)))
+
+;;;
+;;; Structs that are vtables have a "flags" slot, which corresponds to
+;;; class-index-flags. `vtable-flag-vtable' indicates that instances of
+;;; a vtable are themselves vtables, and `vtable-flag-validated'
+;;; indicates that the struct's layout has been validated. goops.c
+;;; defines a few additional flags: one to indicate that a vtable is
+;;; actually a class, one to indicate that the class is "valid" (meaning
+;;; that it hasn't been redefined), and one to indicate that instances
+;;; of a class are slot definition objects (<slot> instances).
+;;;
+(define vtable-flag-goops-metaclass
+ (logior vtable-flag-vtable vtable-flag-goops-class))
+
+(define-inlinable (class-add-flags! class flags)
+ (struct-set! class class-index-flags
+ (logior flags (struct-ref class class-index-flags))))
+
+(define-inlinable (class-clear-flags! class flags)
+ (struct-set! class class-index-flags
+ (logand (lognot flags) (struct-ref class class-index-flags))))
+
+(define-inlinable (class-has-flags? class flags)
+ (eqv? flags
+ (logand (struct-ref class class-index-flags) flags)))
+
+(define-inlinable (class? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
+
+(define-inlinable (slot? obj)
+ (and (struct? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
+
+(define-inlinable (instance? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
+
+;;;
+;;; Now that we know the slots that must be present in classes, and
+;;; their offsets, we can create the root of the class hierarchy.
+;;;
+;;; Note that the `direct-supers', `direct-slots', `cpl', and `slots'
+;;; fields will be updated later, once we can create slot definition
+;;; objects and once we have definitions for <top> and <object>.
+;;;
+(define <class>
+ (let-syntax ((cons-layout
+ ;; A simple way to compute class layout for the concrete
+ ;; types used in <class>.
+ (syntax-rules (<protected-read-only-slot>
+ <self-slot>
+ <hidden-slot>
+ <protected-hidden-slot>)
+ ((_ (name) tail)
+ (string-append "pw" tail))
+ ((_ (name #:class <protected-read-only-slot>) tail)
+ (string-append "pr" tail))
+ ((_ (name #:class <self-slot>) tail)
+ (string-append "sr" tail))
+ ((_ (name #:class <hidden-slot>) tail)
+ (string-append "uh" tail))
+ ((_ (name #:class <protected-hidden-slot>) tail)
+ (string-append "ph" tail)))))
+ (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
+ (nfields (/ (string-length layout) 2))
+ (<class> (%make-vtable-vtable layout)))
+ (class-add-flags! <class> (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
+ (struct-set! <class> class-index-name '<class>)
+ (struct-set! <class> class-index-nfields nfields)
+ (struct-set! <class> class-index-direct-supers '())
+ (struct-set! <class> class-index-direct-slots '())
+ (struct-set! <class> class-index-direct-subclasses '())
+ (struct-set! <class> class-index-direct-methods '())
+ (struct-set! <class> class-index-cpl '())
+ (struct-set! <class> class-index-slots '())
+ (struct-set! <class> class-index-redefined #f)
+ <class>)))
+
+;;;
+;;; Accessors to fields of <class>.
+;;;
+(define-syntax-rule (define-class-accessor name docstring field)
+ (define (name obj)
+ docstring
+ (let ((val obj))
+ (unless (class? val)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S"
+ (list val) #f))
+ (struct-ref val field))))
+
+(define-class-accessor class-name
+ "Return the class name of @var{obj}."
+ class-index-name)
+(define-class-accessor class-direct-supers
+ "Return the direct superclasses of the class @var{obj}."
+ class-index-direct-supers)
+(define-class-accessor class-direct-slots
+ "Return the direct slots of the class @var{obj}."
+ class-index-direct-slots)
+(define-class-accessor class-direct-subclasses
+ "Return the direct subclasses of the class @var{obj}."
+ class-index-direct-subclasses)
+(define-class-accessor class-direct-methods
+ "Return the direct methods of the class @var{obj}."
+ class-index-direct-methods)
+(define-class-accessor class-precedence-list
+ "Return the class precedence list of the class @var{obj}."
+ class-index-cpl)
+(define-class-accessor class-slots
+ "Return the slot list of the class @var{obj}."
+ class-index-slots)
+
+(define (class-subclasses c)
+ "Compute a list of all subclasses of @var{c}, direct and indirect."
+ (define (all-subclasses c)
+ (cons c (append-map all-subclasses
+ (class-direct-subclasses c))))
+ (delete-duplicates (cdr (all-subclasses c)) eq?))
+
+(define (class-methods c)
+ "Compute a list of all methods that specialize on @var{c} or
+subclasses of @var{c}."
+ (delete-duplicates (append-map class-direct-methods
+ (cons c (class-subclasses c)))
+ eq?))
+
+(define (is-a? obj class)
+ "Return @code{#t} if @var{obj} is an instance of @var{class}, or
+@code{#f} otherwise."
+ (and (memq class (class-precedence-list (class-of obj))) #t))
+
+
+\f
+
+;;;
+;;; At this point, <class> is missing slot definitions, but we can't
+;;; create slot definitions until we have a slot definition class.
+;;; Continue with manual object creation until we're able to bootstrap
+;;; more of the protocol. Again, the CPL and class hierarchy slots
+;;; remain uninitialized.
+;;;
+(define* (get-keyword key l #:optional default)
+ "Determine an associated value for the keyword @var{key} from the list
+@var{l}. The list @var{l} has to consist of an even number of elements,
+where, starting with the first, every second element is a keyword,
+followed by its associated value. If @var{l} does not hold a value for
+@var{key}, the value @var{default} is returned."
+ (unless (keyword? key)
+ (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
+ (let lp ((l l))
+ (match l
+ (() default)
+ ((kw arg . l)
+ (unless (keyword? kw)
+ (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
+ (if (eq? kw key) arg (lp l))))))
+
+(define *unbound* (list 'unbound))
+
+(define-inlinable (unbound? x)
+ (eq? x *unbound*))
+
+(define (%allocate-instance class)
+ (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
+ (%clear-fields! obj *unbound*)
+ obj))
+
+(define <slot>
+ (let-syntax ((cons-layout
+ ;; All slots are "pw" in <slot>.
+ (syntax-rules ()
+ ((_ _ tail) (string-append "pw" tail)))))
+ (let* ((layout (fold-slot-slots macro-fold-right cons-layout ""))
+ (nfields (/ (string-length layout) 2))
+ (<slot> (make-struct/no-tail <class> (make-struct-layout layout))))
+ (class-add-flags! <slot> (logior vtable-flag-goops-class
+ vtable-flag-goops-slot
+ vtable-flag-goops-valid))
+ (struct-set! <slot> class-index-name '<slot>)
+ (struct-set! <slot> class-index-nfields nfields)
+ (struct-set! <slot> class-index-direct-supers '())
+ (struct-set! <slot> class-index-direct-slots '())
+ (struct-set! <slot> class-index-direct-subclasses '())
+ (struct-set! <slot> class-index-direct-methods '())
+ (struct-set! <slot> class-index-cpl (list <slot>))
+ (struct-set! <slot> class-index-slots '())
+ (struct-set! <slot> class-index-redefined #f)
+ <slot>)))
+
+;;; Access to slot objects is performance-sensitive for slot-ref, so in
+;;; addition to the type-checking accessors that we export, we also
+;;; define some internal inlined helpers that just do an unchecked
+;;; struct-ref in cases where we know the object must be a slot, as
+;;; when accessing class-slots.
+;;;
+(define-syntax-rule (define-slot-accessor name docstring %name field)
+ (begin
+ (define-syntax-rule (%name obj)
+ (struct-ref obj field))
+ (define (name obj)
+ docstring
+ (unless (slot? obj)
+ (scm-error 'wrong-type-arg #f "Not a slot: ~S"
+ (list obj) #f))
+ (%name obj))))
+
+(define-slot-accessor slot-definition-name
+ "Return the name of @var{obj}."
+ %slot-definition-name slot-index-name)
+(define-slot-accessor slot-definition-allocation
+ "Return the allocation of the slot @var{obj}."
+ %slot-definition-allocation slot-index-allocation)
+(define-slot-accessor slot-definition-init-keyword
+ "Return the init keyword of the slot @var{obj}, or @code{#f}."
+ %slot-definition-init-keyword slot-index-init-keyword)
+(define-slot-accessor slot-definition-init-form
+ "Return the init form of the slot @var{obj}, or the unbound value"
+ %slot-definition-init-form slot-index-init-form)
+(define-slot-accessor slot-definition-init-value
+ "Return the init value of the slot @var{obj}, or the unbound value."
+ %slot-definition-init-value slot-index-init-value)
+(define-slot-accessor slot-definition-init-thunk
+ "Return the init thunk of the slot @var{obj}, or @code{#f}."
+ %slot-definition-init-thunk slot-index-init-thunk)
+(define-slot-accessor slot-definition-options
+ "Return the initargs given when creating the slot @var{obj}."
+ %slot-definition-options slot-index-options)
+(define-slot-accessor slot-definition-getter
+ "Return the getter of the slot @var{obj}, or @code{#f}."
+ %slot-definition-getter slot-index-getter)
+(define-slot-accessor slot-definition-setter
+ "Return the setter of the slot @var{obj}, or @code{#f}."
+ %slot-definition-setter slot-index-setter)
+(define-slot-accessor slot-definition-accessor
+ "Return the accessor of the slot @var{obj}, or @code{#f}."
+ %slot-definition-accessor slot-index-accessor)
+(define-slot-accessor slot-definition-slot-ref
+ "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}."
+ %slot-definition-slot-ref slot-index-slot-ref)
+(define-slot-accessor slot-definition-slot-set!
+ "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}."
+ %slot-definition-slot-set! slot-index-slot-set!)
+(define-slot-accessor slot-definition-index
+ "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."
+ %slot-definition-index slot-index-index)
+(define-slot-accessor slot-definition-size
+ "Return the number fields used by the slot @var{obj}, or @code{#f}."
+ %slot-definition-size slot-index-size)
+
+;; Boot definition.
+(define (direct-slot-definition-class class initargs)
+ (get-keyword #:class initargs <slot>))
+
+;; Boot definition.
+(define (make-slot class initargs)
+ (let ((slot (make-struct/no-tail class)))
+ (define-syntax-rule (init-slot offset kw default)
+ (struct-set! slot offset (get-keyword kw initargs default)))
+ (init-slot slot-index-name #:name #f)
+ (init-slot slot-index-allocation #:allocation #:instance)
+ (init-slot slot-index-init-keyword #:init-keyword #f)
+ (init-slot slot-index-init-form #:init-form *unbound*)
+ (init-slot slot-index-init-value #:init-value *unbound*)
+ (struct-set! slot slot-index-init-thunk
+ (or (get-keyword #:init-thunk initargs #f)
+ (let ((val (%slot-definition-init-value slot)))
+ (if (unbound? val)
+ #f
+ (lambda () val)))))
+ (struct-set! slot slot-index-options initargs)
+ (init-slot slot-index-getter #:getter #f)
+ (init-slot slot-index-setter #:setter #f)
+ (init-slot slot-index-accessor #:accessor #f)
+ (init-slot slot-index-slot-ref #:slot-ref #f)
+ (init-slot slot-index-slot-set! #:slot-set! #f)
+ (init-slot slot-index-index #:index #f)
+ (init-slot slot-index-size #:size #f)
+ slot))
+
+;; Boot definition.
+(define (make class . args)
+ (unless (memq <slot> (class-precedence-list class))
+ (error "Unsupported class: ~S" class))
+ (make-slot class args))
+
+;; Boot definition.
+(define (compute-direct-slot-definition class initargs)
+ (apply make (direct-slot-definition-class class initargs) initargs))
+
+(define (compute-direct-slot-definition-initargs class slot-spec)
+ (match slot-spec
+ ((? symbol? name) (list #:name name))
+ (((? symbol? name) . initargs)
+ (cons* #:name name
+ ;; If there is an #:init-form, the `class' macro will have
+ ;; already added an #:init-thunk. Still, if there isn't an
+ ;; #:init-thunk already but we do have an #:init-value,
+ ;; synthesize an #:init-thunk initarg. This will ensure
+ ;; that the #:init-thunk gets passed on to the effective
+ ;; slot definition too.
+ (if (get-keyword #:init-thunk initargs)
+ initargs
+ (let ((value (get-keyword #:init-value initargs *unbound*)))
+ (if (unbound? value)
+ initargs
+ (cons* #:init-thunk (lambda () value) initargs))))))))
+
+(let ()
+ (define-syntax cons-slot
+ (syntax-rules ()
+ ((_ (name #:class class) tail)
+ ;; Special case to avoid referencing specialized <slot> kinds,
+ ;; which are not defined yet.
+ (cons (list 'name) tail))
+ ((_ (name . initargs) tail)
+ (cons (list 'name . initargs) tail))))
+ (define-syntax-rule (initialize-direct-slots! class fold-slots)
+ (let ((specs (fold-slots macro-fold-right cons-slot '())))
+ (define (make-direct-slot-definition spec)
+ (let ((initargs (compute-direct-slot-definition-initargs class spec)))
+ (compute-direct-slot-definition class initargs)))
+ (struct-set! class class-index-direct-slots
+ (map make-direct-slot-definition specs))))
+
+ (initialize-direct-slots! <class> fold-class-slots)
+ (initialize-direct-slots! <slot> fold-slot-slots))
+
+
+\f
+
+;;;
+;;; OK, at this point we have initialized `direct-slots' on both <class>
+;;; and <slot>. We need to define a standard way to make subclasses:
+;;; how to compute the precedence list of subclasses, how to compute the
+;;; list of slots in a subclass, and what layout to use for instances of
+;;; those classes.
+;;;
+(define (compute-std-cpl c get-direct-supers)
+ "The standard class precedence list computation algorithm."
+ (define (only-non-null lst)
+ (filter (lambda (l) (not (null? l))) lst))
+
+ (define (merge-lists reversed-partial-result inputs)
+ (cond
+ ((every null? inputs)
+ (reverse! reversed-partial-result))
+ (else
+ (let* ((candidate (lambda (c)
+ (and (not (any (lambda (l)
+ (memq c (cdr l)))
+ inputs))
+ c)))
+ (candidate-car (lambda (l)
+ (and (not (null? l))
+ (candidate (car l)))))
+ (next (any candidate-car inputs)))
+ (unless next
+ (goops-error "merge-lists: Inconsistent precedence graph"))
+ (let ((remove-next (lambda (l)
+ (if (eq? (car l) next)
+ (cdr l)
+ l))))
+ (merge-lists (cons next reversed-partial-result)
+ (only-non-null (map remove-next inputs))))))))
+ (let ((c-direct-supers (get-direct-supers c)))
+ (merge-lists (list c)
+ (only-non-null (append (map class-precedence-list
+ c-direct-supers)
+ (list c-direct-supers))))))
+
+;; This version of compute-cpl is replaced with a generic function once
+;; GOOPS has booted.
+(define (compute-cpl class)
+ (compute-std-cpl class class-direct-supers))
+
+(define (effective-slot-definition-class class slot)
+ (class-of slot))
+
+(define (compute-effective-slot-definition class slot)
+ ;; FIXME: Support slot being a list of slots, as in CLOS.
+ (apply make
+ (effective-slot-definition-class class slot)
+ (slot-definition-options slot)))
+
+(define (build-slots-list dslots cpl)
+ (define (slot-memq slot slots)
+ (let ((name (%slot-definition-name slot)))
+ (let lp ((slots slots))
+ (match slots
+ (() #f)
+ ((slot . slots)
+ (or (eq? (%slot-definition-name slot) name) (lp slots)))))))
+ (define (check-cpl slots static-slots)
+ (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
+ (scm-error 'misc-error #f
+ "a predefined static inherited field cannot be redefined"
+ '() '())))
+ (define (remove-duplicate-slots slots)
+ (let lp ((slots (reverse slots)) (res '()) (seen '()))
+ (match slots
+ (() res)
+ ((slot . slots)
+ (let ((name (%slot-definition-name slot)))
+ (if (memq name seen)
+ (lp slots res seen)
+ (lp slots (cons slot res) (cons name seen))))))))
+ ;; For subclases of <class> and <slot>, we need to ensure that the
+ ;; <class> or <slot> slots come first.
+ (let* ((static-slots (cond
+ ((memq <class> cpl)
+ (when (memq <slot> cpl) (error "invalid class"))
+ (struct-ref <class> class-index-slots))
+ ((memq <slot> cpl)
+ (struct-ref <slot> class-index-slots))
+ (else #f))))
+ (when static-slots
+ (check-cpl dslots static-slots))
+ (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
+ (match cpl
+ (() (remove-duplicate-slots (append static-slots res)))
+ ((head . cpl)
+ (let ((new-slots (struct-ref head class-index-direct-slots)))
+ (cond
+ ((not static-slots)
+ (lp cpl (append new-slots res) static-slots))
+ ((or (eq? head <class>) (eq? head <slot>))
+ ;; Move static slots to the head of the list.
+ (lp cpl res new-slots))
+ (else
+ (check-cpl new-slots static-slots)
+ (lp cpl (append new-slots res) static-slots)))))))))
+
+;; Boot definition.
+(define (compute-get-n-set class slot)
+ (let ((index (struct-ref class class-index-nfields)))
+ (struct-set! class class-index-nfields (1+ index))
+ index))
+
+(define (allocate-slots class slots)
+ "Transform the computed list of direct slot definitions @var{slots}
+into a corresponding list of effective slot definitions, allocating
+slots as we go."
+ (define (make-effective-slot-definition slot)
+ ;; `compute-get-n-set' is expected to mutate `nfields' if it
+ ;; allocates a field to the object. Pretty strange, but we preserve
+ ;; the behavior for backward compatibility.
+ (let* ((slot (compute-effective-slot-definition class slot))
+ (index (struct-ref class class-index-nfields))
+ (g-n-s (compute-get-n-set class slot))
+ (size (- (struct-ref class class-index-nfields) index)))
+ (call-with-values
+ (lambda ()
+ (match g-n-s
+ ((? integer?)
+ (unless (= size 1)
+ (error "unexpected return from compute-get-n-set"))
+ (values #f #f))
+ (((? procedure? get) (? procedure? set))
+ (values get set))))
+ (lambda (get set)
+ (struct-set! slot slot-index-index index)
+ (struct-set! slot slot-index-size size)
+ (struct-set! slot slot-index-slot-ref get)
+ (struct-set! slot slot-index-slot-set! set)))
+ slot))
+ (struct-set! class class-index-nfields 0)
+ (map-in-order make-effective-slot-definition slots))
+
+(define (%compute-layout slots nfields is-class?)
+ (define (slot-protection-and-kind slot)
+ (define (subclass? class parent)
+ (memq parent (class-precedence-list class)))
+ (let ((type (kw-arg-ref (%slot-definition-options slot) #:class)))
+ (if (and type (subclass? type <foreign-slot>))
+ (values (cond
+ ((subclass? type <self-slot>) #\s)
+ ((subclass? type <protected-slot>) #\p)
+ (else #\u))
+ (cond
+ ((subclass? type <opaque-slot>) #\o)
+ ((subclass? type <read-only-slot>) #\r)
+ ((subclass? type <hidden-slot>) #\h)
+ (else #\w)))
+ (values #\p #\w))))
+ (let ((layout (make-string (* nfields 2))))
+ (let lp ((n 0) (slots slots))
+ (match slots
+ (()
+ (unless (= n nfields) (error "bad nfields"))
+ (when is-class?
+ (let ((class-layout (struct-ref <class> class-index-layout)))
+ (unless (string-prefix? (symbol->string class-layout) layout)
+ (error "bad layout for class"))))
+ layout)
+ ((slot . slots)
+ (unless (= n (%slot-definition-index slot)) (error "bad allocation"))
+ (call-with-values (lambda () (slot-protection-and-kind slot))
+ (lambda (protection kind)
+ (let init ((n n) (size (%slot-definition-size slot)))
+ (cond
+ ((zero? size) (lp n slots))
+ (else
+ (unless (< n nfields) (error "bad nfields"))
+ (string-set! layout (* n 2) protection)
+ (string-set! layout (1+ (* n 2)) kind)
+ (init (1+ n) (1- size))))))))))))
+
+
+\f
+
+;;;
+;;; With all of this, we are now able to define subclasses of <class>.
+;;;
+(define (%prep-layout! class)
+ (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
+ (layout (%compute-layout (struct-ref class class-index-slots)
+ (struct-ref class class-index-nfields)
+ is-class?)))
+ (%init-layout! class layout)))
+
+(define (make-standard-class class name dsupers dslots)
+ (let ((z (make-struct/no-tail class)))
+ (define (make-direct-slot-definition dslot)
+ (let ((initargs (compute-direct-slot-definition-initargs z dslot)))
+ (compute-direct-slot-definition z initargs)))
+
+ (struct-set! z class-index-name name)
+ (struct-set! z class-index-nfields 0)
+ (struct-set! z class-index-direct-supers dsupers)
+ (struct-set! z class-index-direct-subclasses '())
+ (struct-set! z class-index-direct-methods '())
+ (struct-set! z class-index-redefined #f)
+ (let ((cpl (compute-cpl z)))
+ (struct-set! z class-index-cpl cpl)
+ (when (memq <slot> cpl)
+ (class-add-flags! z vtable-flag-goops-slot))
+ (let* ((dslots (map make-direct-slot-definition dslots))
+ (slots (allocate-slots z (build-slots-list dslots cpl))))
+ (struct-set! z class-index-direct-slots dslots)
+ (struct-set! z class-index-slots slots)))
+ (for-each
+ (lambda (super)
+ (let ((subclasses (struct-ref super class-index-direct-subclasses)))
+ (struct-set! super class-index-direct-subclasses
+ (cons z subclasses))))
+ dsupers)
+ (%prep-layout! z)
+ z))
+
+(define-syntax define-standard-class
+ (syntax-rules ()
+ ((define-standard-class name (super ...) #:metaclass meta slot ...)
+ (define name
+ (make-standard-class meta 'name (list super ...) '(slot ...))))
+ ((define-standard-class name (super ...) slot ...)
+ (define-standard-class name (super ...) #:metaclass <class> slot ...))))
+
+
+\f
+
+;;;
+;;; Sweet! Now we can define <top> and <object>, and finish
+;;; initializing the `direct-subclasses', `direct-supers', and `cpl'
+;;; slots of <class>.
+;;;
+(define-standard-class <top> ())
+(define-standard-class <object> (<top>))
+
+;; The inheritance links for <top>, <object>, <class>, and <slot> were
+;; partially initialized. Correct them here.
+(struct-set! <object> class-index-direct-subclasses (list <slot> <class>))
+(struct-set! <class> class-index-direct-supers (list <object>))
+(struct-set! <slot> class-index-direct-supers (list <object>))
+(struct-set! <class> class-index-cpl (list <class> <object> <top>))
+(struct-set! <slot> class-index-cpl (list <slot> <object> <top>))
+
+
+\f
+
+;;;
+;;; We can also define the various slot types, and finish initializing
+;;; `direct-slots' and `slots' on <class> and <slot>.
+;;;
+(define-standard-class <foreign-slot> (<slot>))
+(define-standard-class <protected-slot> (<foreign-slot>))
+(define-standard-class <hidden-slot> (<foreign-slot>))
+(define-standard-class <opaque-slot> (<foreign-slot>))
+(define-standard-class <read-only-slot> (<foreign-slot>))
+(define-standard-class <self-slot> (<read-only-slot>))
+(define-standard-class <protected-opaque-slot> (<protected-slot>
+ <opaque-slot>))
+(define-standard-class <protected-hidden-slot> (<protected-slot>
+ <hidden-slot>))
+(define-standard-class <protected-read-only-slot> (<protected-slot>
+ <read-only-slot>))
+(define-standard-class <scm-slot> (<protected-slot>))
+(define-standard-class <int-slot> (<foreign-slot>))
+(define-standard-class <float-slot> (<foreign-slot>))
+(define-standard-class <double-slot> (<foreign-slot>))
+
+
+\f
+
+;;;
+;;; Finally! Initialize `direct-slots' and `slots' on <class>, and
+;;; `slots' on <slot>.
+;;;
+(let ()
+ (define-syntax-rule (cons-slot (name . initargs) tail)
+ (cons (list 'name . initargs) tail))
+ (define-syntax-rule (initialize-direct-slots! class fold-slots)
+ (let ((specs (fold-slots macro-fold-right cons-slot '())))
+ (define (make-direct-slot-definition spec)
+ (let ((initargs (compute-direct-slot-definition-initargs class spec)))
+ (compute-direct-slot-definition class initargs)))
+ (struct-set! class class-index-direct-slots
+ (map make-direct-slot-definition specs))))
+ (define (initialize-slots! class)
+ (let ((slots (build-slots-list (class-direct-slots class)
+ (class-precedence-list class))))
+ (struct-set! class class-index-slots (allocate-slots class slots))))
+
+ ;; Finish initializing <class> with the specialized slot kinds.
+ (initialize-direct-slots! <class> fold-class-slots)
+
+ (initialize-slots! <class>)
+ (initialize-slots! <slot>))
+
+
+\f
+
+;;;
+;;; Now, to build out the class hierarchy.
+;;;
+
+(define-standard-class <procedure-class> (<class>))
+
+(define-standard-class <applicable-struct-class>
+ (<procedure-class>))
+(class-add-flags! <applicable-struct-class>
+ vtable-flag-applicable-vtable)
+
+(define-standard-class <applicable-struct-with-setter-class>
+ (<applicable-struct-class>))
+(class-add-flags! <applicable-struct-with-setter-class>
+ vtable-flag-setter-vtable)
+
+(define-standard-class <applicable> (<top>))
+(define-standard-class <applicable-struct> (<object> <applicable>)
+ #:metaclass <applicable-struct-class>
+ procedure)
+(define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
+ #:metaclass <applicable-struct-with-setter-class>
+ setter)
+(define-standard-class <generic> (<applicable-struct>)
+ #:metaclass <applicable-struct-class>
+ methods
+ (n-specialized #:init-value 0)
+ (extended-by #:init-value ())
+ effective-methods)
+(define-standard-class <extended-generic> (<generic>)
+ #:metaclass <applicable-struct-class>
+ (extends #:init-value ()))
+(define-standard-class <generic-with-setter> (<generic>
+ <applicable-struct-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+(define-standard-class <accessor> (<generic-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+(define-standard-class <extended-generic-with-setter> (<extended-generic>
+ <generic-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+(define-standard-class <extended-accessor> (<accessor>
+ <extended-generic-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+
+(define-standard-class <method> (<object>)
+ generic-function
+ specializers
+ procedure
+ formals
+ body
+ make-procedure)
+(define-standard-class <accessor-method> (<method>)
+ (slot-definition #:init-keyword #:slot-definition))
+
+(define-standard-class <boolean> (<top>))
+(define-standard-class <char> (<top>))
+(define-standard-class <list> (<top>))
+(define-standard-class <pair> (<list>))
+(define-standard-class <null> (<list>))
+(define-standard-class <string> (<top>))
+(define-standard-class <symbol> (<top>))
+(define-standard-class <vector> (<top>))
+(define-standard-class <foreign> (<top>))
+(define-standard-class <hashtable> (<top>))
+(define-standard-class <fluid> (<top>))
+(define-standard-class <dynamic-state> (<top>))
+(define-standard-class <frame> (<top>))
+(define-standard-class <vm-continuation> (<top>))
+(define-standard-class <bytevector> (<top>))
+(define-standard-class <uvec> (<bytevector>))
+(define-standard-class <array> (<top>))
+(define-standard-class <bitvector> (<top>))
+(define-standard-class <number> (<top>))
+(define-standard-class <complex> (<number>))
+(define-standard-class <real> (<complex>))
+(define-standard-class <integer> (<real>))
+(define-standard-class <fraction> (<real>))
+(define-standard-class <keyword> (<top>))
+(define-standard-class <unknown> (<top>))
+(define-standard-class <procedure> (<applicable>)
+ #:metaclass <procedure-class>)
+(define-standard-class <primitive-generic> (<procedure>)
+ #:metaclass <procedure-class>)
+(define-standard-class <port> (<top>))
+(define-standard-class <input-port> (<port>))
+(define-standard-class <output-port> (<port>))
+(define-standard-class <input-output-port> (<input-port> <output-port>))
+
+(define (inherit-applicable! class)
+ "An internal routine to redefine a SMOB class that was added after
+GOOPS was loaded, and on which scm_set_smob_apply installed an apply
+function."
+ ;; Why not use class-redefinition? We would, except that loading the
+ ;; compiler to compile effective methods can happen while GOOPS has
+ ;; only been partially loaded, and loading the compiler might cause
+ ;; SMOB types to be defined that need this facility. Instead we make
+ ;; a very specific hack, not a general solution. Probably the right
+ ;; solution is to avoid using the compiler, but that is another kettle
+ ;; of fish.
+ (unless (memq <applicable> (class-precedence-list class))
+ (unless (null? (class-slots class))
+ (error "SMOB object has slots?"))
+ (for-each
+ (lambda (super)
+ (let ((subclasses (struct-ref super class-index-direct-subclasses)))
+ (struct-set! super class-index-direct-subclasses
+ (delq class subclasses))))
+ (struct-ref class class-index-direct-supers))
+ (struct-set! class class-index-direct-supers (list <applicable>))
+ (struct-set! class class-index-cpl (compute-cpl class))
+ (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
+ (struct-set! <applicable> class-index-direct-subclasses
+ (cons class subclasses)))))
+
+
+\f
+
+;;;
+;;; At this point we have defined the class hierarchy, and it's time to
+;;; move on to instance allocation and generics. Once we have generics,
+;;; we'll fill out the metaobject protocol.
+;;;
+;;; Here we define a limited version of `make', so that we can allocate
+;;; instances of specific classes. This definition will be replaced
+;;; later.
+;;;
+(define (%invalidate-method-cache! gf)
+ (slot-set! gf 'procedure (delayed-compile gf))
+ (slot-set! gf 'effective-methods '()))
+
+;; Boot definition.
+(define (invalidate-method-cache! gf)
+ (%invalidate-method-cache! gf))
+
+(define (make class . args)
+ (cond
+ ((or (eq? class <generic>) (eq? class <accessor>))
+ (let ((z (make-struct/no-tail class #f '() 0 '())))
+ (set-procedure-property! z 'name (get-keyword #:name args #f))
+ (invalidate-method-cache! z)
+ (when (eq? class <accessor>)
+ (let ((setter (get-keyword #:setter args #f)))
+ (when setter
+ (slot-set! z 'setter setter))))
+ z))
+ (else
+ (let ((z (%allocate-instance class)))
+ (cond
+ ((or (eq? class <method>) (eq? class <accessor-method>))
+ (for-each (match-lambda
+ ((kw slot default)
+ (slot-set! z slot (get-keyword kw args default))))
+ '((#:generic-function generic-function #f)
+ (#:specializers specializers ())
+ (#:procedure procedure #f)
+ (#:formals formals ())
+ (#:body body ())
+ (#:make-procedure make-procedure #f))))
+ ((memq <class> (class-precedence-list class))
+ (class-add-flags! z (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
+ (for-each (match-lambda
+ ((kw slot default)
+ (slot-set! z slot (get-keyword kw args default))))
+ '((#:name name ???)
+ (#:dsupers direct-supers ())
+ (#:slots direct-slots ()))))
+ (else
+ (error "boot `make' does not support this class" class)))
+ z))))
+
+
+\f
+
+;;;
+;;; Slot access.
+;;;
+;;; Before we go on, some notes about class redefinition. In GOOPS,
+;;; classes can be redefined. Redefinition of a class marks the class
+;;; as invalid, and instances will be lazily migrated over to the new
+;;; representation as they are accessed. Migration happens when
+;;; `class-of' is called on an instance. For more technical details on
+;;; object redefinition, see struct.h.
+;;;
+;;; In the following interfaces, class-of handles the redefinition
+;;; protocol. I would think though that there is some thread-unsafety
+;;; here though as the { class, object data } pair needs to be accessed
+;;; atomically, not the { class, object } pair.
+;;;
+(define-inlinable (%class-slot-definition class slot-name kt kf)
+ (let lp ((slots (struct-ref class class-index-slots)))
+ (match slots
+ ((slot . slots)
+ (if (eq? (%slot-definition-name slot) slot-name)
+ (kt slot)
+ (lp slots)))
+ (_ (kf)))))
+
+(define (class-slot-definition class slot-name)
+ (unless (class? class)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f))
+ (%class-slot-definition class slot-name
+ (lambda (slot) slot)
+ (lambda () #f)))
+
+(define (slot-ref obj slot-name)
+ "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (let ((val (slot-value slot)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
+
+(define (slot-set! obj slot-name value)
+ "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
+ (let ((class (class-of obj)))
+ (define (have-slot slot)
+ (cond
+ ((%slot-definition-slot-set! slot)
+ => (lambda (slot-set!) (slot-set! obj value)))
+ (else
+ (struct-set! obj (%slot-definition-index slot) value))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (slot-missing class obj slot-name value))
+
+ (%class-slot-definition class slot-name have-slot no-slot)))
+
+(define (slot-bound? obj slot-name)
+ "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (not (unbound? (slot-value slot))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
+
+(define (slot-exists? obj slot-name)
+ "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
+ (define (have-slot slot) #t)
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ #f)
+ (%class-slot-definition (class-of obj) slot-name have-slot no-slot))
+
+(begin-deprecated
+ (define (check-slot-args class obj slot-name)
+ (unless (eq? class (class-of obj))
+ (scm-error 'wrong-type-arg #f "~S is not the class of ~S"
+ (list class obj) #f))
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f)))
+
+ (define (slot-ref-using-class class obj slot-name)
+ (issue-deprecation-warning "slot-ref-using-class is deprecated. "
+ "Use slot-ref instead.")
+ (check-slot-args class obj slot-name)
+ (slot-ref obj slot-name))
+
+ (define (slot-set-using-class! class obj slot-name value)
+ (issue-deprecation-warning "slot-set-using-class! is deprecated. "
+ "Use slot-set! instead.")
+ (check-slot-args class obj slot-name)
+ (slot-set! obj slot-name value))
+
+ (define (slot-bound-using-class? class obj slot-name)
+ (issue-deprecation-warning "slot-bound-using-class? is deprecated. "
+ "Use slot-bound? instead.")
+ (check-slot-args class obj slot-name)
+ (slot-bound? obj slot-name))
+
+ (define (slot-exists-using-class? class obj slot-name)
+ (issue-deprecation-warning "slot-exists-using-class? is deprecated. "
+ "Use slot-exists? instead.")
+ (check-slot-args class obj slot-name)
+ (slot-exists? obj slot-name)))
+
+
+\f
+
+;;;
+;;; Method accessors.
+;;;
+(define (method-generic-function obj)
+ "Return the generic function for the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'generic-function))
+
+(define (method-specializers obj)
+ "Return specializers of the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'specializers))
+
+(define (method-procedure obj)
+ "Return the procedure of the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'procedure))
+
+
+\f
+
+;;;
+;;; Generic functions!
+;;;
+(define *dispatch-module* (current-module))
+
+;;;
+;;; Generic functions have an applicable-methods cache associated with
+;;; them. Every distinct set of types that is dispatched through a
+;;; generic adds an entry to the cache. This cache gets compiled out to
+;;; a dispatch procedure. In steady-state, this dispatch procedure is
+;;; never recompiled; but during warm-up there is some churn, both to
+;;; the cache and to the dispatch procedure.
+;;;
+;;; So what is the deal if warm-up happens in a multithreaded context?
+;;; There is indeed a window between missing the cache for a certain set
+;;; of arguments, and then updating the cache with the newly computed
+;;; applicable methods. One of the updaters is liable to lose their new
+;;; entry.
+;;;
+;;; This is actually OK though, because a subsequent cache miss for the
+;;; race loser will just cause memoization to try again. The cache will
+;;; eventually be consistent. We're not mutating the old part of the
+;;; cache, just consing on the new entry.
+;;;
+;;; It doesn't even matter if the dispatch procedure and the cache are
+;;; inconsistent -- most likely the type-set that lost the dispatch
+;;; procedure race will simply re-trigger a memoization, but since the
+;;; winner isn't in the effective-methods cache, it will likely also
+;;; re-trigger a memoization, and the cache will finally be consistent.
+;;; As you can see there is a possibility for ping-pong effects, but
+;;; it's unlikely given the shortness of the window between slot-set!
+;;; invocations. We could add a mutex, but it is strictly unnecessary,
+;;; and would add runtime cost and complexity.
+;;;
+
+(define (emit-linear-dispatch gf-sym nargs methods free rest?)
+ (define (gen-syms n stem)
+ (let lp ((n (1- n)) (syms '()))
+ (if (< n 0)
+ syms
+ (lp (1- n) (cons (gensym stem) syms)))))
+ (let* ((args (gen-syms nargs "a"))
+ (types (gen-syms nargs "t")))
+ (let lp ((methods methods)
+ (free free)
+ (exp `(cache-miss ,gf-sym
+ ,(if rest?
+ `(cons* ,@args rest)
+ `(list ,@args)))))
+ (match methods
+ (()
+ (values `(,(if rest? `(,@args . rest) args)
+ (let ,(map (lambda (t a)
+ `(,t (class-of ,a)))
+ types args)
+ ,exp))
+ free))
+ ((#(_ specs _ cmethod) . methods)
+ (let build-dispatch ((free free)
+ (types types)
+ (specs specs)
+ (checks '()))
+ (match types
+ (()
+ (let ((m-sym (gensym "p")))
+ (lp methods
+ (acons cmethod m-sym free)
+ `(if (and . ,checks)
+ ,(if rest?
+ `(apply ,m-sym ,@args rest)
+ `(,m-sym . ,args))
+ ,exp))))
+ ((type . types)
+ (match specs
+ ((spec . specs)
+ (let ((var (assq-ref free spec)))
+ (if var
+ (build-dispatch free
+ types
+ specs
+ (cons `(eq? ,type ,var)
+ checks))
+ (let ((var (gensym "c")))
+ (build-dispatch (acons spec var free)
+ types
+ specs
+ (cons `(eq? ,type ,var)
+ checks)))))))))))))))
+
+(define (compute-dispatch-procedure gf cache)
+ (define (scan)
+ (let lp ((ls cache) (nreq -1) (nrest -1))
+ (match ls
+ (()
+ (collate (make-vector (1+ nreq) '())
+ (make-vector (1+ nrest) '())))
+ ((#(len specs rest? cmethod) . ls)
+ (if rest?
+ (lp ls nreq (max nrest len))
+ (lp ls (max nreq len) nrest))))))
+ (define (collate req rest)
+ (let lp ((ls cache))
+ (match ls
+ (() (emit req rest))
+ (((and entry #(len specs rest? cmethod)) . ls)
+ (if rest?
+ (vector-set! rest len (cons entry (vector-ref rest len)))
+ (vector-set! req len (cons entry (vector-ref req len))))
+ (lp ls)))))
+ (define (emit req rest)
+ (let ((gf-sym (gensym "g")))
+ (define (emit-rest n clauses free)
+ (if (< n (vector-length rest))
+ (match (vector-ref rest n)
+ (() (emit-rest (1+ n) clauses free))
+ ;; FIXME: hash dispatch
+ (methods
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #t))
+ (lambda (clause free)
+ (emit-rest (1+ n) (cons clause clauses) free)))))
+ (emit-req (1- (vector-length req)) clauses free)))
+ (define (emit-req n clauses free)
+ (if (< n 0)
+ (comp `(lambda ,(map cdr free)
+ (case-lambda ,@clauses))
+ (map car free))
+ (match (vector-ref req n)
+ (() (emit-req (1- n) clauses free))
+ ;; FIXME: hash dispatch
+ (methods
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #f))
+ (lambda (clause free)
+ (emit-req (1- n) (cons clause clauses) free)))))))
+
+ (emit-rest 0
+ (if (or (zero? (vector-length rest))
+ (null? (vector-ref rest 0)))
+ (list `(args (cache-miss ,gf-sym args)))
+ '())
+ (acons gf gf-sym '()))))
+ (define (comp exp vals)
+ ;; When cross-compiling Guile itself, the native Guile must generate
+ ;; code for the host.
+ (with-target %host-type
+ (lambda ()
+ (let ((p ((@ (system base compile) compile) exp
+ #:env *dispatch-module*
+ #:from 'scheme
+ #:opts '(#:partial-eval? #f #:cse? #f))))
+ (apply p vals)))))
+
+ ;; kick it.
+ (scan))
+
+;; o/~ ten, nine, eight
+;; sometimes that's just how it goes
+;; three, two, one
+;;
+;; get out before it blows o/~
+;;
+(define timer-init 30)
+(define (delayed-compile gf)
+ (let ((timer timer-init))
+ (lambda args
+ (set! timer (1- timer))
+ (cond
+ ((zero? timer)
+ (let ((dispatch (compute-dispatch-procedure
+ gf (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'procedure dispatch)
+ (apply dispatch args)))
+ (else
+ ;; interestingly, this catches recursive compilation attempts as
+ ;; well; in that case, timer is negative
+ (cache-dispatch gf args))))))
+
+(define (cache-dispatch gf args)
+ (define (map-until n f ls)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
+ (define (equal? x y) ; can't use the stock equal? because it's a generic...
+ (cond ((pair? x) (and (pair? y)
+ (eq? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((null? x) (null? y))
+ (else #f)))
+ (if (slot-ref gf 'n-specialized)
+ (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+ (let lp ((cache (slot-ref gf 'effective-methods)))
+ (cond ((null? cache)
+ (cache-miss gf args))
+ ((equal? (vector-ref (car cache) 1) types)
+ (apply (vector-ref (car cache) 3) args))
+ (else (lp (cdr cache))))))
+ (cache-miss gf args)))
+
+(define (cache-miss gf args)
+ (apply (memoize-method! gf args) args))
+
+(define (memoize-effective-method! gf args applicable)
+ (define (first-n ls n)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (car ls) (first-n (cdr ls) (- n 1)))))
+ (define (parse n ls)
+ (cond ((null? ls)
+ (memoize n #f (map class-of args)))
+ ((= n (slot-ref gf 'n-specialized))
+ (memoize n #t (map class-of (first-n args n))))
+ (else
+ (parse (1+ n) (cdr ls)))))
+ (define (memoize len rest? types)
+ (let* ((cmethod (compute-cmethod applicable types))
+ (cache (cons (vector len types rest? cmethod)
+ (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'effective-methods cache)
+ (slot-set! gf 'procedure (delayed-compile gf))
+ cmethod))
+ (parse 0 args))
+
+;;;
+;;; Compiling next methods into method bodies
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+(define (compute-cmethod methods types)
+ (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
+ (if make-procedure
+ (make-procedure
+ (if (null? (cdr methods))
+ (lambda args
+ (no-next-method (method-generic-function (car methods)) args))
+ (compute-cmethod (cdr methods) types)))
+ (method-procedure (car methods)))))
+
+;;;
+;;; Memoization
+;;;
+
+(define (memoize-method! gf args)
+ (let ((applicable ((if (eq? gf compute-applicable-methods)
+ %compute-applicable-methods
+ compute-applicable-methods)
+ gf args)))
+ (cond (applicable
+ (memoize-effective-method! gf args applicable))
+ (else
+ (no-applicable-method gf args)))))
+
+(set-procedure-property! memoize-method! 'system-procedure #t)
+
+(define no-applicable-method
+ (make <generic> #:name 'no-applicable-method))
+
+(%goops-early-init)