-;;; installed-scm-file
-
-;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
+;;;; goops.scm -- The Guile Object-Oriented Programming System
+;;;;
+;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 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
(define-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
- #:use-module (oop goops util)
- #:use-module (system base target)
+ #: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-extended-generic define-extended-generics
goops-error
min-fixnum max-fixnum
-;;; *fixme* Should go into goops.c
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- slot-exists-using-class? slot-ref slot-set! slot-bound?
+ 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
method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword)
- #:no-backtrace)
+ make find-method get-keyword))
-;; XXX FIXME: figure out why the 'eval-when's in this file must use
-;; 'compile' and must avoid 'expand', but only in 2.2, and only when
-;; compiling something that imports goops, e.g. (ice-9 occam-channel),
-;; before (oop goops) itself has been compiled.
-;; First initialize the builtin part of GOOPS
-(eval-when (compile load eval)
+;;;
+;;; 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"))
-
-(eval-when (compile load eval)
- (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
+ "scm_init_goops_builtins")
(add-interesting-primitive! 'class-of))
+
+\f
+
+;;;
+;;; We then define the slots that must appear in all classes (<class>
+;;; objects) and slot definitions (<slot> objects). These slots must
+;;; appear in order. We'll use this list to statically compute offsets
+;;; for the various fields, to compute the struct layout for <class>
+;;; instances, and to compute the slot definition lists for <class>.
+;;; Because the list is needed at expansion-time, we define it as a
+;;; macro.
+;;;
(define-syntax macro-fold-left
(syntax-rules ()
((_ folder seed ()) seed)
((_ folder seed (head . tail))
(folder head (macro-fold-right folder seed tail)))))
-(define-syntax fold-<class>-slots
- (lambda (x)
- (define slots
- '((layout <protected-read-only-slot>)
- (flags <hidden-slot>)
- (self <self-slot>)
- (instance-finalizer <hidden-slot>)
- (print)
- (name <protected-hidden-slot>)
- (nfields <hidden-slot>)
- (%reserved <hidden-slot>)
- (redefined)
- (direct-supers)
- (direct-slots)
- (direct-subclasses)
- (direct-methods)
- (cpl)
- (slots)
- (getters-n-setters)))
- (syntax-case x ()
- ((_ fold visit seed)
- ;; The datum->syntax makes it as if the identifiers in `slots'
- ;; were present in the initial form, which allows them to be used
- ;; as (components of) introduced identifiers.
- #`(fold visit seed #,(datum->syntax #'visit slots))))))
-
-;; Define class-index-layout to 0, class-index-flags to 1, and so on.
-(let-syntax ((define-class-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 #,(id-append #'name #'class-index- #'name)
- #,(tail-length #'tail))
- tail))))))
- (fold-<class>-slots macro-fold-left define-class-index (begin)))
+(define-syntax-rule (define-macro-folder macro-folder value ...)
+ (define-syntax macro-folder
+ (lambda (x)
+ (syntax-case x ()
+ ((_ fold visit seed)
+ ;; The datum->syntax makes it as if each `value' were present
+ ;; in the initial form, which allows them to be used as
+ ;; (components of) introduced identifiers.
+ #`(fold visit seed #,(datum->syntax #'visit '(value ...))))))))
+
+(define-macro-folder fold-class-slots
+ (layout #:class <protected-read-only-slot>)
+ (flags #:class <hidden-slot>)
+ (self #:class <self-slot>)
+ (instance-finalizer #:class <hidden-slot>)
+ (print)
+ (name #:class <protected-hidden-slot>)
+ (nfields #:class <hidden-slot>)
+ (%reserved #:class <hidden-slot>)
+ (redefined)
+ (direct-supers)
+ (direct-slots)
+ (direct-subclasses)
+ (direct-methods)
+ (cpl)
+ (slots))
+
+(define-macro-folder fold-slot-slots
+ (name #:init-keyword #:name)
+ (allocation #:init-keyword #:allocation #:init-value #:instance)
+ (init-keyword #:init-keyword #:init-keyword #:init-value #f)
+ (init-form #:init-keyword #:init-form)
+ (init-value #:init-keyword #:init-value)
+ (init-thunk #:init-keyword #:init-thunk #:init-value #f)
+ (options)
+ (getter #:init-keyword #:getter #:init-value #f)
+ (setter #:init-keyword #:setter #:init-value #f)
+ (accessor #:init-keyword #:accessor #:init-value #f)
+ ;; These last don't have #:init-keyword because they are meant to be
+ ;; set by `allocate-slots', not in compute-effective-slot-definition.
+ (slot-ref #:init-value #f)
+ (slot-set! #:init-value #f)
+ (index #:init-value #f)
+ (size #:init-value #f))
+
+;;;
+;;; Statically define variables for slot offsets: `class-index-layout'
+;;; will be 0, `class-index-flags' will be 1, and so on, and the same
+;;; for `slot-index-name' and such for <slot>.
+;;;
+(let-syntax ((define-slot-indexer
+ (syntax-rules ()
+ ((_ define-index prefix)
+ (define-syntax define-index
+ (lambda (x)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a)
+ (syntax->datum b))))
+ (define (tail-length tail)
+ (syntax-case tail ()
+ ((begin) 0)
+ ((visit head tail) (1+ (tail-length #'tail)))))
+ (syntax-case x ()
+ ((_ (name . _) tail)
+ #`(begin
+ (define-syntax #,(id-append #'name #'prefix #'name)
+ (identifier-syntax #,(tail-length #'tail)))
+ tail)))))))))
+ (define-slot-indexer define-class-index class-index-)
+ (define-slot-indexer define-slot-index slot-index-)
+ (fold-class-slots macro-fold-left define-class-index (begin))
+ (fold-slot-slots macro-fold-left define-slot-index (begin)))
+
+;;;
+;;; Structs that are vtables have a "flags" slot, which corresponds to
+;;; class-index-flags. `vtable-flag-vtable' indicates that instances of
+;;; a vtable are themselves vtables, and `vtable-flag-validated'
+;;; indicates that the struct's layout has been validated. goops.c
+;;; defines a few additional flags: one to indicate that a vtable is
+;;; actually a class, one to indicate that the class is "valid" (meaning
+;;; that it hasn't been redefined), and one to indicate that instances
+;;; of a class are slot definition objects (<slot> instances).
+;;;
+(define vtable-flag-goops-metaclass
+ (logior vtable-flag-vtable vtable-flag-goops-class))
+
+(define-inlinable (class-add-flags! class flags)
+ (struct-set! class class-index-flags
+ (logior flags (struct-ref class class-index-flags))))
+
+(define-inlinable (class-clear-flags! class flags)
+ (struct-set! class class-index-flags
+ (logand (lognot flags) (struct-ref class class-index-flags))))
+
+(define-inlinable (class-has-flags? class flags)
+ (eqv? flags
+ (logand (struct-ref class class-index-flags) flags)))
+
+(define-inlinable (class? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
+
+(define-inlinable (slot? obj)
+ (and (struct? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
+
+(define-inlinable (instance? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
+
+;;;
+;;; Now that we know the slots that must be present in classes, and
+;;; their offsets, we can create the root of the class hierarchy.
+;;;
+;;; Note that the `direct-supers', `direct-slots', `cpl', and `slots'
+;;; fields will be updated later, once we can create slot definition
+;;; objects and once we have definitions for <top> and <object>.
+;;;
+(define <class>
+ (let-syntax ((cons-layout
+ ;; A simple way to compute class layout for the concrete
+ ;; types used in <class>.
+ (syntax-rules (<protected-read-only-slot>
+ <self-slot>
+ <hidden-slot>
+ <protected-hidden-slot>)
+ ((_ (name) tail)
+ (string-append "pw" tail))
+ ((_ (name #:class <protected-read-only-slot>) tail)
+ (string-append "pr" tail))
+ ((_ (name #:class <self-slot>) tail)
+ (string-append "sr" tail))
+ ((_ (name #:class <hidden-slot>) tail)
+ (string-append "uh" tail))
+ ((_ (name #:class <protected-hidden-slot>) tail)
+ (string-append "ph" tail)))))
+ (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
+ (nfields (/ (string-length layout) 2))
+ (<class> (%make-vtable-vtable layout)))
+ (class-add-flags! <class> (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
+ (struct-set! <class> class-index-name '<class>)
+ (struct-set! <class> class-index-nfields nfields)
+ (struct-set! <class> class-index-direct-supers '())
+ (struct-set! <class> class-index-direct-slots '())
+ (struct-set! <class> class-index-direct-subclasses '())
+ (struct-set! <class> class-index-direct-methods '())
+ (struct-set! <class> class-index-cpl '())
+ (struct-set! <class> class-index-slots '())
+ (struct-set! <class> class-index-redefined #f)
+ <class>)))
+;;;
+;;; Accessors to fields of <class>.
+;;;
(define-syntax-rule (define-class-accessor name docstring field)
(define (name obj)
docstring
"Return the slot list of the class @var{obj}."
class-index-slots)
-;;
-;; is-a?
-;;
+(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))
-;;; The standard class precedence list computation algorithm
+\f
+
;;;
-;;; Correct behaviour:
+;;; 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-class food ())
-;;; (define-class fruit (food))
-;;; (define-class spice (food))
-;;; (define-class apple (fruit))
-;;; (define-class cinnamon (spice))
-;;; (define-class pie (apple cinnamon))
-;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
+(define* (get-keyword key l #:optional default)
+ "Determine an associated value for the keyword @var{key} from the list
+@var{l}. The list @var{l} has to consist of an even number of elements,
+where, starting with the first, every second element is a keyword,
+followed by its associated value. If @var{l} does not hold a value for
+@var{key}, the value @var{default} is returned."
+ (unless (keyword? key)
+ (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
+ (let lp ((l l))
+ (match l
+ (() default)
+ ((kw arg . l)
+ (unless (keyword? kw)
+ (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
+ (if (eq? kw key) arg (lp l))))))
+
+(define *unbound* (list 'unbound))
+
+(define-inlinable (unbound? x)
+ (eq? x *unbound*))
+
+(define (%allocate-instance class)
+ (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
+ (%clear-fields! obj *unbound*)
+ obj))
+
+(define <slot>
+ (let-syntax ((cons-layout
+ ;; All slots are "pw" in <slot>.
+ (syntax-rules ()
+ ((_ _ tail) (string-append "pw" tail)))))
+ (let* ((layout (fold-slot-slots macro-fold-right cons-layout ""))
+ (nfields (/ (string-length layout) 2))
+ (<slot> (make-struct/no-tail <class> (make-struct-layout layout))))
+ (class-add-flags! <slot> (logior vtable-flag-goops-class
+ vtable-flag-goops-slot
+ vtable-flag-goops-valid))
+ (struct-set! <slot> class-index-name '<slot>)
+ (struct-set! <slot> class-index-nfields nfields)
+ (struct-set! <slot> class-index-direct-supers '())
+ (struct-set! <slot> class-index-direct-slots '())
+ (struct-set! <slot> class-index-direct-subclasses '())
+ (struct-set! <slot> class-index-direct-methods '())
+ (struct-set! <slot> class-index-cpl (list <slot>))
+ (struct-set! <slot> class-index-slots '())
+ (struct-set! <slot> class-index-redefined #f)
+ <slot>)))
+
+;;; Access to slot objects is performance-sensitive for slot-ref, so in
+;;; addition to the type-checking accessors that we export, we also
+;;; define some internal inlined helpers that just do an unchecked
+;;; struct-ref in cases where we know the object must be a slot, as
+;;; when accessing class-slots.
+;;;
+(define-syntax-rule (define-slot-accessor name docstring %name field)
+ (begin
+ (define-syntax-rule (%name obj)
+ (struct-ref obj field))
+ (define (name obj)
+ docstring
+ (unless (slot? obj)
+ (scm-error 'wrong-type-arg #f "Not a slot: ~S"
+ (list obj) #f))
+ (%name obj))))
+
+(define-slot-accessor slot-definition-name
+ "Return the name of @var{obj}."
+ %slot-definition-name slot-index-name)
+(define-slot-accessor slot-definition-allocation
+ "Return the allocation of the slot @var{obj}."
+ %slot-definition-allocation slot-index-allocation)
+(define-slot-accessor slot-definition-init-keyword
+ "Return the init keyword of the slot @var{obj}, or @code{#f}."
+ %slot-definition-init-keyword slot-index-init-keyword)
+(define-slot-accessor slot-definition-init-form
+ "Return the init form of the slot @var{obj}, or the unbound value"
+ %slot-definition-init-form slot-index-init-form)
+(define-slot-accessor slot-definition-init-value
+ "Return the init value of the slot @var{obj}, or the unbound value."
+ %slot-definition-init-value slot-index-init-value)
+(define-slot-accessor slot-definition-init-thunk
+ "Return the init thunk of the slot @var{obj}, or @code{#f}."
+ %slot-definition-init-thunk slot-index-init-thunk)
+(define-slot-accessor slot-definition-options
+ "Return the initargs given when creating the slot @var{obj}."
+ %slot-definition-options slot-index-options)
+(define-slot-accessor slot-definition-getter
+ "Return the getter of the slot @var{obj}, or @code{#f}."
+ %slot-definition-getter slot-index-getter)
+(define-slot-accessor slot-definition-setter
+ "Return the setter of the slot @var{obj}, or @code{#f}."
+ %slot-definition-setter slot-index-setter)
+(define-slot-accessor slot-definition-accessor
+ "Return the accessor of the slot @var{obj}, or @code{#f}."
+ %slot-definition-accessor slot-index-accessor)
+(define-slot-accessor slot-definition-slot-ref
+ "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}."
+ %slot-definition-slot-ref slot-index-slot-ref)
+(define-slot-accessor slot-definition-slot-set!
+ "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}."
+ %slot-definition-slot-set! slot-index-slot-set!)
+(define-slot-accessor slot-definition-index
+ "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."
+ %slot-definition-index slot-index-index)
+(define-slot-accessor slot-definition-size
+ "Return the number fields used by the slot @var{obj}, or @code{#f}."
+ %slot-definition-size slot-index-size)
+
+;; Boot definition.
+(define (direct-slot-definition-class class initargs)
+ (get-keyword #:class initargs <slot>))
+
+;; Boot definition.
+(define (make-slot class initargs)
+ (let ((slot (make-struct/no-tail class)))
+ (define-syntax-rule (init-slot offset kw default)
+ (struct-set! slot offset (get-keyword kw initargs default)))
+ (init-slot slot-index-name #:name #f)
+ (init-slot slot-index-allocation #:allocation #:instance)
+ (init-slot slot-index-init-keyword #:init-keyword #f)
+ (init-slot slot-index-init-form #:init-form *unbound*)
+ (init-slot slot-index-init-value #:init-value *unbound*)
+ (struct-set! slot slot-index-init-thunk
+ (or (get-keyword #:init-thunk initargs #f)
+ (let ((val (%slot-definition-init-value slot)))
+ (if (unbound? val)
+ #f
+ (lambda () val)))))
+ (struct-set! slot slot-index-options initargs)
+ (init-slot slot-index-getter #:getter #f)
+ (init-slot slot-index-setter #:setter #f)
+ (init-slot slot-index-accessor #:accessor #f)
+ (init-slot slot-index-slot-ref #:slot-ref #f)
+ (init-slot slot-index-slot-set! #:slot-set! #f)
+ (init-slot slot-index-index #:index #f)
+ (init-slot slot-index-size #:size #f)
+ slot))
+
+;; Boot definition.
+(define (make class . args)
+ (unless (memq <slot> (class-precedence-list class))
+ (error "Unsupported class: ~S" class))
+ (make-slot class args))
+
+;; Boot definition.
+(define (compute-direct-slot-definition class initargs)
+ (apply make (direct-slot-definition-class class initargs) initargs))
+
+(define (compute-direct-slot-definition-initargs class slot-spec)
+ (match slot-spec
+ ((? symbol? name) (list #:name name))
+ (((? symbol? name) . initargs)
+ (cons* #:name name
+ ;; If there is an #:init-form, the `class' macro will have
+ ;; already added an #:init-thunk. Still, if there isn't an
+ ;; #:init-thunk already but we do have an #:init-value,
+ ;; synthesize an #:init-thunk initarg. This will ensure
+ ;; that the #:init-thunk gets passed on to the effective
+ ;; slot definition too.
+ (if (get-keyword #:init-thunk initargs)
+ initargs
+ (let ((value (get-keyword #:init-value initargs *unbound*)))
+ (if (unbound? value)
+ initargs
+ (cons* #:init-thunk (lambda () value) initargs))))))))
+
+(let ()
+ (define-syntax cons-slot
+ (syntax-rules ()
+ ((_ (name #:class class) tail)
+ ;; Special case to avoid referencing specialized <slot> kinds,
+ ;; which are not defined yet.
+ (cons (list 'name) tail))
+ ((_ (name . initargs) tail)
+ (cons (list 'name . initargs) tail))))
+ (define-syntax-rule (initialize-direct-slots! class fold-slots)
+ (let ((specs (fold-slots macro-fold-right cons-slot '())))
+ (define (make-direct-slot-definition spec)
+ (let ((initargs (compute-direct-slot-definition-initargs class spec)))
+ (compute-direct-slot-definition class initargs)))
+ (struct-set! class class-index-direct-slots
+ (map make-direct-slot-definition specs))))
+
+ (initialize-direct-slots! <class> fold-class-slots)
+ (initialize-direct-slots! <slot> fold-slot-slots))
+
+
+\f
+
;;;
-;;; (define-class d ())
-;;; (define-class e ())
-;;; (define-class f ())
-;;; (define-class b (d e))
-;;; (define-class c (e f))
-;;; (define-class a (b c))
-;;; => cpl (a) = a b d c e f object top
+;;; 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))
(and (not (null? l))
(candidate (car l)))))
(next (any candidate-car inputs)))
- (if (not next)
- (goops-error "merge-lists: Inconsistent precedence graph"))
+ (unless next
+ (goops-error "merge-lists: Inconsistent precedence graph"))
(let ((remove-next (lambda (l)
(if (eq? (car l) next)
(cdr l)
c-direct-supers)
(list c-direct-supers))))))
-;; Bootstrap version.
+;; 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 (check-cpl slots class-slots)
- (when (or-map (lambda (slot-def) (assq (car slot-def) slots))
- class-slots)
+ (define (slot-memq slot slots)
+ (let ((name (%slot-definition-name slot)))
+ (let lp ((slots slots))
+ (match slots
+ (() #f)
+ ((slot . slots)
+ (or (eq? (%slot-definition-name slot) name) (lp slots)))))))
+ (define (check-cpl slots static-slots)
+ (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
(scm-error 'misc-error #f
- "a predefined <class> inherited field cannot be redefined"
+ "a predefined static inherited field cannot be redefined"
'() '())))
(define (remove-duplicate-slots slots)
(let lp ((slots (reverse slots)) (res '()) (seen '()))
- (cond
- ((null? slots) res)
- ((memq (caar slots) seen)
- (lp (cdr slots) res seen))
- (else
- (lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen))))))
- (let* ((class-slots (and (memq <class> cpl)
- (struct-ref <class> class-index-slots))))
- (when class-slots
- (check-cpl dslots class-slots))
- (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
- (if (null? cpl)
- (remove-duplicate-slots (append class-slots res))
- (let* ((head (car cpl))
- (cpl (cdr cpl))
- (new-slots (struct-ref head class-index-direct-slots)))
- (cond
- ((not class-slots)
- (lp cpl (append new-slots res) class-slots))
- ((eq? head <class>)
- ;; Move class slots to the head of the list.
- (lp cpl res new-slots))
- (else
- (check-cpl new-slots class-slots)
- (lp cpl (append new-slots res) class-slots))))))))
-
-(define (%compute-getters-n-setters slots)
- (define (compute-init-thunk options)
- (cond
- ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val)))
- ((kw-arg-ref options #:init-thunk))
- (else #f)))
- (let lp ((slots slots) (n 0))
- (match slots
- (() '())
- (((name . options) . slots)
- (cons (cons name (cons (compute-init-thunk options) n))
- (lp slots (1+ n)))))))
-
-(define (%compute-layout slots getters-n-setters nfields is-class?)
- (define (instance-allocated? g-n-s)
- (match g-n-s
- ((name init-thunk . (? exact-integer? index)) #t)
- ((name init-thunk getter setter index size) #t)
- (_ #f)))
-
- (define (allocated-index g-n-s)
- (match g-n-s
- ((name init-thunk . (? exact-integer? index)) index)
- ((name init-thunk getter setter index size) index)))
-
- (define (allocated-size g-n-s)
- (match g-n-s
- ((name init-thunk . (? exact-integer? index)) 1)
- ((name init-thunk getter setter index size) size)))
+ (match slots
+ (() res)
+ ((slot . slots)
+ (let ((name (%slot-definition-name slot)))
+ (if (memq name seen)
+ (lp slots res seen)
+ (lp slots (cons slot res) (cons name seen))))))))
+ ;; For subclases of <class> and <slot>, we need to ensure that the
+ ;; <class> or <slot> slots come first.
+ (let* ((static-slots (cond
+ ((memq <class> cpl)
+ (when (memq <slot> cpl) (error "invalid class"))
+ (struct-ref <class> class-index-slots))
+ ((memq <slot> cpl)
+ (struct-ref <slot> class-index-slots))
+ (else #f))))
+ (when static-slots
+ (check-cpl dslots static-slots))
+ (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
+ (match cpl
+ (() (remove-duplicate-slots (append static-slots res)))
+ ((head . cpl)
+ (let ((new-slots (struct-ref head class-index-direct-slots)))
+ (cond
+ ((not static-slots)
+ (lp cpl (append new-slots res) static-slots))
+ ((or (eq? head <class>) (eq? head <slot>))
+ ;; Move static slots to the head of the list.
+ (lp cpl res new-slots))
+ (else
+ (check-cpl new-slots static-slots)
+ (lp cpl (append new-slots res) static-slots)))))))))
- (define (slot-protection-and-kind options)
+;; Boot definition.
+(define (compute-get-n-set class slot)
+ (let ((index (struct-ref class class-index-nfields)))
+ (struct-set! class class-index-nfields (1+ index))
+ index))
+
+(define (allocate-slots class slots)
+ "Transform the computed list of direct slot definitions @var{slots}
+into a corresponding list of effective slot definitions, allocating
+slots as we go."
+ (define (make-effective-slot-definition slot)
+ ;; `compute-get-n-set' is expected to mutate `nfields' if it
+ ;; allocates a field to the object. Pretty strange, but we preserve
+ ;; the behavior for backward compatibility.
+ (let* ((slot (compute-effective-slot-definition class slot))
+ (index (struct-ref class class-index-nfields))
+ (g-n-s (compute-get-n-set class slot))
+ (size (- (struct-ref class class-index-nfields) index)))
+ (call-with-values
+ (lambda ()
+ (match g-n-s
+ ((? integer?)
+ (unless (= size 1)
+ (error "unexpected return from compute-get-n-set"))
+ (values #f #f))
+ (((? procedure? get) (? procedure? set))
+ (values get set))))
+ (lambda (get set)
+ (struct-set! slot slot-index-index index)
+ (struct-set! slot slot-index-size size)
+ (struct-set! slot slot-index-slot-ref get)
+ (struct-set! slot slot-index-slot-set! set)))
+ slot))
+ (struct-set! class class-index-nfields 0)
+ (map-in-order make-effective-slot-definition slots))
+
+(define (%compute-layout slots nfields is-class?)
+ (define (slot-protection-and-kind slot)
(define (subclass? class parent)
(memq parent (class-precedence-list class)))
- (let ((type (kw-arg-ref options #:class)))
+ (let ((type (kw-arg-ref (%slot-definition-options slot) #:class)))
(if (and type (subclass? type <foreign-slot>))
(values (cond
((subclass? type <self-slot>) #\s)
((subclass? type <hidden-slot>) #\h)
(else #\w)))
(values #\p #\w))))
-
(let ((layout (make-string (* nfields 2))))
- (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
- (match getters-n-setters
+ (let lp ((n 0) (slots slots))
+ (match slots
(()
(unless (= n nfields) (error "bad nfields"))
- (unless (null? slots) (error "inconsistent g-n-s/slots"))
(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)
- ((g-n-s . getters-n-setters)
- (match slots
- (((name . options) . slots)
- (cond
- ((instance-allocated? g-n-s)
- (unless (< n nfields) (error "bad nfields"))
- (unless (= n (allocated-index g-n-s)) (error "bad allocation"))
- (call-with-values (lambda () (slot-protection-and-kind options))
- (lambda (protection kind)
- (let init ((n n) (size (allocated-size g-n-s)))
- (cond
- ((zero? size) (lp n slots getters-n-setters))
- (else
- (string-set! layout (* n 2) protection)
- (string-set! layout (1+ (* n 2)) kind)
- (init (1+ n) (1- size))))))))
- (else
- (lp n slots getters-n-setters))))))))))
+ ((slot . slots)
+ (unless (= n (%slot-definition-index slot)) (error "bad allocation"))
+ (call-with-values (lambda () (slot-protection-and-kind slot))
+ (lambda (protection kind)
+ (let init ((n n) (size (%slot-definition-size slot)))
+ (cond
+ ((zero? size) (lp n slots))
+ (else
+ (unless (< n nfields) (error "bad nfields"))
+ (string-set! layout (* n 2) protection)
+ (string-set! layout (1+ (* n 2)) kind)
+ (init (1+ n) (1- size))))))))))))
+
+
+\f
+;;;
+;;; With all of this, we are now able to define subclasses of <class>.
+;;;
(define (%prep-layout! class)
(let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
- (layout (%compute-layout
- (struct-ref class class-index-slots)
- (struct-ref class class-index-getters-n-setters)
- (struct-ref class class-index-nfields)
- is-class?)))
+ (layout (%compute-layout (struct-ref class class-index-slots)
+ (struct-ref class class-index-nfields)
+ is-class?)))
(%init-layout! class layout)))
(define (make-standard-class class name dsupers dslots)
(let ((z (make-struct/no-tail class)))
+ (define (make-direct-slot-definition dslot)
+ (let ((initargs (compute-direct-slot-definition-initargs z dslot)))
+ (compute-direct-slot-definition z initargs)))
+
+ (struct-set! z class-index-name name)
+ (struct-set! z class-index-nfields 0)
(struct-set! z class-index-direct-supers dsupers)
- (let* ((cpl (compute-cpl z))
- (dslots (map (lambda (slot)
- (if (pair? slot) slot (list slot)))
- dslots))
- (slots (build-slots-list dslots cpl))
- (nfields (length slots))
- (g-n-s (%compute-getters-n-setters slots)))
- (struct-set! z class-index-name name)
- (struct-set! z class-index-nfields nfields)
- (struct-set! z class-index-direct-slots dslots)
- (struct-set! z class-index-direct-subclasses '())
- (struct-set! z class-index-direct-methods '())
+ (struct-set! z class-index-direct-subclasses '())
+ (struct-set! z class-index-direct-methods '())
+ (struct-set! z class-index-redefined #f)
+ (let ((cpl (compute-cpl z)))
(struct-set! z class-index-cpl cpl)
- (struct-set! z class-index-slots slots)
- (struct-set! z class-index-getters-n-setters g-n-s)
- (struct-set! z class-index-redefined #f)
- (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)
- (%inherit-magic! z dsupers)
- z)))
-
-(define <class>
- (let-syntax ((cons-dslot
- ;; The specialized slot classes have not been defined
- ;; yet; initialize <class> with unspecialized slots.
- (syntax-rules ()
- ((_ (name) tail) (cons (list 'name) tail))
- ((_ (name class) tail) (cons (list 'name) tail))))
- (cons-layout
- ;; A simple way to compute class layout for the concrete
- ;; types used in <class>.
- (syntax-rules (<protected-read-only-slot> <self-slot>
- <hidden-slot> <protected-hidden-slot>)
- ((_ (name) tail)
- (string-append "pw" tail))
- ((_ (name <protected-read-only-slot>) tail)
- (string-append "pr" tail))
- ((_ (name <self-slot>) tail)
- (string-append "sr" tail))
- ((_ (name <hidden-slot>) tail)
- (string-append "uh" tail))
- ((_ (name <protected-hidden-slot>) tail)
- (string-append "ph" tail)))))
- (let* ((dslots (fold-<class>-slots macro-fold-right cons-dslot '()))
- (layout (fold-<class>-slots macro-fold-right cons-layout ""))
- (<class> (%make-root-class layout)))
- ;; The `direct-supers', `direct-slots', `cpl', `slots', and
- ;; `getters-n-setters' fields will be updated later.
- (struct-set! <class> class-index-name '<class>)
- (struct-set! <class> class-index-nfields (length dslots))
- (struct-set! <class> class-index-direct-supers '())
- (struct-set! <class> class-index-direct-slots dslots)
- (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 dslots)
- (struct-set! <class> class-index-getters-n-setters
- (%compute-getters-n-setters dslots))
- (struct-set! <class> class-index-redefined #f)
- <class>)))
+ (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 ...) slot ...)
(define-standard-class name (super ...) #:metaclass <class> slot ...))))
+
+\f
+
+;;;
+;;; Sweet! Now we can define <top> and <object>, and finish
+;;; initializing the `direct-subclasses', `direct-supers', and `cpl'
+;;; slots of <class>.
+;;;
(define-standard-class <top> ())
(define-standard-class <object> (<top>))
-;; <top>, <object>, and <class> were partially initialized. Correct
-;; them here.
-(struct-set! <object> class-index-direct-subclasses (list <class>))
+;; 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>))
+
-(define-standard-class <foreign-slot> (<top>))
+\f
+
+;;;
+;;; We can also define the various slot types, and finish initializing
+;;; `direct-slots' and `slots' on <class> and <slot>.
+;;;
+(define-standard-class <foreign-slot> (<slot>))
(define-standard-class <protected-slot> (<foreign-slot>))
(define-standard-class <hidden-slot> (<foreign-slot>))
(define-standard-class <opaque-slot> (<foreign-slot>))
(define-standard-class <float-slot> (<foreign-slot>))
(define-standard-class <double-slot> (<foreign-slot>))
-;; Finish initialization of <class> with specialized slots.
-(let-syntax ((visit
- (syntax-rules ()
- ((_ (name) tail)
- (cons (list 'name) tail))
- ((_ (name class) tail)
- (cons (list 'name #:class class) tail)))))
- (let* ((dslots (fold-<class>-slots macro-fold-right visit '()))
- (g-n-s (%compute-getters-n-setters dslots)))
- (struct-set! <class> class-index-direct-slots dslots)
- (struct-set! <class> class-index-slots dslots)
- (struct-set! <class> class-index-getters-n-setters g-n-s)))
-
-;; Applicables and their classes.
+
+\f
+
+;;;
+;;; Finally! Initialize `direct-slots' and `slots' on <class>, and
+;;; `slots' on <slot>.
+;;;
+(let ()
+ (define-syntax-rule (cons-slot (name . initargs) tail)
+ (cons (list 'name . initargs) tail))
+ (define-syntax-rule (initialize-direct-slots! class fold-slots)
+ (let ((specs (fold-slots macro-fold-right cons-slot '())))
+ (define (make-direct-slot-definition spec)
+ (let ((initargs (compute-direct-slot-definition-initargs class spec)))
+ (compute-direct-slot-definition class initargs)))
+ (struct-set! class class-index-direct-slots
+ (map make-direct-slot-definition specs))))
+ (define (initialize-slots! class)
+ (let ((slots (build-slots-list (class-direct-slots class)
+ (class-precedence-list class))))
+ (struct-set! class class-index-slots (allocate-slots class slots))))
+
+ ;; Finish initializing <class> with the specialized slot kinds.
+ (initialize-direct-slots! <class> fold-class-slots)
+
+ (initialize-slots! <class>)
+ (initialize-slots! <slot>))
+
+
+\f
+
+;;;
+;;; Now, to build out the class hierarchy.
+;;;
+
(define-standard-class <procedure-class> (<class>))
+
(define-standard-class <applicable-struct-class>
(<procedure-class>))
+(class-add-flags! <applicable-struct-class>
+ vtable-flag-applicable-vtable)
+
(define-standard-class <applicable-struct-with-setter-class>
(<applicable-struct-class>))
-(%bless-applicable-struct-vtables! <applicable-struct-class>
- <applicable-struct-with-setter-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>)
<extended-generic-with-setter>)
#:metaclass <applicable-struct-with-setter-class>)
-;; Methods
(define-standard-class <method> (<object>)
generic-function
specializers
(define-standard-class <accessor-method> (<method>)
(slot-definition #:init-keyword #:slot-definition))
-;; Primitive types classes
(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 <output-port> (<port>))
(define-standard-class <input-output-port> (<input-port> <output-port>))
+(define (inherit-applicable! class)
+ "An internal routine to redefine a SMOB class that was added after
+GOOPS was loaded, and on which scm_set_smob_apply installed an apply
+function."
+ ;; Why not use class-redefinition? We would, except that loading the
+ ;; compiler to compile effective methods can happen while GOOPS has
+ ;; only been partially loaded, and loading the compiler might cause
+ ;; SMOB types to be defined that need this facility. Instead we make
+ ;; a very specific hack, not a general solution. Probably the right
+ ;; solution is to avoid using the compiler, but that is another kettle
+ ;; of fish.
+ (unless (memq <applicable> (class-precedence-list class))
+ (unless (null? (class-slots class))
+ (error "SMOB object has slots?"))
+ (for-each
+ (lambda (super)
+ (let ((subclasses (struct-ref super class-index-direct-subclasses)))
+ (struct-set! super class-index-direct-subclasses
+ (delq class subclasses))))
+ (struct-ref class class-index-direct-supers))
+ (struct-set! class class-index-direct-supers (list <applicable>))
+ (struct-set! class class-index-cpl (compute-cpl class))
+ (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
+ (struct-set! <applicable> class-index-direct-subclasses
+ (cons class subclasses)))))
+
+
+\f
+
+;;;
+;;; At this point we have defined the class hierarchy, and it's time to
+;;; move on to instance allocation and generics. Once we have generics,
+;;; we'll fill out the metaobject protocol.
+;;;
+;;; Here we define a limited version of `make', so that we can allocate
+;;; instances of specific classes. This definition will be replaced
+;;; later.
+;;;
(define (%invalidate-method-cache! gf)
- (slot-set! gf 'procedure (delayed-compile gf))
- (slot-set! gf 'effective-methods '()))
+ (slot-set! gf 'effective-methods '())
+ (recompute-generic-function-dispatch-procedure! gf))
;; Boot definition.
(define (invalidate-method-cache! gf)
(%invalidate-method-cache! gf))
-(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))))))
-
-;; A simple make which will be redefined later. This version handles
-;; only creation of gf, methods and classes (no instances).
-;;
-;; Since this code will disappear when Goops will be fully booted,
-;; no precaution is taken to be efficient.
-;;
(define (make class . args)
(cond
((or (eq? class <generic>) (eq? class <accessor>))
(slot-set! z 'setter setter))))
z))
(else
- (let ((z (%allocate-instance class args)))
+ (let ((z (%allocate-instance class)))
(cond
((or (eq? class <method>) (eq? class <accessor-method>))
(for-each (match-lambda
(#:body body ())
(#:make-procedure make-procedure #f))))
((memq <class> (class-precedence-list class))
+ (class-add-flags! z (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
(for-each (match-lambda
((kw slot default)
(slot-set! z slot (get-keyword kw args default))))
'((#:name name ???)
(#:dsupers direct-supers ())
- (#:slots direct-slots ())
- )))
+ (#:slots direct-slots ()))))
(else
(error "boot `make' does not support this class" class)))
z))))
-;; In the future, this function will return the effective slot
-;; definition associated with SLOT_NAME. Now it just returns some of
-;; the information which will be stored in the effective slot
-;; definition.
-;;
-(define (get-slot-value-using-name class obj slot-name)
- (match (assq slot-name (struct-ref class class-index-getters-n-setters))
- (#f (slot-missing class obj slot-name))
- ((name init-thunk . (? exact-integer? index))
- (struct-ref obj index))
- ((name init-thunk getter setter . _)
- (getter obj))))
-
-(define (set-slot-value-using-name! class obj slot-name value)
- (match (assq slot-name (struct-ref class class-index-getters-n-setters))
- (#f (slot-missing class obj slot-name value))
- ((name init-thunk . (? exact-integer? index))
- (struct-set! obj index value))
- ((name init-thunk getter setter . _)
- (setter obj value))))
-
-(define (test-slot-existence class obj slot-name)
- (and (assq slot-name (struct-ref class class-index-getters-n-setters))
- #t))
-
-;; ========================================
-
-(define (check-slot-args class obj slot-name)
- (unless (class? class)
- (scm-error 'wrong-type-arg #f "Not a class: ~S"
- (list class) #f))
- (unless (is-a? obj <object>)
- (scm-error 'wrong-type-arg #f "Not an instance: ~S"
- (list obj) #f))
- (unless (symbol? slot-name)
- (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
- (list slot-name) #f)))
-
-(define (slot-ref-using-class class obj slot-name)
- (check-slot-args class obj slot-name)
- (let ((val (get-slot-value-using-name class obj slot-name)))
- (if (unbound? val)
- (slot-unbound class obj slot-name)
- val)))
-
-(define (slot-set-using-class! class obj slot-name value)
- (check-slot-args class obj slot-name)
- (set-slot-value-using-name! class obj slot-name value))
-
-(define (slot-bound-using-class? class obj slot-name)
- (check-slot-args class obj slot-name)
- (not (unbound? (get-slot-value-using-name class obj slot-name))))
-
-(define (slot-exists-using-class? class obj slot-name)
- (check-slot-args class obj slot-name)
- (test-slot-existence class obj slot-name))
-
-;; Class redefinition protocol:
-;;
-;; A class is represented by a heap header h1 which points to a
-;; malloc:ed memory block m1.
-;;
-;; When a new version of a class is created, a new header h2 and
-;; memory block m2 are allocated. The headers h1 and h2 then switch
-;; pointers so that h1 refers to m2 and h2 to m1. In this way, names
-;; bound to h1 will point to the new class at the same time as h2 will
-;; be a handle which the GC will use to free m1.
-;;
-;; The `redefined' slot of m1 will be set to point to h1. An old
-;; instance will have its class pointer (the CAR of the heap header)
-;; pointing to m1. The non-immediate `redefined'-slot in m1 indicates
-;; the class modification and the new class pointer can be found via
-;; h1.
-;;
-;; In the following interfaces, class-of handles the redefinition
-;; protocol. There would seem to be some thread-unsafety though as the
-;; { class, object data } pair needs to be accessed atomically, not the
-;; { class, object } pair.
+\f
+
+;;;
+;;; Slot access.
+;;;
+;;; Before we go on, some notes about class redefinition. In GOOPS,
+;;; classes can be redefined. Redefinition of a class marks the class
+;;; as invalid, and instances will be lazily migrated over to the new
+;;; representation as they are accessed. Migration happens when
+;;; `class-of' is called on an instance. For more technical details on
+;;; object redefinition, see struct.h.
+;;;
+;;; In the following interfaces, class-of handles the redefinition
+;;; protocol. I would think though that there is some thread-unsafety
+;;; here though as the { class, object data } pair needs to be accessed
+;;; atomically, not the { class, object } pair.
+;;;
+(define-inlinable (%class-slot-definition class slot-name kt kf)
+ (let lp ((slots (struct-ref class class-index-slots)))
+ (match slots
+ ((slot . slots)
+ (if (eq? (%slot-definition-name slot) slot-name)
+ (kt slot)
+ (lp slots)))
+ (_ (kf)))))
+
+(define (class-slot-definition class slot-name)
+ (unless (class? class)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f))
+ (%class-slot-definition class slot-name
+ (lambda (slot) slot)
+ (lambda () #f)))
(define (slot-ref obj slot-name)
"Return the value from @var{obj}'s slot with the nam var{slot_name}."
- (slot-ref-using-class (class-of obj) obj slot-name))
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (let ((val (slot-value slot)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
(define (slot-set! obj slot-name value)
"Set the slot named @var{slot_name} of @var{obj} to @var{value}."
- (slot-set-using-class! (class-of obj) obj slot-name value))
+ (let ((class (class-of obj)))
+ (define (have-slot slot)
+ (cond
+ ((%slot-definition-slot-set! slot)
+ => (lambda (slot-set!) (slot-set! obj value)))
+ (else
+ (struct-set! obj (%slot-definition-index slot) value))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (slot-missing class obj slot-name value))
+
+ (%class-slot-definition class slot-name have-slot no-slot)))
(define (slot-bound? obj slot-name)
"Return the value from @var{obj}'s slot with the nam var{slot_name}."
- (slot-bound-using-class? (class-of obj) obj slot-name))
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (not (unbound? (slot-value slot))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
(define (slot-exists? obj slot-name)
"Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
- (slot-exists-using-class? (class-of obj) obj slot-name))
+ (define (have-slot slot) #t)
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ #f)
+ (%class-slot-definition (class-of obj) slot-name have-slot no-slot))
+
+(begin-deprecated
+ (define (check-slot-args class obj slot-name)
+ (unless (eq? class (class-of obj))
+ (scm-error 'wrong-type-arg #f "~S is not the class of ~S"
+ (list class obj) #f))
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f)))
+
+ (define (slot-ref-using-class class obj slot-name)
+ (issue-deprecation-warning "slot-ref-using-class is deprecated. "
+ "Use slot-ref instead.")
+ (check-slot-args class obj slot-name)
+ (slot-ref obj slot-name))
+
+ (define (slot-set-using-class! class obj slot-name value)
+ (issue-deprecation-warning "slot-set-using-class! is deprecated. "
+ "Use slot-set! instead.")
+ (check-slot-args class obj slot-name)
+ (slot-set! obj slot-name value))
+
+ (define (slot-bound-using-class? class obj slot-name)
+ (issue-deprecation-warning "slot-bound-using-class? is deprecated. "
+ "Use slot-bound? instead.")
+ (check-slot-args class obj slot-name)
+ (slot-bound? obj slot-name))
+
+ (define (slot-exists-using-class? class obj slot-name)
+ (issue-deprecation-warning "slot-exists-using-class? is deprecated. "
+ "Use slot-exists? instead.")
+ (check-slot-args class obj slot-name)
+ (slot-exists? obj slot-name)))
+
+\f
+
+;;;
+;;; Method accessors.
+;;;
(define (method-generic-function obj)
"Return the generic function for the method @var{obj}."
(unless (is-a? obj <method>)
(list obj) #f))
(slot-ref obj 'procedure))
-(define *dispatch-module* (current-module))
+\f
+
+;;;
+;;; 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. This cache gets compiled out to
-;;; a dispatch procedure. In steady-state, this dispatch procedure is
-;;; never recompiled; but during warm-up there is some churn, both to
-;;; the cache and to the dispatch procedure.
+;;; 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
;;;
;;; 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
+;;; 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
;;; re-trigger a memoization, and the cache will finally be consistent.
;;; As you can see there is a possibility for ping-pong effects, but
;;; it's unlikely given the shortness of the window between slot-set!
-;;; invocations. We could add a mutex, but it is strictly unnecessary,
-;;; and would add runtime cost and complexity.
-;;;
-
-(define (emit-linear-dispatch gf-sym nargs methods free rest?)
- (define (gen-syms n stem)
- (let lp ((n (1- n)) (syms '()))
- (if (< n 0)
- syms
- (lp (1- n) (cons (gensym stem) syms)))))
- (let* ((args (gen-syms nargs "a"))
- (types (gen-syms nargs "t")))
- (let lp ((methods methods)
- (free free)
- (exp `(cache-miss ,gf-sym
- ,(if rest?
- `(cons* ,@args rest)
- `(list ,@args)))))
- (cond
- ((null? methods)
- (values `(,(if rest? `(,@args . rest) args)
- (let ,(map (lambda (t a)
- `(,t (class-of ,a)))
- types args)
- ,exp))
- free))
- (else
- ;; jeez
- (let preddy ((free free)
- (types types)
- (specs (vector-ref (car methods) 1))
- (checks '()))
- (if (null? types)
- (let ((m-sym (gensym "p")))
- (lp (cdr methods)
- (acons (vector-ref (car methods) 3)
- m-sym
- free)
- `(if (and . ,checks)
- ,(if rest?
- `(apply ,m-sym ,@args rest)
- `(,m-sym . ,args))
- ,exp)))
- (let ((var (assq-ref free (car specs))))
- (if var
- (preddy free
- (cdr types)
- (cdr specs)
- (cons `(eq? ,(car types) ,var)
- checks))
- (let ((var (gensym "c")))
- (preddy (acons (car specs) var free)
- (cdr types)
- (cdr specs)
- (cons `(eq? ,(car types) ,var)
- checks))))))))))))
-
-(define (compute-dispatch-procedure gf cache)
- (define (scan)
- (let lp ((ls cache) (nreq -1) (nrest -1))
- (cond
- ((null? ls)
- (collate (make-vector (1+ nreq) '())
- (make-vector (1+ nrest) '())))
- ((vector-ref (car ls) 2) ; rest
- (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
- (else ; req
- (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
- (define (collate req rest)
- (let lp ((ls cache))
- (cond
- ((null? ls)
- (emit req rest))
- ((vector-ref (car ls) 2) ; rest
- (let ((n (vector-ref (car ls) 0)))
- (vector-set! rest n (cons (car ls) (vector-ref rest n)))
- (lp (cdr ls))))
- (else ; req
- (let ((n (vector-ref (car ls) 0)))
- (vector-set! req n (cons (car ls) (vector-ref req n)))
- (lp (cdr ls)))))))
- (define (emit req rest)
- (let ((gf-sym (gensym "g")))
- (define (emit-rest n clauses free)
- (if (< n (vector-length rest))
- (let ((methods (vector-ref rest n)))
- (cond
- ((null? methods)
- (emit-rest (1+ n) clauses free))
- ;; FIXME: hash dispatch
- (else
- (call-with-values
- (lambda ()
- (emit-linear-dispatch gf-sym n methods free #t))
- (lambda (clause free)
- (emit-rest (1+ n) (cons clause clauses) free))))))
- (emit-req (1- (vector-length req)) clauses free)))
- (define (emit-req n clauses free)
- (if (< n 0)
- (comp `(lambda ,(map cdr free)
- (case-lambda ,@clauses))
- (map car free))
- (let ((methods (vector-ref req n)))
- (cond
- ((null? methods)
- (emit-req (1- n) clauses free))
- ;; FIXME: hash dispatch
- (else
- (call-with-values
- (lambda ()
- (emit-linear-dispatch gf-sym n methods free #f))
- (lambda (clause free)
- (emit-req (1- n) (cons clause clauses) free))))))))
-
- (emit-rest 0
- (if (or (zero? (vector-length rest))
- (null? (vector-ref rest 0)))
- (list `(args (cache-miss ,gf-sym args)))
- '())
- (acons gf gf-sym '()))))
- (define (comp exp vals)
- ;; When cross-compiling Guile itself, the native Guile must generate
- ;; code for the host.
- (with-target %host-type
- (lambda ()
- (let ((p ((@ (system base compile) compile) exp
- #:env *dispatch-module*
- #:from 'scheme
- #:opts '(#:partial-eval? #f #:cse? #f))))
- (apply p vals)))))
-
- ;; kick it.
- (scan))
-
-;; o/~ ten, nine, eight
-;; sometimes that's just how it goes
-;; three, two, one
-;;
-;; get out before it blows o/~
-;;
-(define timer-init 30)
-(define (delayed-compile gf)
- (let ((timer timer-init))
- (lambda args
- (set! timer (1- timer))
- (cond
- ((zero? timer)
- (let ((dispatch (compute-dispatch-procedure
- gf (slot-ref gf 'effective-methods))))
- (slot-set! gf 'procedure dispatch)
- (apply dispatch args)))
- (else
- ;; interestingly, this catches recursive compilation attempts as
- ;; well; in that case, timer is negative
- (cache-dispatch gf args))))))
+;;; invocations.
+;;;
+;;; We probably do need to use atomic access primitives to correctly
+;;; handle concurrency, but that's a more general Guile concern.
+;;;
-(define (cache-dispatch gf args)
- (define (map-until n f ls)
- (if (or (zero? n) (null? ls))
- '()
- (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
- (define (equal? x y) ; can't use the stock equal? because it's a generic...
- (cond ((pair? x) (and (pair? y)
- (eq? (car x) (car y))
- (equal? (cdr x) (cdr y))))
- ((null? x) (null? y))
- (else #f)))
- (if (slot-ref gf 'n-specialized)
- (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
- (let lp ((cache (slot-ref gf 'effective-methods)))
- (cond ((null? cache)
- (cache-miss gf args))
- ((equal? (vector-ref (car cache) 1) types)
- (apply (vector-ref (car cache) 3) args))
- (else (lp (cdr cache))))))
- (cache-miss gf args)))
-
-(define (cache-miss gf args)
- (apply (memoize-method! gf args) args))
+(define-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 (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)
+ ((#(len types rest? cmethod nargs*) . cache)
+ (define (type-ref n)
+ (and (< n len) (list-ref types n)))
+ (cond
+ ((eqv? nargs nargs*)
+ (let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss)))
+ (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) (types types))
+ (match types
+ ((type . types)
+ (let ((arg (car args))
+ (args (cdr args)))
+ (and (eq? type (class-of arg))
+ (lp args types))))
+ (_ #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)
+ ((#(_ _ _ _ nargs) . cache)
+ (lp (logior arities (ash 1 nargs)) 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 (match cache ((#(_ _ _ _ nargs) . _) nargs))))
+ (let ((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 (first-n ls n)
(parse (1+ n) (cdr ls)))))
(define (memoize len rest? types)
(let* ((cmethod (compute-cmethod applicable types))
- (cache (cons (vector len types rest? cmethod)
+ (cache (cons (vector len types rest? cmethod (length args))
(slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
- (slot-set! gf 'procedure (delayed-compile gf))
+ (recompute-generic-function-dispatch-procedure! gf)
cmethod))
(parse 0 args))
;;;
-;;; Compiling next methods into method bodies
+;;; 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.
;;;
-
-;;; So, for the reader: there basic idea is that, given that the
-;;; semantics of `next-method' depend on the concrete types being
-;;; dispatched, why not compile a specific procedure to handle each type
-;;; combination that we see at runtime.
-;;;
-;;; In theory we can do much better than a bytecode compilation, because
-;;; we know the *exact* types of the arguments. It's ideal for native
-;;; compilation. A task for the future.
+;;; 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.
;;;
-;;; I think this whole generic application mess would benefit from a
-;;; strict MOP.
-
(define (compute-cmethod methods types)
- (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
- (if make-procedure
+ (match methods
+ ((method . methods)
+ (match (slot-ref method 'make-procedure)
+ (#f (method-procedure method))
+ (make-procedure
(make-procedure
- (if (null? (cdr methods))
- (lambda args
- (no-next-method (method-generic-function (car methods)) args))
- (compute-cmethod (cdr methods) types)))
- (method-procedure (car methods)))))
+ (match methods
+ (()
+ (lambda args
+ (no-next-method (method-generic-function method) args)))
+ (methods
+ (compute-cmethod methods types)))))))))
;;;
;;; Memoization
;;;
-(define (memoize-method! gf args)
+(define (memoize-generic-function-application! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods
compute-applicable-methods)
(else
(no-applicable-method gf args)))))
-(set-procedure-property! memoize-method! 'system-procedure #t)
-
(define no-applicable-method
(make <generic> #:name 'no-applicable-method))
;; a subclass of these.
(for-each
(lambda (meta)
- (if (and (not (member meta all-cpls))
+ (when (and (not (member meta all-cpls))
(not (member meta needed-metas)))
(set! needed-metas (append needed-metas (list meta)))))
all-metas)
;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
-;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;; SLOT-DEFINITION ::= INSTANCE-OF-<SLOT> | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
(define (make-class supers slots . options)
- (let* ((name (get-keyword #:name options (make-unbound)))
+ (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)))
;; 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-definition-name slots))))
+ (tmp2 (find-duplicate (map slot-spec->name slots))))
(if tmp1
(goops-error "make-class: super class ~S is duplicate in class ~S"
tmp1 name))
((#:getter #:setter)
#'(define-class-pre-definition (rest ...)
out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <generic>)))
- (toplevel-define!
- 'arg
- (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
+ (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 ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <accessor>)))
- (toplevel-define!
- 'arg
- (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
+ (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 ...)
#:name (generic-function-name generic)
#:extended-by (slot-ref generic 'extended-by)
#:setter setter)))
- (if (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)))
+ (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))
(syntax-rules (setter)
((_ ((setter name) . args) body ...)
(begin
- (if (or (not (defined? 'name))
- (not (is-a? name <accessor>)))
- (toplevel-define! 'name
- (ensure-accessor
- (if (defined? 'name) name #f) 'name)))
+ (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
;; 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.
- (if (or (not (defined? 'name))
- (not name))
- (toplevel-define! 'name (make <generic> #:name 'name)))
+ (when (or (not (defined? 'name))
+ (not name))
+ (toplevel-define! 'name (make <generic> #:name 'name)))
(add-method! name (method args body ...))))))
(define-syntax method
#: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!}
;;;
(generic-function-methods gf)))
(define (invalidate-method-cache! gf)
- (%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)))
;;;
;;; Slots
;;;
-(define slot-definition-name car)
-
-(define slot-definition-options cdr)
-
-(define (slot-definition-allocation s)
- (get-keyword #:allocation (cdr s) #:instance))
-
-(define (slot-definition-getter s)
- (get-keyword #:getter (cdr s) #f))
-
-(define (slot-definition-setter s)
- (get-keyword #:setter (cdr s) #f))
-
-(define (slot-definition-accessor s)
- (get-keyword #:accessor (cdr s) #f))
-
-(define (slot-definition-init-value s)
- ;; can be #f, so we can't use #f as non-value
- (get-keyword #:init-value (cdr s) (make-unbound)))
-
-(define (slot-definition-init-form s)
- (get-keyword #:init-form (cdr s) (make-unbound)))
-
-(define (slot-definition-init-thunk s)
- (get-keyword #:init-thunk (cdr s) #f))
-
-(define (slot-definition-init-keyword s)
- (get-keyword #:init-keyword (cdr s) #f))
-
-(define (class-slot-definition class slot-name)
- (assq slot-name (class-slots class)))
-
(define (slot-init-function class slot-name)
- (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))
+ (%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}."
(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 access
;;;
-(define (class-slot-g-n-s class slot-name)
- (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
- (getters-n-setters (struct-ref class class-index-getters-n-setters))
- (g-n-s (cddr (or (assq slot-name getters-n-setters)
- (slot-missing class slot-name)))))
- (if (not (memq (slot-definition-allocation this-slot)
- '(#:class #:each-subclass)))
- (slot-missing class slot-name))
- g-n-s))
+(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 slot) #f)))
+ (if (unbound? x)
+ (slot-unbound class slot-name)
+ x))))
-(define (class-slot-ref class slot)
- (let ((x ((car (class-slot-g-n-s class slot)) #f)))
- (if (unbound? x)
- (slot-unbound class slot)
- x)))
-
-(define (class-slot-set! class slot value)
- ((cadr (class-slot-g-n-s class slot)) #f value))
+(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 (shallow-clone (self <object>))
- (let ((clone (%allocate-instance (class-of self) '()))
- (slots (map slot-definition-name
- (class-slots (class-of self)))))
+ (let* ((class (class-of self))
+ (clone (%allocate-instance class))
+ (slots (map slot-definition-name (class-slots class))))
(for-each (lambda (slot)
- (if (slot-bound? self slot)
- (slot-set! clone slot (slot-ref self slot))))
+ (when (slot-bound? self slot)
+ (slot-set! clone slot (slot-ref self slot))))
slots)
clone))
(define-method (deep-clone (self <object>))
- (let ((clone (%allocate-instance (class-of self) '()))
- (slots (map slot-definition-name
- (class-slots (class-of self)))))
+ (let* ((class (class-of self))
+ (clone (%allocate-instance class))
+ (slots (map slot-definition-name (class-slots class))))
(for-each (lambda (slot)
- (if (slot-bound? self slot)
- (slot-set! clone slot
- (let ((value (slot-ref self slot)))
- (if (instance? value)
- (deep-clone value)
- value)))))
+ (when (slot-bound? self slot)
+ (slot-set! clone slot
+ (let ((value (slot-ref self slot)))
+ (if (instance? value)
+ (deep-clone value)
+ value)))))
slots)
clone))
;; Invalidate class so that subsequent instances slot accesses invoke
;; change-object-class
(struct-set! new class-index-redefined old)
- (%invalidate-class new) ;must come after slot-set!
+ (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set!
old)
(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
- (
if (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))))
+ (
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)))
;;;
(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.
- (if (pair? l)
- (begin
- (if (eqv? (car l) old)
- (set-car! l new))
- (loop (cdr l))))))
+ (when (pair? l)
+ (when (eqv? (car l) old)
+ (set-car! l new))
+ (loop (cdr l)))))
;;;
;;; update-direct-subclass!
;;;
(define (compute-slot-accessors class slots)
(for-each
- (lambda (s g-n-s)
- (let ((getter-function (slot-definition-getter s))
- (setter-function (slot-definition-setter s))
- (accessor (slot-definition-accessor s)))
- (if getter-function
- (add-method! getter-function
- (compute-getter-method class g-n-s)))
- (if setter-function
- (add-method! setter-function
- (compute-setter-method class g-n-s)))
- (if accessor
- (begin
- (add-method! accessor
- (compute-getter-method class g-n-s))
- (add-method! (setter accessor)
- (compute-setter-method class g-n-s))))))
- slots (struct-ref class class-index-getters-n-setters)))
-
-(define-method (compute-getter-method (class <class>) slotdef)
- (let ((init-thunk (cadr slotdef))
- (g-n-s (cddr slotdef)))
+ (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)
+ (let ((init-thunk (slot-definition-init-thunk slot))
+ (slot-ref (slot-definition-slot-ref slot))
+ (index (slot-definition-index slot)))
(make <accessor-method>
#:specializers (list class)
- #:procedure (cond ((pair? g-n-s)
- (make-generic-bound-check-getter (car g-n-s)))
- (init-thunk
- (standard-get g-n-s))
- (else
- (bound-check-get g-n-s)))
- #:slot-definition slotdef)))
-
-(define-method (compute-setter-method (class <class>) slotdef)
- (let ((g-n-s (cddr slotdef)))
+ #:procedure (cond
+ (slot-ref (make-generic-bound-check-getter slot-ref))
+ (init-thunk (standard-get index))
+ (else (bound-check-get index)))
+ #:slot-definition slot)))
+
+(define-method (compute-setter-method (class <class>) slot)
+ (let ((slot-set! (slot-definition-slot-set! slot))
+ (index (slot-definition-index slot)))
(make <accessor-method>
- #:specializers (list class <top>)
- #:procedure (if (pair? g-n-s)
- (cadr g-n-s)
- (standard-set g-n-s))
- #:slot-definition slotdef)))
+ #:specializers (list class <top>)
+ #:procedure (cond
+ (slot-set! slot-set!)
+ (else (standard-set index)))
+ #:slot-definition slot)))
(define (make-generic-bound-check-getter proc)
(lambda (o)
(define-standard-accessor-method ((standard-set n) o v)
(struct-set! o n v))
-;;; compute-getters-n-setters
-;;;
-(define (compute-getters-n-setters class slots)
-
- (define (compute-slot-init-function name s)
- (or (let ((thunk (slot-definition-init-thunk s)))
- (and thunk
- (if (thunk? thunk)
- thunk
- (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
- name class thunk))))
- (let ((init (slot-definition-init-value s)))
- (and (not (unbound? init))
- (lambda () init)))))
-
- (define (verify-accessors slot l)
- (cond ((integer? l))
- ((not (and (list? l) (= (length l) 2)))
- (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
- slot class l))
- (else
- (let ((get (car l))
- (set (cadr l)))
- (if (not (procedure? get))
- (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
- slot class get))
- (if (not (procedure? set))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
- slot class set))))))
-
- (map (lambda (s)
- ;; The strange treatment of nfields is due to backward compatibility.
- (let* ((index (slot-ref class 'nfields))
- (g-n-s (compute-get-n-set class s))
- (size (- (slot-ref class 'nfields) index))
- (name (slot-definition-name s)))
- ;; NOTE: The following is interdependent with C macros
- ;; defined above goops.c:scm_sys_prep_layout_x.
- ;;
- ;; For simple instance slots, we have the simplest form
- ;; '(name init-function . index)
- ;; For other slots we have
- ;; '(name init-function getter setter . alloc)
- ;; where alloc is:
- ;; '(index size) for instance allocated slots
- ;; '() for other slots
- (verify-accessors name g-n-s)
- (case (slot-definition-allocation s)
- ((#:each-subclass #:class)
- (unless (and (zero? size) (pair? g-n-s))
- (error "Class-allocated slots should not reserve fields"))
- ;; Don't initialize the slot; that's handled when the slot
- ;; is allocated, in compute-get-n-set.
- (cons name (cons #f g-n-s)))
- (else
- (cons name
- (cons (compute-slot-init-function name s)
- (if (or (integer? g-n-s)
- (zero? size))
- g-n-s
- (append g-n-s (list index size)))))))))
- slots))
-
;;; compute-cpl
;;;
;;; 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)))
(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
(struct-set! class class-index-nfields (+ already-allocated 1))
already-allocated))
- ((#:class) ;; Class slot
+ ((#: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.
;; 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 loop ((l (cdr (class-precedence-list class))))
- (let ((r (assoc name
- (struct-ref (car l)
- class-index-getters-n-setters))))
- (if r
- (cddr r)
- (loop (cdr l))))))))
+ (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)
;; 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)))
- (if (not (and get set))
- (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
- s))
+ (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 (make-closure-variable class value)
- (list (lambda (o) value)
- (lambda (o v) (set! value v))))
-
(define-method (compute-get-n-set (o <object>) s)
(goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
;;; {Initialize}
;;;
-(define *unbound* (make-unbound))
-
;; 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 (even? (length initargs))
- (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
+ (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
- (get-keyword kw initargs *unbound*)
+ ;; 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 ((get-n-set (struct-ref class class-index-getters-n-setters))
- (slots (struct-ref class class-index-slots)))
+ (let lp ((slots (struct-ref class class-index-slots)))
(match slots
(() obj)
- (((name . options) . slots)
- (match get-n-set
- (((_ init-thunk . _) . get-n-set)
- (let ((initarg (get-initarg (get-keyword #:init-keyword options))))
- (cond
- ((not (unbound? initarg))
- (slot-set! obj name initarg))
- (init-thunk
- (slot-set! obj name (init-thunk)))))
- (lp get-n-set slots))))))))
+ ((slot . slots)
+ (define (initialize-slot! value)
+ (cond
+ ((%slot-definition-slot-set! slot)
+ => (lambda (slot-set!) (slot-set! obj value)))
+ (else
+ (struct-set! obj (%slot-definition-index slot) 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)
- (let ((dslots (get-keyword #:slots initargs '()))
- (supers (get-keyword #:dsupers initargs '())))
- (let ((name (get-keyword #:name initargs '???)))
- (struct-set! class class-index-name name))
- (struct-set! class class-index-nfields 0)
- (struct-set! class class-index-direct-supers supers)
- (struct-set! class class-index-direct-slots dslots)
- (struct-set! class class-index-direct-subclasses '())
- (struct-set! class class-index-direct-methods '())
- (struct-set! class class-index-cpl (compute-cpl class))
- (struct-set! class class-index-redefined #f)
- (let ((slots (compute-slots class)))
- (struct-set! class class-index-slots slots)
- (let ((getters-n-setters (compute-getters-n-setters class slots)))
- (struct-set! class class-index-getters-n-setters getters-n-setters))
- ;; Build getters - setters - accessors
- (compute-slot-accessors class 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))))
- supers)
-
- ;; Support for the underlying structs:
-
- ;; Set the layout slot
- (%prep-layout! class)
- ;; Inherit class flags (invisible on scheme level) from supers
- (%inherit-magic! class supers)))
+ (class-add-flags! class (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
+ (struct-set! class class-index-name (get-keyword #:name initargs '???))
+ (struct-set! 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-redefined #f)
+ (struct-set! class class-index-cpl (compute-cpl class))
+ (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)))
(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)
- (if (and (slot-exists-using-class? old-class old-instance slot)
- (eq? (slot-definition-allocation
- (class-slot-definition old-class slot))
- #:instance)
- (slot-bound-using-class? old-class old-instance slot))
- ;; Slot was present and allocated in old instance; copy it
- (slot-set-using-class!
- new-class
- new-instance
- slot
- (slot-ref-using-class old-class old-instance slot))
- ;; slot was absent; initialize it with its default value
- (let ((init (slot-init-function new-class slot)))
- (if init
- (slot-set-using-class!
- new-class
- new-instance
- slot
- (apply init '()))))))
- (map slot-definition-name (class-slots new-class)))
+ (for-each
+ (lambda (slot)
+ (if (and (slot-exists? old-instance slot)
+ (eq? (%slot-definition-allocation
+ (class-slot-definition old-class slot))
+ #:instance)
+ (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)
;;;
(define-method (allocate-instance (class <class>) initargs)
- (%allocate-instance class initargs))
+ (%allocate-instance class))
(define-method (make-instance (class <class>) . initargs)
(let ((instance (allocate-instance class initargs)))
;;;
;;; {apply-generic}
;;;
-;;; Protocol for calling standard generic functions. This protocol is
-;;; not used for real <generic> functions (in this case we use a
-;;; completely C hard-coded protocol). Apply-generic is used by
-;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
-;;; The code below is similar to the first MOP described in AMOP. In
-;;; particular, it doesn't used the currified approach to gf
-;;; call. There are 2 reasons for that:
-;;; - the protocol below is exposed to mimic completely the one written in C
-;;; - the currified protocol would be imho inefficient in C.
+;;; 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)
- (if (null? (slot-ref gf 'methods))
- (no-method gf 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-method
))
-;;;
-;;; {<composite-metaclass> and <active-metaclass>}
-;;;
-
-;(autoload "active-slot" <active-metaclass>)
-;(autoload "composite-slot" <composite-metaclass>)
-;(export <composite-metaclass> <active-metaclass>)
-
-;;;
-;;; {Tools}
-;;;
-
-;; list2set
-;;
-;; duplicate the standard list->set function but using eq instead of
-;; eqv which really sucks a lot, uselessly here
-;;
-(define (list2set l)
- (let loop ((l l)
- (res '()))
- (cond
- ((null? l) res)
- ((memq (car l) res) (loop (cdr l) res))
- (else (loop (cdr l) (cons (car l) res))))))
-
-(define (class-subclasses c)
- (letrec ((allsubs (lambda (c)
- (cons c (mapappend allsubs
- (class-direct-subclasses c))))))
- (list2set (cdr (allsubs c)))))
-
-(define (class-methods c)
- (list2set (mapappend class-direct-methods
- (cons c (class-subclasses c)))))
-
;;;
;;; {Final initialization}
;;;
HCoop / bpt / guile.git / blobdiff