mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity
guile/module/oop/goops.scm
Mikael Djurfeldt 382d890026 Bugfix: Recursively use method*, not method, in method* 
* module/oop/goops.scm (method*): Do not use method.
2024-11-27 13:27:46 +01:00

3551 lines
136 KiB
Scheme
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;; goops.scm -- The Guile Object-Oriented Programming System
;;;;
;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021
;;;; Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;;
;;;; This file was based upon stklos.stk from the STk distribution
;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
;;;;
(define-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module ((ice-9 control) #:select (let/ec))
#:use-module (ice-9 threads)
#:use-module ((language tree-il primitives)
:select (add-interesting-primitive!))
#:export-syntax (define-class class standard-define-class
define-generic define-accessor
define-method define-method*
define-extended-generic define-extended-generics
method method*)
#:export ( ;; The root of everything.
<top>
<class> <object>
;; Slot types.
<slot>
<foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
<read-only-slot> <protected-opaque-slot>
<protected-hidden-slot> <protected-read-only-slot>
<scm-slot>
;; Redefinable classes.
<redefinable-class>
;; Methods are implementations of generic functions.
<method> <accessor-method>
;; Applicable objects, either procedures or applicable structs.
<procedure-class> <applicable>
<procedure> <primitive-generic>
;; Applicable structs.
<applicable-struct-class> <applicable-struct-with-setter-class>
<applicable-struct> <applicable-struct-with-setter>
<generic> <extended-generic>
<generic-with-setter> <extended-generic-with-setter>
<accessor> <extended-accessor>
;; Types with their own allocated typecodes.
<boolean> <char> <list> <pair> <null> <string> <symbol>
<vector> <bytevector> <uvec> <foreign> <hashtable>
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
<keyword> <syntax> <atomic-box>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
;; Unknown.
<unknown>
;; Particular SMOB data types. All SMOB types have
;; corresponding classes, which may be obtained via class-of,
;; once you have an instance. Perhaps FIXME to provide a
;; smob-type-name->class procedure.
<promise> <thread> <mutex> <condition-variable>
<regexp> <hook> <bitvector> <random-state>
<directory> <array> <character-set>
<dynamic-object> <guardian> <macro>
;; Modules.
<module>
;; Ports.
<port> <input-port> <output-port> <input-output-port>
;; Like SMOB types, all port types have their own classes,
;; which can be accessed via `class-of' once you have an
;; instance. Here we export bindings just for file ports.
<file-port>
<file-input-port> <file-output-port> <file-input-output-port>
is-a? class-of
ensure-metaclass ensure-metaclass-with-supers
make-class
make-generic ensure-generic
make-extended-generic
make-accessor ensure-accessor
add-method!
class-slot-ref class-slot-set! slot-unbound slot-missing
slot-definition-name slot-definition-options
slot-definition-allocation
slot-definition-getter slot-definition-setter
slot-definition-accessor
slot-definition-init-value slot-definition-init-form
slot-definition-init-thunk slot-definition-init-keyword
slot-init-function class-slot-definition
method-source
compute-cpl compute-std-cpl compute-get-n-set compute-slots
compute-getter-method compute-setter-method
allocate-instance initialize make-instance make
no-next-method no-applicable-method no-method
change-class update-instance-for-different-class
shallow-clone deep-clone
class-redefinition
apply-generic apply-method apply-methods
compute-applicable-methods %compute-applicable-methods
method-more-specific? sort-applicable-methods
class-subclasses class-methods
goops-error
min-fixnum max-fixnum
instance?
slot-ref slot-set! slot-bound? slot-exists?
class-name class-direct-supers class-direct-subclasses
class-direct-methods class-direct-slots class-precedence-list
class-slots
generic-function-name
generic-function-methods method-generic-function
method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
make find-method get-keyword))
;;;
;;; Booting GOOPS is a tortuous process. We begin by loading a small
;;; set of primitives from C.
;;;
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_goops_builtins")
(add-interesting-primitive! 'class-of))
;;;
;;; 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>)
(instance-finalizer #:class <hidden-slot>)
(print)
(name #:class <protected-hidden-slot>)
(nfields #:class <hidden-slot>)
(%reserved-6 #:class <hidden-slot>)
(%reserved-7 #:class <hidden-slot>)
(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/raw #:init-value #f)
(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 instances of a class are slot
;;; definition objects (<slot> instances), one to indicate that this
;;; class has "static slot allocation" (meaning that its slots must
;;; always be allocated to the same indices in all subclasses), and two
;;; more flags used for redefinable classes (more below).
;;;
(define vtable-flag-goops-metaclass
(logior vtable-flag-vtable vtable-flag-goops-class))
(define-inlinable (class-add-flags! class flags)
(struct-set!/unboxed
class
class-index-flags
(logior flags (struct-ref/unboxed class class-index-flags))))
(define-inlinable (class-clear-flags! class flags)
(struct-set!/unboxed
class
class-index-flags
(logand (lognot flags) (struct-ref/unboxed class class-index-flags))))
(define-inlinable (class-has-flags? class flags)
(eqv? flags
(logand (struct-ref/unboxed 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)
(and (struct? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-class)))
(define (class-has-statically-allocated-slots? class)
(class-has-flags? class vtable-flag-goops-static-slot-allocation))
(define (class-has-indirect-instances? class)
(class-has-flags? class vtable-flag-goops-indirect))
(define (indirect-slots-need-migration? slots)
(class-has-flags? (struct-vtable slots) vtable-flag-goops-needs-migration))
;;;
;;; 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>
<hidden-slot>
<protected-hidden-slot>)
((_ (name) tail)
(string-append "pw" tail))
((_ (name #:class <protected-read-only-slot>) tail)
(string-append "pw" 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> vtable-flag-goops-class)
(struct-set! <class> class-index-name '<class>)
(struct-set!/unboxed <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 '())
<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))
;;;
;;; 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/unboxed 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))
(struct-set! <slot> class-index-name '<slot>)
(struct-set!/unboxed <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 '())
<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/raw
"Return the raw slot-ref procedure of the slot @var{obj}."
%slot-definition-slot-ref/raw slot-index-slot-ref/raw)
(define-slot-accessor slot-definition-slot-ref
"Return the slot-ref procedure of the slot @var{obj}."
%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}."
%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)
(struct-set! slot slot-index-slot-ref/raw #f)
(struct-set! slot slot-index-slot-ref #f)
(struct-set! slot slot-index-slot-set! #f)
(struct-set! slot slot-index-index #f)
(struct-set! slot slot-index-size #f)
slot))
;; Boot definition.
(define (make class . args)
(unless (memq <slot> (class-precedence-list class))
(error (format #f "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))
;;;
;;; 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)
(match static-slots
(() #t)
((static-slot . static-slots)
(when (slot-memq static-slot slots)
(scm-error 'misc-error #f
"statically allocated inherited field cannot be redefined: ~a"
(list (%slot-definition-name static-slot)) '()))
(check-cpl slots static-slots))))
(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
(match (filter class-has-statically-allocated-slots? (cdr cpl))
(() #f)
((class) (struct-ref class class-index-direct-slots))
(classes
(error "can't subtype multiple classes with static slot allocation"
classes)))))
(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))
((class-has-statically-allocated-slots? head)
;; 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/unboxed class class-index-nfields)))
(struct-set!/unboxed class class-index-nfields (1+ index))
index))
;;; Pre-generate getters and setters for the first 20 slots.
(define-syntax define-standard-accessor-method
(lambda (stx)
(define num-standard-pre-cache 20)
(syntax-case stx ()
((_ ((proc n) arg ...) body)
#`(define proc
(let ((cache (vector #,@(map (lambda (n*)
#`(lambda (arg ...)
(let ((n #,n*))
body)))
(iota num-standard-pre-cache)))))
(lambda (n)
(if (< n #,num-standard-pre-cache)
(vector-ref cache n)
(lambda (arg ...) body)))))))))
(define-standard-accessor-method ((bound-check-get n) o)
(let ((x (struct-ref o n)))
(if (unbound? x)
(slot-unbound o)
x)))
(define-standard-accessor-method ((standard-get n) o)
(struct-ref o n))
(define-standard-accessor-method ((standard-set n) o v)
(struct-set! o n v))
(define-standard-accessor-method ((unboxed-get n) o)
(struct-ref/unboxed o n))
(define-standard-accessor-method ((unboxed-set n) o v)
(struct-set!/unboxed o n v))
;; Boot definitions.
(define (opaque-slot? slot) #f)
(define (read-only-slot? slot) #f)
(define (unboxed-slot? slot)
(memq (%slot-definition-name slot)
'(flags instance-finalizer nfields %reserved-6 %reserved-7)))
(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))
(name (%slot-definition-name slot))
(index (struct-ref/unboxed class class-index-nfields))
(g-n-s (compute-get-n-set class slot))
(size (- (struct-ref/unboxed 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"))
(cond
((unboxed-slot? slot)
(let ((get (unboxed-get g-n-s)))
(values get get (unboxed-set g-n-s))))
(else
(values (standard-get g-n-s)
(if (slot-definition-init-thunk slot)
(standard-get g-n-s)
(bound-check-get g-n-s))
(standard-set g-n-s)))))
(((? procedure? get) (? procedure? set))
(values get
(lambda (o)
(let ((value (get o)))
(if (unbound? value)
(slot-unbound class o name)
value)))
set))))
(lambda (get/raw get set)
(let ((get (if (opaque-slot? slot)
(lambda (o)
(error "Slot is opaque" name))
get))
(set (cond
((opaque-slot? slot)
(lambda (o v)
(error "Slot is opaque" name)))
((read-only-slot? slot)
(if (unboxed-slot? slot)
(lambda (o v)
(let ((v* (get/raw o)))
(if (zero? v*)
;; Allow initialization.
(set o v)
(error "Slot is read-only" name))))
(lambda (o v)
(let ((v* (get/raw o)))
(if (unbound? v*)
;; Allow initialization.
(set o v)
(error "Slot is read-only" name))))))
(else set))))
(struct-set! slot slot-index-slot-ref/raw get/raw)
(struct-set! slot slot-index-slot-ref get)
(struct-set! slot slot-index-slot-set! set)
(struct-set! slot slot-index-index index)
(struct-set! slot slot-index-size size))))
slot))
(struct-set!/unboxed 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 (get-keyword #:class (%slot-definition-options slot))))
(if (and type (subclass? type <foreign-slot>))
(values (cond
((subclass? type <protected-slot>) #\p)
(else #\u))
(cond
((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))))))))))))
;;;
;;; 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/unboxed 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!/unboxed 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 '())
(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 ...))))
;;;
;;; 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>))
;;;
;;; 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 <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 (opaque-slot? slot) (is-a? slot <opaque-slot>))
(define (read-only-slot? slot) (is-a? slot <read-only-slot>))
(define (unboxed-slot? slot)
(and (is-a? slot <foreign-slot>)
(not (is-a? slot <protected-slot>))))
;;;
;;; 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))))
;; Boot definition that avoids munging nfields.
(define (allocate-slots class slots)
(define (make-effective-slot-definition slot index)
(let* ((slot (compute-effective-slot-definition class slot))
(get/raw (standard-get index))
(set/raw (standard-set index)))
(struct-set! slot slot-index-slot-ref/raw (standard-get index))
(struct-set! slot slot-index-slot-ref
(if (slot-definition-init-thunk slot)
get/raw
(bound-check-get index)))
(struct-set! slot slot-index-slot-set!
(if (read-only-slot? slot)
(lambda (o v)
(let ((v* (get/raw o)))
(if (unbound? v*)
;; Allow initialization.
(set/raw o v)
(error "Slot is read-only" slot))))
set/raw))
(struct-set! slot slot-index-index index)
(struct-set! slot slot-index-size 1)
slot))
(map make-effective-slot-definition slots (iota (length slots))))
(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>)
;; Now that we're all done with that, mark <class> and <slot> as
;; static.
(class-add-flags! <class> vtable-flag-goops-static-slot-allocation)
(class-add-flags! <slot> vtable-flag-goops-static-slot-allocation))
;;;
;;; 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>))
;; Not all pairs are lists, but there is code out there that relies on
;; (is-a? '(1 2 3) <list>) to work. Terrible. How to fix?
(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 <syntax> (<top>))
(define-standard-class <atomic-box> (<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."
(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)))))
;;;
;;; 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 'effective-methods '())
(recompute-generic-function-dispatch-procedure! gf))
;; 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 vtable-flag-goops-class)
(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))))
;;;
;;; Slot access.
;;;
(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 (have-slot slot)
((%slot-definition-slot-ref slot) obj))
(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)
((%slot-definition-slot-set! slot) obj 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 (have-slot slot)
(not (unbound? ((%slot-definition-slot-ref/raw slot) obj))))
(define (no-slot)
(unless (symbol? slot-name)
(scm-error 'wrong-type-arg #f "Not a symbol: ~S"
(list slot-name) #f))
(not (unbound? (slot-missing class obj slot-name))))
(%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))
;;;
;;; 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))
;;;
;;; Generic functions!
;;;
;;; 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. A composite dispatch procedure
;;; is recomputed every time an entry gets added to the cache, or when
;;; the cache is invalidated.
;;;
;;; In steady-state, this dispatch procedure is never regenerated; but
;;; during warm-up there is some churn.
;;;
;;; 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 probably do need to use atomic access primitives to correctly
;;; handle concurrency, but that's a more general Guile concern.
;;;
(define-syntax arity-case
(lambda (x)
(syntax-case x ()
;; (arity-case n 2 foo bar)
;; => (case n
;; ((0) (foo))
;; ((1) (foo a))
;; ((2) (foo a b))
;; (else bar))
((arity-case n max form alternate)
(let ((max (syntax->datum #'max)))
#`(case n
#,@(let lp ((n 0))
(let ((ids (map (lambda (n)
(let* ((n (+ (char->integer #\a) n))
(c (integer->char n)))
(datum->syntax #'here (symbol c))))
(iota n))))
#`(((#,n) (form #,@ids))
. #,(if (< n max)
(lp (1+ n))
#'()))))
(else alternate)))))))
;;;
;;; These dispatchers are set as the "procedure" field of <generic>
;;; instances. Unlike CLOS, in GOOPS a generic function can have
;;; multiple arities.
;;;
;;; We pre-generate fast dispatchers for applications of up to 20
;;; arguments. More arguments than that will go through slower generic
;;; routines that cons arguments into a rest list.
;;;
(define (multiple-arity-dispatcher fv miss)
(define-syntax dispatch
(lambda (x)
(define (build-clauses args)
(let ((len (length (syntax->datum args))))
#`((#,args ((vector-ref fv #,len) . #,args))
. #,(syntax-case args ()
(() #'())
((arg ... _) (build-clauses #'(arg ...)))))))
(syntax-case x ()
((dispatch arg ...)
#`(case-lambda
#,@(build-clauses #'(arg ...))
(args (apply miss args)))))))
(arity-case (1- (vector-length fv)) 20 dispatch
(lambda args
(let ((nargs (length args)))
(if (< nargs (vector-length fv))
(apply (vector-ref fv nargs) args)
(apply miss args))))))
;;;
;;; The above multiple-arity-dispatcher is entirely sufficient, and
;;; should be fast enough. Still, for no good reason we also have an
;;; arity dispatcher for generics that are only called with one arity.
;;;
(define (single-arity-dispatcher f nargs miss)
(define-syntax-rule (dispatch arg ...)
(case-lambda
((arg ...) (f arg ...))
(args (apply miss args))))
(arity-case nargs 20 dispatch
(lambda args
(if (eqv? (length args) nargs)
(apply f args)
(apply miss args)))))
;;;
;;; The guts of generic function dispatch are here. Once we've selected
;;; an arity, we need to map from arguments to effective method. Until
;;; we have `eqv?' specializers, this map is entirely a function of the
;;; types (classes) of the arguments. So, we look in the cache to see
;;; if we have seen this set of concrete types, and if so we apply the
;;; previously computed effective method. Otherwise we miss the cache,
;;; so we'll have to compute the right answer for this set of types, add
;;; the mapping to the cache, and apply the newly computed method.
;;;
;;; The cached mapping is invalidated whenever a new method is defined
;;; on this generic, or whenever the class hierarchy of any method
;;; specializer changes.
;;;
(define (single-arity-cache-dispatch cache nargs cache-miss)
(match cache
(() cache-miss)
(((typev . cmethod) . cache)
(cond
((eqv? nargs (vector-length typev))
(let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss)))
(define (type-ref n)
(and (< n nargs) (vector-ref typev n)))
(define-syntax args-match?
(syntax-rules ()
((args-match?) #t)
((args-match? (arg type) (arg* type*) ...)
;; Check that the arg has the exact type that we saw. It
;; could be that `type' is #f, which indicates the end of
;; the specializers list. Once all specializers have been
;; examined, we don't need to look at any more arguments
;; to know that this is a cache hit.
(or (not type)
(and (eq? (class-of arg) type)
(args-match? (arg* type*) ...))))))
(define-syntax dispatch
(lambda (x)
(define (bind-types types k)
(let lp ((types types) (n 0))
(syntax-case types ()
(() (k))
((type . types)
#`(let ((type (type-ref #,n)))
#,(lp #'types (1+ n)))))))
(syntax-case x ()
((dispatch arg ...)
(with-syntax (((type ...) (generate-temporaries #'(arg ...))))
(bind-types
#'(type ...)
(lambda ()
#'(lambda (arg ...)
(if (args-match? (arg type) ...)
(cmethod arg ...)
(cache-miss arg ...))))))))))
(arity-case nargs 20 dispatch
(lambda args
(define (args-match? args)
(let lp ((args args) (n 0))
(match args
((arg . args)
(or (not (vector-ref typev n))
(and (eq? (vector-ref typev n) (class-of arg))
(lp args (1+ n)))))
(_ #t))))
(if (args-match? args)
(apply cmethod args)
(apply cache-miss args))))))
(else
(single-arity-cache-dispatch cache nargs cache-miss))))))
(define (compute-generic-function-dispatch-procedure gf)
(define (seen-arities cache)
(let lp ((arities 0) (cache cache))
(match cache
(() arities)
(((typev . cmethod) . cache)
(lp (logior arities (ash 1 (vector-length typev)))
cache)))))
(define (cache-miss . args)
(memoize-generic-function-application! gf args)
(apply gf args))
(let* ((cache (slot-ref gf 'effective-methods))
(arities (seen-arities cache))
(max-arity (let lp ((max -1))
(if (< arities (ash 1 (1+ max)))
max
(lp (1+ max))))))
(cond
((= max-arity -1)
;; Nothing in the cache.
cache-miss)
((= arities (ash 1 max-arity))
;; Only one arity in the cache.
(let* ((nargs max-arity)
(f (single-arity-cache-dispatch cache nargs cache-miss)))
(single-arity-dispatcher f nargs cache-miss)))
(else
;; Multiple arities.
(let ((fv (make-vector (1+ max-arity) #f)))
(let lp ((n 0))
(when (<= n max-arity)
(let ((f (single-arity-cache-dispatch cache n cache-miss)))
(vector-set! fv n f)
(lp (1+ n)))))
(multiple-arity-dispatcher fv cache-miss))))))
(define (recompute-generic-function-dispatch-procedure! gf)
(slot-set! gf 'procedure
(compute-generic-function-dispatch-procedure gf)))
(define (memoize-effective-method! gf args applicable)
(define (record-types args)
(let ((typev (make-vector (length args) #f)))
(let lp ((n 0) (args args))
(when (and (< n (slot-ref gf 'n-specialized))
(pair? args))
(match args
((arg . args)
(vector-set! typev n (class-of arg))
(lp (1+ n) args)))))
typev))
(let* ((typev (record-types args))
(compute-effective-method (if (eq? (class-of gf) <generic>)
%compute-effective-method
compute-effective-method))
(cmethod (compute-effective-method gf applicable typev))
(cache (acons typev cmethod (slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
(recompute-generic-function-dispatch-procedure! gf)
cmethod))
;;;
;;; If a method refers to `next-method' in its body, that method will be
;;; able to dispatch to the next most specific method. The exact
;;; `next-method' implementation is only known at runtime, as it is a
;;; function of which precise argument types are being dispatched, which
;;; might be subclasses of the method's declared specializers.
;;;
;;; Guile implements `next-method' by binding it as a closure variable.
;;; An effective method is bound to a specific `next-method' by the
;;; `make-procedure' slot of a <method>, which returns the new closure.
;;;
(define (%compute-specialized-effective-method gf method types next-method)
(match (slot-ref method 'make-procedure)
(#f (method-procedure method))
(make-procedure (make-procedure next-method))))
(define (compute-specialized-effective-method gf method types next-method)
(%compute-specialized-effective-method gf method types next-method))
(define (%compute-effective-method gf methods types)
(match methods
((method . methods)
(let ((compute-specialized-effective-method
(if (and (eq? (class-of gf) <generic>)
(eq? (class-of method) <method>))
%compute-specialized-effective-method
compute-specialized-effective-method)))
(compute-specialized-effective-method
gf method types
(match methods
(()
(lambda args
(no-next-method gf args)))
(methods
(let ((compute-effective-method (if (eq? (class-of gf) <generic>)
%compute-effective-method
compute-effective-method)))
(compute-effective-method gf methods types)))))))))
;; Boot definition; overrided with a generic later.
(define (compute-effective-method gf methods types)
(%compute-effective-method gf methods types))
;;;
;;; Memoization
;;;
(define (memoize-generic-function-application! gf args)
(let ((applicable ((if (eq? (class-of gf) <generic>)
%compute-applicable-methods
compute-applicable-methods)
gf args)))
(cond (applicable
(memoize-effective-method! gf args applicable))
(else
(no-applicable-method gf args)))))
(define no-applicable-method
(make <generic> #:name 'no-applicable-method))
(%goops-early-init)
;; Then load the rest of GOOPS
;; FIXME: deprecate.
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1))
;;
;; goops-error
;;
(define (goops-error format-string . args)
(scm-error 'goops-error #f format-string args '()))
;;;
;;; {Meta classes}
;;;
(define ensure-metaclass-with-supers
(let ((table-of-metas '()))
(lambda (meta-supers)
(let ((entry (assoc meta-supers table-of-metas)))
(if entry
;; Found a previously created metaclass
(cdr entry)
;; Create a new meta-class which inherit from "meta-supers"
(let ((new (make <class> #:dsupers meta-supers
#:slots '()
#:name (gensym "metaclass"))))
(set! table-of-metas (cons (cons meta-supers new) table-of-metas))
new))))))
(define (ensure-metaclass supers)
(if (null? supers)
<class>
(let* ((all-metas (map (lambda (x) (class-of x)) supers))
(all-cpls (append-map (lambda (m)
(cdr (class-precedence-list m)))
all-metas))
(needed-metas '()))
;; Find the most specific metaclasses. The new metaclass will be
;; a subclass of these.
(for-each
(lambda (meta)
(when (and (not (member meta all-cpls))
(not (member meta needed-metas)))
(set! needed-metas (append needed-metas (list meta)))))
all-metas)
;; Now return a subclass of the metaclasses we found.
(if (null? (cdr needed-metas))
(car needed-metas) ; If there's only one, just use it.
(ensure-metaclass-with-supers needed-metas)))))
;;;
;;; {Classes}
;;;
;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;; SLOT-DEFINITION ::= INSTANCE-OF-<SLOT> | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
(define (make-class supers slots . options)
(define (find-duplicate l)
(match l
(() #f)
((head . tail)
(if (memq head tail)
head
(find-duplicate tail)))))
(define (slot-spec->name slot-spec)
(match slot-spec
(((? symbol? name) . args) name)
;; We can get here when redefining classes.
((? slot? slot) (%slot-definition-name slot))))
(let* ((name (get-keyword #:name options *unbound*))
(supers (if (not (or-map (lambda (class)
(memq <object>
(class-precedence-list class)))
supers))
(append supers (list <object>))
supers))
(metaclass (or (get-keyword #:metaclass options #f)
(ensure-metaclass supers))))
;; Verify that all direct slots are different and that we don't inherit
;; several time from the same class
(let ((tmp1 (find-duplicate supers))
(tmp2 (find-duplicate (map slot-spec->name slots))))
(if tmp1
(goops-error "make-class: super class ~S is duplicate in class ~S"
tmp1 name))
(if tmp2
(goops-error "make-class: slot ~S is duplicate in class ~S"
tmp2 name)))
;; Everything seems correct, build the class
(apply make metaclass
#:dsupers supers
#:slots slots
#:name name
options)))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
(define-syntax class
(lambda (x)
(define (parse-options options)
(syntax-case options ()
(() #'())
((kw arg . options) (keyword? (syntax->datum #'kw))
(with-syntax ((options (parse-options #'options)))
(syntax-case #'kw ()
(#:init-form
#'(kw 'arg #:init-thunk (lambda () arg) . options))
(_
#'(kw arg . options)))))))
(define (check-valid-kwargs args)
(syntax-case args ()
(() #'())
((kw arg . args) (keyword? (syntax->datum #'kw))
#`(kw arg . #,(check-valid-kwargs #'args)))))
(define (parse-slots-and-kwargs args)
(syntax-case args ()
(()
#'(() ()))
((kw . _) (keyword? (syntax->datum #'kw))
#`(() #,(check-valid-kwargs args)))
(((name option ...) args ...)
(with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
((option ...) (parse-options #'(option ...))))
#'(((list 'name option ...) . slots) kwargs)))
((name args ...) (symbol? (syntax->datum #'name))
(with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
#'(('(name) . slots) kwargs)))))
(syntax-case x ()
((class (super ...) arg ...)
(with-syntax ((((slot-def ...) (option ...))
(parse-slots-and-kwargs #'(arg ...))))
#'(make-class (list super ...)
(list slot-def ...)
option ...))))))
(define-syntax define-class-pre-definition
(lambda (x)
(syntax-case x ()
((_ (k arg rest ...) out ...)
(keyword? (syntax->datum #'k))
(case (syntax->datum #'k)
((#:getter #:setter)
#'(define-class-pre-definition (rest ...)
out ...
(when (or (not (defined? 'arg))
(not (is-a? arg <generic>)))
(toplevel-define!
'arg
(ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
((#:accessor)
#'(define-class-pre-definition (rest ...)
out ...
(when (or (not (defined? 'arg))
(not (is-a? arg <accessor>)))
(toplevel-define!
'arg
(ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
(else
#'(define-class-pre-definition (rest ...) out ...))))
((_ () out ...)
#'(begin out ...)))))
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
;; which represent accessors exist before `make-class' tries to add
;; methods to them.
(define-syntax define-class-pre-definitions
(lambda (x)
(syntax-case x ()
((_ () out ...)
#'(begin out ...))
((_ (slot rest ...) out ...)
(keyword? (syntax->datum #'slot))
#'(begin out ...))
((_ (slot rest ...) out ...)
(identifier? #'slot)
#'(define-class-pre-definitions (rest ...)
out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
#'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax-rule (define-class name supers slot ...)
(begin
(define-class-pre-definitions (slot ...))
(let ((cls (class supers slot ... #:name 'name)))
(toplevel-define!
'name
(if (defined? 'name)
(class-redefinition name cls)
cls)))))
(define-syntax-rule (standard-define-class arg ...)
(define-class arg ...))
;;;
;;; {Generic functions and accessors}
;;;
;; Apparently the desired semantics are that we extend previous
;; procedural definitions, but that if `name' was already a generic, we
;; overwrite its definition.
(define-syntax define-generic
(lambda (x)
(syntax-case x ()
((define-generic name) (symbol? (syntax->datum #'name))
#'(define name
(if (and (defined? 'name) (is-a? name <generic>))
(make <generic> #:name 'name)
(ensure-generic (if (defined? 'name) name #f) 'name)))))))
(define-syntax define-extended-generic
(lambda (x)
(syntax-case x ()
((define-extended-generic name val) (symbol? (syntax->datum #'name))
#'(define name (make-extended-generic val 'name))))))
(define-syntax define-extended-generics
(lambda (x)
(define (id-append ctx a b)
(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
(syntax-case x ()
((define-extended-generic (name ...) #:prefix (prefix ...))
(and (and-map symbol? (syntax->datum #'(name ...)))
(and-map symbol? (syntax->datum #'(prefix ...))))
(with-syntax ((((val ...)) (map (lambda (name)
(map (lambda (prefix)
(id-append name prefix name))
#'(prefix ...)))
#'(name ...))))
#'(begin
(define-extended-generic name (list val ...))
...))))))
(define* (make-generic #:optional name)
(make <generic> #:name name))
(define* (make-extended-generic gfs #:optional name)
(let* ((gfs (if (list? gfs) gfs (list gfs)))
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
(let ((ans (if gws?
(let* ((sname (and name (make-setter-name name)))
(setters
(append-map (lambda (gf)
(if (is-a? gf <generic-with-setter>)
(list (ensure-generic (setter gf)
sname))
'()))
gfs))
(es (make <extended-generic-with-setter>
#:name name
#:extends gfs
#:setter (make <extended-generic>
#:name sname
#:extends setters))))
(extended-by! setters (setter es))
es)
(make <extended-generic>
#:name name
#:extends gfs))))
(extended-by! gfs ans)
ans)))
(define (extended-by! gfs eg)
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(cons eg (slot-ref gf 'extended-by))))
gfs)
(invalidate-method-cache! eg))
(define (not-extended-by! gfs eg)
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(delq! eg (slot-ref gf 'extended-by))))
gfs)
(invalidate-method-cache! eg))
(define* (ensure-generic old-definition #:optional name)
(cond ((is-a? old-definition <generic>) old-definition)
((procedure-with-setter? old-definition)
(make <generic-with-setter>
#:name name
#:default (procedure old-definition)
#:setter (setter old-definition)))
((procedure? old-definition)
(if (generic-capability? old-definition) old-definition
(make <generic> #:name name #:default old-definition)))
(else (make <generic> #:name name))))
;; same semantics as <generic>
(define-syntax-rule (define-accessor name)
(define name
(cond ((not (defined? 'name)) (ensure-accessor #f 'name))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
(define* (make-accessor #:optional name)
(make <accessor>
#:name name
#:setter (make <generic>
#:name (and name (make-setter-name name)))))
(define* (ensure-accessor proc #:optional name)
(cond ((and (is-a? proc <accessor>)
(is-a? (setter proc) <generic>))
proc)
((is-a? proc <generic-with-setter>)
(upgrade-accessor proc (setter proc)))
((is-a? proc <generic>)
(upgrade-accessor proc (make-generic name)))
((procedure-with-setter? proc)
(make <accessor>
#:name name
#:default (procedure proc)
#:setter (ensure-generic (setter proc) name)))
((procedure? proc)
(ensure-accessor (if (generic-capability? proc)
(make <generic> #:name name #:default proc)
(ensure-generic proc name))
name))
(else
(make-accessor name))))
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
(gws (make (if (is-a? generic <extended-generic>)
<extended-generic-with-setter>
<accessor>)
#:name (generic-function-name generic)
#:extended-by (slot-ref generic 'extended-by)
#:setter setter)))
(when (is-a? generic <extended-generic>)
(let ((gfs (slot-ref generic 'extends)))
(not-extended-by! gfs generic)
(slot-set! gws 'extends gfs)
(extended-by! gfs gws)))
;; Steal old methods
(for-each (lambda (method)
(slot-set! method 'generic-function gws))
methods)
(slot-set! gws 'methods methods)
(invalidate-method-cache! gws)
gws))
;;;
;;; {Methods}
;;;
;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
;; element longer than the other when we have a dotted parameter
;; list). For instance, with the call
;;
;; (M 1)
;;
;; with
;;
;; (define-method M (a . l) ....)
;; (define-method M (a) ....)
;;
;; we consider that the second method is more specific.
;;
;; Precondition: `a' and `b' are methods and are applicable to `types'.
(define (%method-more-specific? a b types)
(let lp ((a-specializers (method-specializers a))
(b-specializers (method-specializers b))
(types types))
(cond
;; (a) less specific than (a b ...) or (a . b)
((null? a-specializers) #t)
;; (a b ...) or (a . b) less specific than (a)
((null? b-specializers) #f)
;; (a . b) less specific than (a b ...)
((not (pair? a-specializers)) #f)
;; (a b ...) more specific than (a . b)
((not (pair? b-specializers)) #t)
(else
(let ((a-specializer (car a-specializers))
(b-specializer (car b-specializers))
(a-specializers (cdr a-specializers))
(b-specializers (cdr b-specializers))
(type (car types))
(types (cdr types)))
(if (eq? a-specializer b-specializer)
(lp a-specializers b-specializers types)
(let lp ((cpl (class-precedence-list type)))
(let ((elt (car cpl)))
(cond
((eq? a-specializer elt) #t)
((eq? b-specializer elt) #f)
(else (lp (cdr cpl))))))))))))
(define (%sort-applicable-methods methods types)
(sort methods (lambda (a b) (%method-more-specific? a b types))))
(define (generic-function-methods obj)
"Return the methods of the generic function @var{obj}."
(define (fold-upward method-lists gf)
(cond
((is-a? gf <extended-generic>)
(let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends)))
(match gfs
(() method-lists)
((gf . gfs)
(lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
gfs)))))
(else method-lists)))
(define (fold-downward method-lists gf)
(let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
(gfs (slot-ref gf 'extended-by)))
(match gfs
(() method-lists)
((gf . gfs)
(lp (fold-downward method-lists gf) gfs)))))
(unless (is-a? obj <generic>)
(scm-error 'wrong-type-arg #f "Not a generic: ~S"
(list obj) #f))
(concatenate (fold-downward (fold-upward '() obj) obj)))
(define (%compute-applicable-methods gf args)
(define (method-applicable? m types)
(let ((specs (method-specializers m)))
(cond
((and (is-a? m <accessor-method>)
(or (null? specs) (null? types)
(not (eq? (car specs) (car types)))))
;; Slot accessor methods are added to each subclass with the
;; slot. They only apply to that specific concrete class, which
;; appears as the first argument.
#f)
(else
(let lp ((specs specs) (types types))
(cond
((null? specs) (null? types))
((not (pair? specs)) #t)
((null? types) #f)
(else
(and (memq (car specs) (class-precedence-list (car types)))
(lp (cdr specs) (cdr types))))))))))
(let ((types (map class-of args)))
(let lp ((methods (generic-function-methods gf))
(applicable '()))
(if (null? methods)
(and (not (null? applicable))
(%sort-applicable-methods applicable types))
(let ((m (car methods)))
(lp (cdr methods)
(if (method-applicable? m types)
(cons m applicable)
applicable)))))))
(define compute-applicable-methods %compute-applicable-methods)
(define (toplevel-define! name val)
(module-define! (current-module) name val))
;;;
;;; The GOOPS API would have been simpler by introducing keyword formals
;;; in define-method itself, but in order to align with lambda* and
;;; define*, we introduce method* and define-method* in parallel to
;;; method and define-method.
;;;
;;; There is some code repetition here. The motivation for that is to
;;; pay some here in order to speed up loading and compilation of larger
;;; chunks of GOOPS code as well as to make sure that method*:s are as
;;; efficient as can be.
;;;
;;; A more elegant solution would have been to use something akin to
;;; Mark H. Weavers macro:
;;;
;;; (define-syntax define-method*
;;; (lambda (x)
;;; (syntax-case x ()
;;; ((_ (generic arg-spec ... . tail) body ...)
;;; (let-values (((required-arg-specs other-arg-specs)
;;; (break (compose keyword? syntax->datum)
;;; #'(arg-spec ...))))
;;; #`(define-method (generic #,@required-arg-specs . rest)
;;; (apply (lambda* (#,@other-arg-specs . tail)
;;; body ...)
;;; rest)))))))
;;;
;;; With the current state of the compiler, this results in slower code
;;; than the implementation below since the apply call isn't
;;; eliminated. Note also that it doesn't support the (next-method) call
;;; as does the following implementation.
;;;
;;; If you make changes, bear in mind that define-method* is supposed to
;;; also be able to handle ordinary methods without keyword formals. See
;;; the Guile Reference and the module (oop goops keyword-formals).
;;;
(define-syntax define-method
(syntax-rules (setter)
((_ ((setter name) . args) body ...)
(begin
(when (or (not (defined? 'name))
(not (is-a? name <accessor>)))
(toplevel-define! 'name
(ensure-accessor
(if (defined? 'name) name #f) 'name)))
(add-method! (setter name) (method args body ...))))
((_ (name . args) body ...)
(begin
;; FIXME: this code is how it always was, but it's quite cracky:
;; it will only define the generic function if it was undefined
;; before (ok), or *was defined to #f*. The latter is crack. But
;; there are bootstrap issues about fixing this -- change it to
;; (is-a? name <generic>) and see.
(when (or (not (defined? 'name))
(not name))
(toplevel-define! 'name (make <generic> #:name 'name)))
(add-method! name (method args body ...))))))
(define-syntax define-method*
(syntax-rules (setter)
((_ ((setter name) . args) body ...)
(begin
(when (or (not (defined? 'name))
(not (is-a? name <accessor>)))
(toplevel-define! 'name
(ensure-accessor
(if (defined? 'name) name #f) 'name)))
(add-method! (setter name) (method* args body ...))))
((_ (name . args) body ...)
(begin
(when (or (not (defined? 'name))
(not name))
(toplevel-define! 'name (make <generic> #:name 'name)))
(add-method! name (method* args body ...))))))
;;; This section of helpers is used by both the method and method* syntax
;;;
(eval-when (expand load eval)
;; parse-formals METHOD-FORMALS
;;
;; return (FORMALS SPECIALIZERS KEYWORD-FORMALS)
;;
;; FORMALS is the possibly improper list of specializable formals.
;;
;; SPECIALIZERS is a proper list of the corresponding specializers.
;; Its last element corresponds to the cdr of the last element in
;; METHOD-FORMALS such that the possibly improper list corresponding
;; to FORMALS can be obtained by applying cons* to SPECIALIZERS.
;; The reason for handling it like this is that the specializers are
;; each evaluated to their values and therefore *must* be provided
;; by a cons* in the (make <method> ...) expression.
;;
;; KEYWORD_FORMALS is the part of METHOD-FORMALS which starts with a
;; keyword and corresponds to the keyword-syntax of lambda*. These
;; are not specializable (which also corresponds to CLOS
;; functionality).
;;
(define (parse-keyword-formals method-formals)
(let lp ((ls method-formals) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
(and (identifier? #'f) (identifier? #'s))
(lp #'rest
(cons #'f formals)
(cons #'s specializers)))
((f . rest)
(identifier? #'f)
(lp #'rest
(cons #'f formals)
(cons #'<top> specializers)))
((f . rest)
(keyword? (syntax->datum #'f))
(list (reverse formals)
(reverse (cons #'<top> specializers)) ;to be cons*:ed
(cons #'f #'rest)))
(()
(list (reverse formals)
(reverse (cons #''() specializers))
'())) ;yes, not #''(); used in tests
(tail
(identifier? #'tail)
(list (append (reverse formals) #'tail)
(reverse (cons #'<top> specializers))
'())))))
(define (parse-formals method-formals)
(let lp ((ls method-formals) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
(and (identifier? #'f) (identifier? #'s))
(lp #'rest
(cons #'f formals)
(cons #'s specializers)))
((f . rest)
(identifier? #'f)
(lp #'rest
(cons #'f formals)
(cons #'<top> specializers)))
(()
(list (reverse formals)
(reverse (cons #''() specializers))))
(tail
(identifier? #'tail)
(list (append (reverse formals) #'tail)
(reverse (cons #'<top> specializers)))))))
(define (find-free-id exp referent)
(syntax-case exp ()
((x . y)
(or (find-free-id #'x referent)
(find-free-id #'y referent)))
(x
(identifier? #'x)
(let ((id (datum->syntax #'x referent)))
(and (free-identifier=? #'x id) id)))
(_ #f)))
(define (compute-procedure formals keyword-formals body)
(syntax-case body ()
((body0 ...)
(if (null? keyword-formals)
(with-syntax ((formals formals))
#'(lambda formals body0 ...))
(let ((formals (append formals keyword-formals)))
(with-syntax ((formals formals))
#'(lambda* formals body0 ...)))))))
;; ->formal-ids FORMALS
;;
;; convert FORMALS into formal-ids format, which is a cell where the
;; car is the list of car:s in FORMALS and the cdr is the cdr of the
;; last cell in FORMALS, i.e. the final tail.
;;
;; The motivation for this format is to easily determine if FORMALS
;; is improper or not in order to generate the corresponding
;; next-method call.
;;
(define (->formal-ids formals)
(let lp ((ls formals) (out '()))
(syntax-case ls ()
((x . xs) (lp #'xs (cons #'x out)))
(() (cons (reverse out) '()))
(tail (cons (reverse out) #'tail)))))
;; compute-keyword-formal-ids FORMALS KEYWORD-FORMALS
;;
;; The main purpose of this beast is to compute the argument list
;; for the actual next-method call for the case where the user calls
;; (next-method). It is invoked in the case where we have keyword
;; formals. Here we have to treat keyword arguments in a special way
;; since we, similar to CLOS, only want to pass on the keyword
;; arguments that were present in the call. We capture those using
;; the rest argument. If not present, we introduce a rest formal.
;;
;; FORMALS is the non-keyword part of the formal arguments.
;; KEYWORD-FORMALS is the part of the formal arguments from the
;; first keyword.
;;
;; return three values:
;;
;; 1. #'lambda
;; 2. the complete formals list
;; 3. the argument list for next-method in formals-ids format as
;; described above (proper list in CAR, tail in CDR)
;;
(define (compute-keyword-formal-ids formals keyword-formals)
(define (result formals formal-ids)
(values #'lambda* formals formal-ids))
(define (lp-key ls formals formal-ids)
(syntax-case ls ()
((#:rest f)
(identifier? #'f)
(result (append (reverse formals) #'f)
(cons (reverse formal-ids) #'f)))
(()
;; No rest formal is present, so we need to introduce one.
(let ((rest-formal (car (generate-temporaries '(rest)))))
(result (append (reverse formals) rest-formal)
(cons (reverse formal-ids) rest-formal))))
((f . rest)
(lp-key #'rest
(cons #'f formals) ;keep
formal-ids)) ;filter away
(tail
(result (append (reverse formals) #'tail)
(cons (reverse formal-ids) #'tail)))))
(let ((reversed-formals (reverse formals)))
(let lp ((ls keyword-formals)
(formals reversed-formals)
(formal-ids reversed-formals))
(syntax-case ls ()
(((f val) . rest)
(lp #'rest (cons #'(f val) formals) (cons #'f formal-ids)))
((#:optional . rest)
(lp #'rest (cons #:optional formals) formal-ids))
((#:key . rest)
(lp-key #'rest (cons #:key formals) formal-ids))
((#:rest f)
(identifier? #'f)
(result (append (reverse formals) #'f)
(cons (reverse formal-ids) #'f)))
((f . rest)
(lp #'rest (cons #'f formals) (cons #'f formal-ids)))
(()
(result (reverse formals) (cons (reverse formal-ids) '())))
(tail
(result (append (reverse formals) #'tail)
(cons (reverse formal-ids) #'tail)))))))
(define (compute-make-procedure formals keyword-formals body next-method)
(syntax-case body ()
((body ...)
(call-with-values
(lambda ()
(if (null? keyword-formals)
(values #'lambda
formals
(->formal-ids formals))
(compute-keyword-formal-ids formals keyword-formals)))
(lambda (lambda-type formals formal-ids)
(with-syntax ((next-method next-method))
(syntax-case formals ()
(formals
#`(lambda (real-next-method)
(#,lambda-type ;lambda or lambda*
formals
(let ((next-method
(lambda args
(if (null? args)
;; We have (next-method) and need to
;; pass on the arguments to the method.
#,(if (null? (cdr formal-ids))
;; proper list of identifiers
#`(real-next-method
#,@(car formal-ids))
;; last identifier is a rest list
#`(apply real-next-method
#,@(car formal-ids)
#,(cdr formal-ids)))
;; user passes arguments to next-method
(apply real-next-method args)))))
body ...)))))))))))
(define (compute-procedures formals keyword-formals body)
;; So, our use of this is broken, because it operates on the
;; pre-expansion source code. It's equivalent to just searching
;; for referent in the datums. Ah well.
(let ((id (find-free-id body 'next-method)))
(if id
;; return a make-procedure
(values #'#f
(compute-make-procedure formals keyword-formals body id))
(values (compute-procedure formals keyword-formals body)
#'#f))))
)
(define-syntax method
(lambda (x)
(syntax-case x ()
((_ formals) #'(method formals (if #f #f)))
((_ formals body0 body1 ...)
(with-syntax (((formals (specializer ...))
(parse-formals #'formals)))
(call-with-values
(lambda ()
(compute-procedures #'formals
'()
#'(body0 body1 ...)))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
#`(make <method>
#:specializers (cons* specializer ...) ;yes, this
;; The cons* is needed to get the value of each
;; specializer.
#:formals 'formals ;might be improper
#:body '(body0 body1 ...)
#:make-procedure make-procedure
#:procedure procedure)))))))))
(define-syntax method*
(lambda (x)
(syntax-case x ()
((_ formals) #'(method* formals (if #f #f)))
((_ formals body0 body1 ...)
(with-syntax (((formals (specializer ...) keyword-formals)
(parse-keyword-formals #'formals)))
(call-with-values
(lambda ()
(compute-procedures #'formals
#'keyword-formals
#'(body0 body1 ...)))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
#`(make <method>
#:specializers (cons* specializer ...)
#:formals (if (null? 'keyword-formals)
'formals ;might be improper
(append 'formals 'keyword-formals))
#:body '(body0 body1 ...)
#:make-procedure make-procedure
#:procedure procedure)))))))))
;;;
;;; {Utilities}
;;;
;;; These are useful when dealing with method specializers, which might
;;; have a rest argument.
;;;
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph"
((null? (car l)) '())
((pair? (car l)) (cons (apply fn (map car l))
(apply map* fn (map cdr l))))
(else (apply fn l))))
(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
(cond ; must be "isomorph"
((null? (car l)) '())
((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
(else (apply fn l))))
(define (length* ls)
(do ((n 0 (+ 1 n))
(ls ls (cdr ls)))
((not (pair? ls)) n)))
;;;
;;; {add-method!}
;;;
(define (add-method-in-classes! m)
;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x)
(let ((dm (class-direct-methods x)))
(unless (memq m dm)
(struct-set! x class-index-direct-methods (cons m dm)))))
(method-specializers m)))
(define (remove-method-in-classes! m)
;; Remove method in all the classes which appears in its specializers list
(for-each* (lambda (x)
(struct-set! x
class-index-direct-methods
(delv! m (class-direct-methods x))))
(method-specializers m)))
(define (compute-new-list-of-methods gf new)
(let ((new-spec (method-specializers new))
(methods (slot-ref gf 'methods)))
(let loop ((l methods))
(if (null? l)
(cons new methods)
(if (equal? (method-specializers (car l)) new-spec)
(begin
;; This spec. list already exists. Remove old method from dependents
(remove-method-in-classes! (car l))
(set-car! l new)
methods)
(loop (cdr l)))))))
(define (method-n-specializers m)
(length* (slot-ref m 'specializers)))
(define (calculate-n-specialized gf)
(fold (lambda (m n) (max n (method-n-specializers m)))
0
(generic-function-methods gf)))
(define (invalidate-method-cache! gf)
(slot-set! gf 'n-specialized (calculate-n-specialized gf))
(%invalidate-method-cache! gf)
(for-each (lambda (gf) (invalidate-method-cache! gf))
(slot-ref gf 'extended-by)))
(define internal-add-method!
(method ((gf <generic>) (m <method>))
(slot-set! m 'generic-function gf)
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
(invalidate-method-cache! gf)
(add-method-in-classes! m)
*unspecified*))
(define-generic add-method!)
((method-procedure internal-add-method!) add-method! internal-add-method!)
(define-method (add-method! (proc <procedure>) (m <method>))
(if (generic-capability? proc)
(begin
(enable-primitive-generic! proc)
(add-method! proc m))
(next-method)))
(define-method (add-method! (pg <primitive-generic>) (m <method>))
(add-method! (primitive-generic-generic pg) m))
(define-method (add-method! obj (m <method>))
(goops-error "~S is not a valid generic function" obj))
;;;
;;; {Access to meta objects}
;;;
;;;
;;; Methods
;;;
(define-method (method-source (m <method>))
(let* ((spec (map* class-name (slot-ref m 'specializers)))
(src (procedure-source (slot-ref m 'procedure))))
(and src
(let ((args (cadr src))
(body (cddr src)))
(cons 'method
(cons (map* list args spec)
body))))))
(define-method (method-formals (m <method>))
(slot-ref m 'formals))
;;;
;;; Slots
;;;
(define (slot-init-function class slot-name)
(%slot-definition-init-thunk (or (class-slot-definition class slot-name)
(error "slot not found" slot-name))))
(define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}."
(slot-ref obj 'slot-definition))
;;;
;;; {Standard methods used by the C runtime}
;;;
;;; Methods to compare objects
;;;
;; Have to do this in a strange order because equal? is used in the
;; add-method! implementation; we need to make sure that when the
;; primitive is extended, that the generic has a method. =
(define g-equal? (make-generic 'equal?))
;; When this generic gets called, we will have already checked eq? and
;; eqv? -- the purpose of this generic is to extend equality. So by
;; default, there is no extension, thus the #f return.
(add-method! g-equal? (method (x y) #f))
(set-primitive-generic! equal? g-equal?)
;;;
;;; methods to display/write an object
;;;
; Code for writing objects must test that the slots they use are
; bound. Otherwise a slot-unbound method will be called and will
; conduct to an infinite loop.
;; Write
(define (display-address o file)
(display (number->string (object-address o) 16) file))
(define-method (write o file)
(display "#<instance " file)
(display-address o file)
(display #\> file))
(define write-object (primitive-generic-generic write))
(define-method (write (o <object>) file)
(let ((class (class-of o)))
(if (slot-bound? class 'name)
(begin
(display "#<" file)
(display (class-name class) file)
(display #\space file)
(display-address o file)
(display #\> file))
(next-method))))
(define-method (write (slot <slot>) file)
(let ((class (class-of slot)))
(if (and (slot-bound? class 'name)
(slot-bound? slot 'name))
(begin
(display "#<" file)
(display (class-name class) file)
(display #\space file)
(display (%slot-definition-name slot) file)
(display #\space file)
(display-address slot file)
(display #\> file))
(next-method))))
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
(slot-bound? meta 'name))
(begin
(display "#<" file)
(display (class-name meta) file)
(display #\space file)
(display (class-name class) file)
(display #\space file)
(display-address class file)
(display #\> file))
(next-method))))
(define-method (write (gf <generic>) file)
(let ((meta (class-of gf)))
(if (and (slot-bound? meta 'name)
(slot-bound? gf 'methods))
(begin
(display "#<" file)
(display (class-name meta) file)
(let ((name (generic-function-name gf)))
(if name
(begin
(display #\space file)
(display name file))))
(display " (" file)
(display (length (generic-function-methods gf)) file)
(display ")>" file))
(next-method))))
(define-method (write (o <method>) file)
(let ((meta (class-of o)))
(if (and (slot-bound? meta 'name)
(slot-bound? o 'specializers))
(begin
(display "#<" file)
(display (class-name meta) file)
(display #\space file)
(display (map* (lambda (spec)
(if (slot-bound? spec 'name)
(slot-ref spec 'name)
spec))
(method-specializers o))
file)
(display #\space file)
(display-address o file)
(display #\> file))
(next-method))))
;; Display (do the same thing as write by default)
(define-method (display o file)
(write-object o file))
;;;
;;; Handling of duplicate bindings in the module system
;;;
(define (find-subclass super name)
(let lp ((classes (class-direct-subclasses super)))
(cond
((null? classes)
(error "class not found" name))
((and (slot-bound? (car classes) 'name)
(eq? (class-name (car classes)) name))
(car classes))
(else
(lp (cdr classes))))))
;; A record type.
(define <module> (find-subclass <top> '<module>))
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <top>)
(int2 <module>)
(val2 <top>)
(var <top>)
(val <top>))
#f)
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <generic>)
(int2 <module>)
(val2 <generic>)
(var <top>)
(val <boolean>))
(and (not (eq? val1 val2))
(make-variable (make-extended-generic (list val2 val1) name))))
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <generic>)
(int2 <module>)
(val2 <generic>)
(var <top>)
(gf <extended-generic>))
(and (not (memq val2 (slot-ref gf 'extends)))
(begin
(slot-set! gf
'extends
(cons val2 (delq! val2 (slot-ref gf 'extends))))
(slot-set! val2
'extended-by
(cons gf (delq! gf (slot-ref val2 'extended-by))))
(invalidate-method-cache! gf)
var)))
(module-define! duplicate-handlers 'merge-generics merge-generics)
(define-method (merge-accessors (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <top>)
(int2 <module>)
(val2 <top>)
(var <top>)
(val <top>))
#f)
(define-method (merge-accessors (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <accessor>)
(int2 <module>)
(val2 <accessor>)
(var <top>)
(val <top>))
(merge-generics module name int1 val1 int2 val2 var val))
(module-define! duplicate-handlers 'merge-accessors merge-accessors)
;;;
;;; slot access
;;;
(define (class-slot-ref class slot-name)
(let ((slot (class-slot-definition class slot-name)))
(unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
(slot-missing class slot-name))
(let ((x ((%slot-definition-slot-ref/raw slot) #f)))
(if (unbound? x)
(slot-unbound class slot-name)
x))))
(define (class-slot-set! class slot-name value)
(let ((slot (class-slot-definition class slot-name)))
(unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
(slot-missing class slot-name))
((%slot-definition-slot-set! slot) #f value)))
(define-method (slot-unbound (c <class>) (o <object>) s)
(goops-error "Slot `~S' is unbound in object ~S" s o))
(define-method (slot-unbound (c <class>) s)
(goops-error "Slot `~S' is unbound in class ~S" s c))
(define-method (slot-unbound (o <object>))
(goops-error "Unbound slot in object ~S" o))
(define-method (slot-missing (c <class>) (o <object>) s)
(goops-error "No slot with name `~S' in object ~S" s o))
(define-method (slot-missing (c <class>) s)
(goops-error "No class slot with name `~S' in class ~S" s c))
(define-method (slot-missing (c <class>) (o <object>) s value)
(slot-missing c o s))
;;; Methods for the possible error we can encounter when calling a gf
(define-method (no-next-method (gf <generic>) args)
(goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
(define-method (no-applicable-method (gf <generic>) args)
(goops-error "No applicable method for ~S in call ~S"
gf (cons (generic-function-name gf) args)))
(define-method (no-method (gf <generic>) args)
(goops-error "No method defined for ~S" gf))
;;;
;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
;;;
(define-method (shallow-clone (self <object>))
(let* ((class (class-of self))
(clone (%allocate-instance class))
(slots (map slot-definition-name (class-slots class))))
(for-each (lambda (slot)
(when (slot-bound? self slot)
(slot-set! clone slot (slot-ref self slot))))
slots)
clone))
(define-method (deep-clone (self <object>))
(let* ((class (class-of self))
(clone (%allocate-instance class))
(slots (map slot-definition-name (class-slots class))))
(for-each (lambda (slot)
(when (slot-bound? self slot)
(slot-set! clone slot
(let ((value (slot-ref self slot)))
(if (instance? value)
(deep-clone value)
value)))))
slots)
clone))
;;;
;;; {Utilities for INITIALIZE methods}
;;;
;;; compute-slot-accessors
;;;
(define (compute-slot-accessors class slots)
(for-each
(lambda (slot)
(let ((getter (%slot-definition-getter slot))
(setter (%slot-definition-setter slot))
(accessor-setter setter)
(accessor (%slot-definition-accessor slot)))
(when getter
(add-method! getter (compute-getter-method class slot)))
(when setter
(add-method! setter (compute-setter-method class slot)))
(when accessor
(add-method! accessor (compute-getter-method class slot))
(add-method! (accessor-setter accessor)
(compute-setter-method class slot)))))
slots))
(define-method (compute-getter-method (class <class>) slot)
(make <accessor-method>
#:specializers (list class)
#:procedure (slot-definition-slot-ref slot)
#:slot-definition slot))
(define-method (compute-setter-method (class <class>) slot)
(make <accessor-method>
#:specializers (list class <top>)
#:procedure (slot-definition-slot-set! slot)
#:slot-definition slot))
(define (make-generic-bound-check-getter proc)
(lambda (o)
(let ((val (proc o)))
(if (unbound? val)
(slot-unbound o)
val))))
;;; compute-cpl
;;;
;; Replace the bootstrap compute-cpl with this definition.
(define compute-cpl
(make <generic> #:name 'compute-cpl))
(define-method (compute-cpl (class <class>))
(compute-std-cpl class class-direct-supers))
;;; compute-get-n-set
;;;
(define compute-get-n-set
(make <generic> #:name 'compute-get-n-set))
(define-method (compute-get-n-set (class <class>) s)
(define (class-slot-init-value)
(let ((thunk (slot-definition-init-thunk s)))
(if thunk
(thunk)
(slot-definition-init-value s))))
(define (make-closure-variable class value)
(list (lambda (o) value)
(lambda (o v) (set! value v))))
(case (slot-definition-allocation s)
((#:instance) ;; Instance slot
;; get-n-set is just its offset
(let ((already-allocated (struct-ref/unboxed class class-index-nfields)))
(struct-set!/unboxed class class-index-nfields (+ already-allocated 1))
already-allocated))
((#:class) ;; Class slot
;; Class-slots accessors are implemented as 2 closures around
;; a Scheme variable. As instance slots, class slots must be
;; unbound at init time.
(let ((name (slot-definition-name s)))
(if (memq name (map slot-definition-name (class-direct-slots class)))
;; This slot is direct; create a new shared variable
(make-closure-variable class (class-slot-init-value))
;; Slot is inherited. Find its definition in superclass
(let lp ((cpl (cdr (class-precedence-list class))))
(match cpl
((super . cpl)
(let ((s (class-slot-definition super name)))
(if s
(list (slot-definition-slot-ref s)
(slot-definition-slot-set! s))
;; Multiple inheritance means that we might have
;; to look deeper in the CPL.
(lp cpl)))))))))
((#:each-subclass) ;; slot shared by instances of direct subclass.
;; (Thomas Buerger, April 1998)
(make-closure-variable class (class-slot-init-value)))
((#:virtual) ;; No allocation
;; slot-ref and slot-set! function must be given by the user
(let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
(set (get-keyword #:slot-set! (slot-definition-options s) #f)))
(unless (and get set)
(goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" s))
(list get set)))
(else (next-method))))
(define-method (compute-get-n-set (o <object>) s)
(goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
(define-method (compute-slots (class <class>))
(build-slots-list (class-direct-slots class)
(class-precedence-list class)))
;;;
;;; {Initialize}
;;;
;; FIXME: This could be much more efficient.
(define (%initialize-object obj initargs)
"Initialize the object @var{obj} with the given arguments
var{initargs}."
(define (valid-initargs? initargs)
(match initargs
(() #t)
(((? keyword?) _ . initargs) (valid-initargs? initargs))
(_ #f)))
(unless (instance? obj)
(scm-error 'wrong-type-arg #f "Not an object: ~S"
(list obj) #f))
(unless (valid-initargs? initargs)
(scm-error 'wrong-type-arg #f "Invalid initargs: ~S"
(list initargs) #f))
(let ((class (class-of obj)))
(define (get-initarg kw)
(if kw
;; Inlined get-keyword to avoid checking initargs for validity
;; each time.
(let lp ((initargs initargs))
(match initargs
((kw* val . initargs)
(if (eq? kw* kw)
val
(lp initargs)))
(_ *unbound*)))
*unbound*))
(let lp ((slots (struct-ref class class-index-slots)))
(match slots
(() obj)
((slot . slots)
(define (initialize-slot! value)
((%slot-definition-slot-set! slot) obj value))
(let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
(cond
((not (unbound? initarg))
(initialize-slot! initarg))
((%slot-definition-init-thunk slot)
=> (lambda (init-thunk)
(unless (memq (slot-definition-allocation slot)
'(#:class #:each-subclass))
(initialize-slot! (init-thunk)))))))
(lp slots))))))
(define-method (initialize (object <object>) initargs)
(%initialize-object object initargs))
(define-method (initialize (slot <slot>) initargs)
(next-method)
(struct-set! slot slot-index-options initargs)
(let ((init-thunk (%slot-definition-init-thunk slot)))
(when init-thunk
(unless (thunk? init-thunk)
(goops-error "Bad init-thunk for slot `~S': ~S"
(%slot-definition-name slot) init-thunk)))))
(define-method (initialize (class <class>) initargs)
(define (make-direct-slot-definition dslot)
(let ((initargs (compute-direct-slot-definition-initargs class dslot)))
(compute-direct-slot-definition class initargs)))
(next-method)
(class-add-flags! class vtable-flag-goops-class)
(struct-set! class class-index-name (get-keyword #:name initargs '???))
(struct-set!/unboxed class class-index-nfields 0)
(struct-set! class class-index-direct-supers
(get-keyword #:dsupers initargs '()))
(struct-set! class class-index-direct-subclasses '())
(struct-set! class class-index-direct-methods '())
(struct-set! class class-index-cpl (compute-cpl class))
(when (get-keyword #:static-slot-allocation? initargs #f)
(match (filter class-has-statically-allocated-slots?
(class-precedence-list class))
(()
(class-add-flags! class vtable-flag-goops-static-slot-allocation))
(classes
(error "Class has superclasses with static slot allocation" classes))))
(struct-set! class class-index-direct-slots
(map (lambda (slot)
(if (slot? slot)
slot
(make-direct-slot-definition slot)))
(get-keyword #:slots initargs '())))
(struct-set! class class-index-slots
(allocate-slots class (compute-slots class)))
;; This is a hack.
(when (memq <slot> (struct-ref class class-index-cpl))
(class-add-flags! class vtable-flag-goops-slot))
;; Build getters - setters - accessors
(compute-slot-accessors class (struct-ref class class-index-slots))
;; Update the "direct-subclasses" of each inherited classes
(for-each (lambda (x)
(let ((dsubs (struct-ref x class-index-direct-subclasses)))
(struct-set! x class-index-direct-subclasses
(cons class dsubs))))
(struct-ref class class-index-direct-supers))
;; Compute struct layout of instances, set the `layout' slot, and
;; update class flags.
(%prep-layout! class))
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
((pair? proc)
(apply slot-set! object 'procedure proc))
(else
(slot-set! object 'procedure proc)))))
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
(initialize-object-procedure applicable-struct initargs))
(define-method (initialize (applicable-struct <applicable-struct-with-setter>)
initargs)
(next-method)
(slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f)))
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
(name (get-keyword #:name initargs #f)))
(next-method)
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
(list (method args
(apply previous-definition args)))
'()))
(if name
(set-procedure-property! generic 'name name))
(invalidate-method-cache! generic)))
(define-method (initialize (eg <extended-generic>) initargs)
(next-method)
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
(define dummy-procedure (lambda args *unspecified*))
(define-method (initialize (method <method>) initargs)
(next-method)
(slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure
(get-keyword #:procedure initargs #f))
(slot-set! method 'formals (get-keyword #:formals initargs '()))
(slot-set! method 'body (get-keyword #:body initargs '()))
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
;;;
;;; {make}
;;;
;;; A new definition which overwrites the previous one which was built-in
;;;
(define-method (allocate-instance (class <class>) initargs)
(%allocate-instance class))
(define-method (make-instance (class <class>) . initargs)
(let ((instance (allocate-instance class initargs)))
(initialize instance initargs)
instance))
(define make make-instance)
;;;
;;; {apply-generic}
;;;
;;; Protocol for calling generic functions, intended to be used when
;;; applying subclasses of <generic> and <generic-with-setter>. The
;;; code below is similar to the first MOP described in AMOP.
;;;
;;; Note that standard generic functions dispatch only on the classes of
;;; the arguments, and the result of such dispatch can be memoized. The
;;; `dispatch-generic-function-application-from-cache' routine
;;; implements this. `apply-generic' isn't called currently; the
;;; generic function MOP was never fully implemented in GOOPS. However
;;; now that GOOPS is implemented entirely in Scheme (2015) it's much
;;; easier to complete this work. Contributions gladly accepted!
;;; Please read the AMOP first though :)
;;;
;;; The protocol is:
;;;
;;; + apply-generic (gf args)
;;; + compute-applicable-methods (gf args ...)
;;; + sort-applicable-methods (gf methods args)
;;; + apply-methods (gf methods args)
;;;
;;; apply-methods calls make-next-method to build the "continuation" of
;;; a method. Applying a next-method will call apply-next-method which
;;; in turn will call apply again to call effectively the following
;;; method. (This paragraph is out of date but is kept so that maybe it
;;; illuminates some future hack.)
;;;
(define-method (apply-generic (gf <generic>) args)
(when (null? (slot-ref gf 'methods))
(no-method gf args))
(let ((methods (compute-applicable-methods gf args)))
(if methods
(apply-methods gf (sort-applicable-methods gf methods args) args)
(no-applicable-method gf args))))
;; compute-applicable-methods is bound to %compute-applicable-methods.
(define compute-applicable-methods
(let ((gf (make <generic> #:name 'compute-applicable-methods)))
(add-method! gf (method ((gf <generic>) args)
(%compute-applicable-methods gf args)))
gf))
(define-method (sort-applicable-methods (gf <generic>) methods args)
(%sort-applicable-methods methods (map class-of args)))
(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
(%method-more-specific? m1 m2 targs))
(define compute-effective-method
(let ((gf (make <generic> #:name 'compute-effective-method)))
(add-method! gf (method ((gf <generic>) methods typev)
(%compute-effective-method gf methods typev)))
gf))
(define compute-specialized-effective-method
(let ((gf (make <generic> #:name 'compute-specialized-effective-method)))
(add-method!
gf
(method ((gf <generic>) (method <method>) typev next)
(%compute-specialized-effective-method gf method typev next)))
gf))
(define-method (compute-specialized-effective-method (gf <generic>)
(m <accessor-method>)
typev
next)
(let ((name (slot-definition-name (accessor-method-slot-definition m))))
(match typev
(#(class)
(slot-definition-slot-ref (class-slot-definition class name)))
(#(class _)
(slot-definition-slot-set! (class-slot-definition class name)))
(_
(next-method)))))
(define-method (apply-method (gf <generic>) methods build-next args)
(apply (method-procedure (car methods))
(build-next (cdr methods) args)
args))
(define-method (apply-methods (gf <generic>) (l <list>) args)
(letrec ((next (lambda (procs args)
(lambda new-args
(let ((a (if (null? new-args) args new-args)))
(if (null? procs)
(no-next-method gf a)
(apply-method gf procs next a)))))))
(apply-method gf l next args)))
;; We don't want the following procedure to turn up in backtraces:
(for-each (lambda (proc)
(set-procedure-property! proc 'system-procedure #t))
(list slot-unbound
slot-missing
no-next-method
no-applicable-method
no-method
))
;;;
;;; Class redefinition
;;;
;;; GOOPS has a facility to allow a user to change the definition of
;;; class. This will cause instances of that class to lazily migrate
;;; over to the new definition. Implementing this is tricky because
;;; identity is a fundamental part of object-oriented programming; you
;;; can't just make a new class and start using it, just like that. In
;;; GOOPS, classes are objects too and need to be addressable by
;;; identity (by `eq?'). Classes need the ability to change their
;;; definition "in place". The same goes for instances; redefining a
;;; class might change the amount of storage associated with each
;;; instance, and yet we need to update the instances in place, and
;;; without having classes maintain a list of all of their instances.
;;;
;;; The way that we implement this is by adding an indirection. An
;;; instance of a redefinable class becomes a small object containing
;;; only a single field, a reference to an external "slots" objects that
;;; holds the actual slots. There is an exception however for objects
;;; that have statically allocated slots, most importantly classes -- in
;;; that case the indirected slots are allocated "directly" in the
;;; object.
;;;
;;; Instances update by checking the class of their their indirected
;;; slots object. In addition to describing the slots of the indirected
;;; slots object, that slots class (which is a direct class) has a
;;; "redefined" slot. If the indirect slots object is current, this
;;; value is #f. Otherwise it points to the old class definition
;;; corresponding to its instances.
;;;
;;; To try to clarify things, here is a diagram of the "normal" state of
;;; affairs. The redefinable class has an associated slots class. When
;;; it makes instances, the instances have a pointer to the indirect
;;; "slots" object. The class of the indirect slots object is the slots
;;; class associated with the instance's class. The "V" arrows indicate
;;; a vtable (class-of) relationship. Dashed arrows indicate a reference
;;; from a struct slot to an object.
;;;
;;; Initial state.
;;; +-------------+ +------------------------------+
;;; | class ----> slots class, redefined: #f |
;;; +-V-----------+ +-V----------------------------+
;;; V V
;;; +-V-----------+ +-V----------------------------+
;;; | instance ----> slots ... |
;;; +-------------+ +------------------------------+
;;;
;;; When a class is redefined, it is updated in place. However existing
;;; instances are only migrated lazily. So after a class has been
;;; redefined but before the instance has been updated, the state looks
;;; like this:
;;;
;;; Redefined state.
;;; ,-------------------------------------------.
;;; | |
;;; +-v-----------+ +----------------------------|-+
;;; | old class ----> old slots class, redefined:' VVV
;;; +-------------+ +------------------------------+ V
;;; V
;;; +-------------+ +------------------------------+ V
;;; | new class ----> new slots class, redefined:#f| V
;;; +-V-----------+ +------------------------------+ V
;;; V V
;;; +-V-----------+ +------------------------------+ V
;;; | old inst ----> slots ... VVV
;;; +-------------+ +------------------------------+
;;;
;;; That is to say, because the class was updated in place, the old
;;; instance's vtable is the new class, even though the old instance's
;;; slots still correspond to the old class. The vtable of the old slots
;;; has the "redefined" field, which has been set to point to a fresh
;;; object containing the direct slots of the old class, and a pointer to
;;; the old slots class -- as if it were the old class, but with a new
;;; temporary identity. This allows us to then call
;;;
;;; (change-object-class obj old-class new-class)
;;;
;;; which will allocate a fresh slots object for the old instance
;;; corresponding to the new class, completing the migration for that
;;; instance.
;;;
;;; Lazy instance migration is triggered by "class-of". Calling
;;; "class-of" on an indirect instance will check the indirect slots to
;;; see if they need redefinition. If so, we construct a fresh instance
;;; of the new class and swap fields with the old instance (including
;;; the indirect-slots field). Unfortunately there is some
;;; thread-unsafety here, as retrieving the class is unsynchronized with
;;; retrieving the indirect slots.
;;;
(define-class <indirect-slots-class> (<class>)
(%redefined #:init-value #f))
(define-class <redefinable-class> (<class>)
(indirect-slots-class))
(define-method (compute-slots (class <redefinable-class>))
(let* ((slots (next-method))
;; The base method ensured that at most one superclass has
;; statically allocated slots.
(static-slots
(match (filter class-has-statically-allocated-slots?
(cdr (class-precedence-list class)))
(() '())
((class) (struct-ref class class-index-direct-slots)))))
(define (simplify-slot-definition s)
;; Here we take a slot definition and strip it to just be a plain
;; old name, suitable for use as a slot for the plain-old-data
;; indirect-slots class.
(and (eq? (slot-definition-allocation s) #:instance)
(make (class-of s) #:name (slot-definition-name s))))
(define (maybe-make-indirect-slot-definition s)
;; Here we copy over all the frippery of a slot definition
;; (accessors, init-keywords, and so on), but we change the slot
;; to have virtual allocation and we provide explicit
;; slot-ref/slot-set! functions that access the slot value through
;; the indirect slots object. For slot definitions without
;; instance allocation though, we just pass them through.
(cond
((eq? (slot-definition-allocation s) #:instance)
(let* ((s* (class-slot-definition (slot-ref class 'indirect-slots-class)
(slot-definition-name s)))
(ref (slot-definition-slot-ref/raw s*))
(set! (slot-definition-slot-set! s*)))
(apply make (class-of s)
#:allocation #:virtual
;; TODO: Make faster.
#:slot-ref (lambda (o)
(ref (slot-ref o 'indirect-slots)))
#:slot-set! (lambda (o v)
(set! (slot-ref o 'indirect-slots) v))
(let loop ((options (slot-definition-options s)))
(match options
(() '())
(((or #:allocation #:slot-ref #:slot-set!) _ . rest)
(loop rest))
((kw arg . rest)
(cons* kw arg (loop rest))))))))
(else s)))
(unless (equal? (list-head slots (length static-slots))
static-slots)
(error "unexpected slots"))
(let* ((indirect-slots (list-tail slots (length static-slots)))
(indirect-slots-class
(make-class '()
(filter-map simplify-slot-definition
indirect-slots)
#:name 'indirect-slots
#:metaclass <indirect-slots-class>)))
(slot-set! class 'indirect-slots-class indirect-slots-class)
(append static-slots
(cons (make <slot> #:name 'indirect-slots)
(map maybe-make-indirect-slot-definition
indirect-slots))))))
(define-method (initialize (class <redefinable-class>) initargs)
(next-method)
(class-add-flags! class vtable-flag-goops-indirect))
(define-method (allocate-instance (class <redefinable-class>) initargs)
(let ((instance (next-method))
(nfields (struct-ref/unboxed class class-index-nfields))
(indirect-slots-class (slot-ref class 'indirect-slots-class)))
;; Indirect slots will be last struct field.
(struct-set! instance (1- nfields) (make indirect-slots-class))
instance))
;; Called when redefining an existing binding, and the new binding is a
;; class. Two arguments: the old value, and the new.
(define-generic class-redefinition)
(define-method (class-redefinition (old <top>) (new <class>))
;; Default class-redefinition method is to just replace old binding
;; with the class.
new)
(define-method (class-redefinition (old <redefinable-class>)
(new <redefinable-class>))
;; When redefining a redefinable class with a redefinable class, we
;; migrate the old definition and its instances to become the new
;; definition.
;;
;; Work on direct methods:
;; 1. Remove accessor methods from the old class
;; 2. Patch the occurences of new in the specializers by old
;; 3. Displace the methods from old to new
(remove-class-accessors! old) ;; -1-
(let ((methods (class-direct-methods new)))
(for-each (lambda (m)
(update-direct-method! m new old)) ;; -2-
methods)
(struct-set! new
class-index-direct-methods
(append methods (class-direct-methods old))))
;; Substitute old for new in new cpl
(set-car! (struct-ref new class-index-cpl) old)
;; Remove the old class from the direct-subclasses list of its super classes
(for-each (lambda (c) (struct-set! c class-index-direct-subclasses
(delv! old (class-direct-subclasses c))))
(class-direct-supers old))
;; Replace the new class with the old in the direct-subclasses of the supers
(for-each (lambda (c)
(struct-set! c class-index-direct-subclasses
(cons old (delv! new (class-direct-subclasses c)))))
(class-direct-supers new))
;; Swap object headers
(%modify-instance old new)
;; Now old is NEW!
;; Redefine all the subclasses of old to take into account modification
(for-each
(lambda (c)
(update-direct-subclass! c new old))
(class-direct-subclasses new))
;; Invalidate class so that subsequent instance slot accesses invoke
;; change-object-class
(let ((slots-class (slot-ref new 'indirect-slots-class)))
(slot-set! slots-class '%redefined new)
(class-add-flags! slots-class vtable-flag-goops-needs-migration))
old)
(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
(when (is-a? m <accessor-method>)
(let ((gf (slot-ref m 'generic-function)))
;; remove the method from its GF
(slot-set! gf 'methods
(delq1! m (slot-ref gf 'methods)))
(invalidate-method-cache! gf)
;; remove the method from its specializers
(remove-method-in-classes! m))))
(class-direct-methods c)))
(define-method (update-direct-method! (m <method>)
(old <class>)
(new <class>))
(let loop ((l (method-specializers m)))
;; Note: the <top> in dotted list is never used.
;; So we can work as if we had only proper lists.
(when (pair? l)
(when (eqv? (car l) old)
(set-car! l new))
(loop (cdr l)))))
(define-method (update-direct-subclass! (c <class>)
(old <class>)
(new <class>))
(class-redefinition c
(make-class (class-direct-supers c)
(class-direct-slots c)
#:name (class-name c)
#:metaclass (class-of c))))
(define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class '())))
;; Initialize the slots of the new instance
(for-each
(lambda (slot)
(unless (eq? slot 'indirect-slots)
(if (and (slot-exists? old-instance slot)
(memq (%slot-definition-allocation
(class-slot-definition old-class slot))
'(#:instance #:virtual))
(slot-bound? old-instance slot))
;; Slot was present and allocated in old instance; copy it
(slot-set! new-instance slot (slot-ref old-instance slot))
;; slot was absent; initialize it with its default value
(let ((init (slot-init-function new-class slot)))
(when init
(slot-set! new-instance slot (init)))))))
(map slot-definition-name (class-slots new-class)))
;; Exchange old and new instance in place to keep pointers valid
(%modify-instance old-instance new-instance)
;; Allow class specific updates of instances (which now are swapped)
(update-instance-for-different-class new-instance old-instance)
old-instance))
(define-method (update-instance-for-different-class (old-instance <object>)
(new-instance
<object>))
;;not really important what we do, we just need a default method
new-instance)
(define-method (change-class (old-instance <object>)
(new-class <redefinable-class>))
(unless (is-a? (class-of old-instance) <redefinable-class>)
(error (string-append
"Default change-class implementation only works on"
" instances of redefinable classes")))
(change-object-class old-instance (class-of old-instance) new-class))
(define class-of-obsolete-indirect-instance
(let ((lock (make-mutex))
(stack '()))
(lambda (instance)
(let* ((new-class (struct-vtable instance))
(nfields (struct-ref/unboxed new-class class-index-nfields))
;; Indirect slots are in last instance slot. For normal
;; instances last slot is 0 of course.
(slots (struct-ref instance (1- nfields)))
(old-class (slot-ref (class-of slots) '%redefined)))
(let/ec return
(dynamic-wind
(lambda ()
(with-mutex lock
(if (memv slots stack)
(return (or old-class new-class))
(set! stack (cons slots stack)))))
(lambda ()
(when old-class
(change-class instance new-class))
new-class)
(lambda ()
(with-mutex lock
(set! stack (delq! slots stack))))))))))
;;;
;;; {Final initialization}
;;;
;; Tell C code that the main bulk of Goops has been loaded
(%goops-loaded)
;;;
;;; {SMOB and port classes}
;;;
(define <promise> (find-subclass <top> '<promise>))
(define <thread> (find-subclass <top> '<thread>))
(define <mutex> (find-subclass <top> '<mutex>))
(define <condition-variable> (find-subclass <top> '<condition-variable>))
(define <regexp> (find-subclass <top> '<regexp>))
(define <hook> (find-subclass <top> '<hook>))
(define <bitvector> (find-subclass <top> '<bitvector>))
(define <random-state> (find-subclass <top> '<random-state>))
(define <directory> (find-subclass <top> '<directory>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))
(define <guardian> (find-subclass <applicable> '<guardian>))
(define <macro> (find-subclass <top> '<macro>))
;; <dynamic-object> used to be a SMOB type, albeit not exported even to
;; C. However now it's a record type, though still private. Cross our
;; fingers that nobody is using it in anger!
(define <dynamic-object>
(module-ref (resolve-module '(system foreign-library)) '<foreign-library>))
(define (define-class-subtree class)
(define! (class-name class) class)
(for-each define-class-subtree (class-direct-subclasses class)))
(define-class-subtree (find-subclass <port> '<file-port>))
View git blame Copy permalink