;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000-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 (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
<procedure> <primitive-generic>
;; Applicable structs.
- <applicable-struct-class>
- <applicable-struct>
+ <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>
<boolean> <char> <list> <pair> <null> <string> <symbol>
<vector> <bytevector> <uvec> <foreign> <hashtable>
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
+ <keyword>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
;; smob-type-name->class procedure.
<arbiter> <promise> <thread> <mutex> <condition-variable>
<regexp> <hook> <bitvector> <random-state> <async>
- <directory> <keyword> <array> <character-set>
+ <directory> <array> <character-set>
<dynamic-object> <guardian> <macro>
;; Modules.
make-extended-generic
make-accessor ensure-accessor
add-method!
- class-slot-ref class-slot-set! slot-unbound slot-missing
+ 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-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
class-subclasses class-methods
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?
slot-exists? make find-method get-keyword)
#:no-backtrace)
-(define *goops-module* (current-module))
-;; 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.
+;;;
+;;; 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))
-;; First initialize the builtin part of GOOPS
-(eval-when (compile load eval)
- (%init-goops-builtins))
-(eval-when (compile load eval)
- (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
- (add-interesting-primitive! 'class-of))
+\f
+
+;;;
+;;; We then define the slots that must appear in all classes (<class>
+;;; 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 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))))))
+
+;;;
+;;; Statically define variables for slot offsets: `class-index-layout'
+;;; will be 0, `class-index-flags' will be 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-syntax #,(id-append #'name #'class-index- #'name)
+ (identifier-syntax #,(tail-length #'tail)))
+ tail))))))
+ (fold-class-slots macro-fold-left define-class-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 couple of additional flags: one to indicate that a vtable
+;;; is actually a class, and one to indicate that the class is "valid",
+;;; meaning that it hasn't been redefined.
+;;;
+(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 (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', `slots', and
+;;; `getters-n-setters' fields will be updated later, once we have
+;;; definitions for the specialized slot types like <read-only-slot> 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 <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))))
+ (cons-slot
+ (syntax-rules ()
+ ((_ (name) tail) (cons (list 'name) tail))
+ ((_ (name class) tail) (cons (list 'name) tail)))))
+ (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
+ (slots (fold-class-slots macro-fold-right cons-slot '()))
+ (<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 (length slots))
+ (struct-set! <class> class-index-direct-supers '())
+ (struct-set! <class> class-index-direct-slots 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 slots)
+ (struct-set! <class> class-index-getters-n-setters '())
+ (struct-set! <class> class-index-redefined #f)
+ <class>)))
+
+;;;
+;;; Accessors to fields of <class>.
+;;;
+(define-syntax-rule (define-class-accessor name docstring field)
+ (define (name obj)
+ docstring
+ (let ((val obj))
+ (unless (class? val)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S"
+ (list val) #f))
+ (struct-ref val field))))
+
+(define-class-accessor class-name
+ "Return the class name of @var{obj}."
+ class-index-name)
+(define-class-accessor class-direct-supers
+ "Return the direct superclasses of the class @var{obj}."
+ class-index-direct-supers)
+(define-class-accessor class-direct-slots
+ "Return the direct slots of the class @var{obj}."
+ class-index-direct-slots)
+(define-class-accessor class-direct-subclasses
+ "Return the direct subclasses of the class @var{obj}."
+ class-index-direct-subclasses)
+(define-class-accessor class-direct-methods
+ "Return the direct methods of the class @var{obj}."
+ class-index-direct-methods)
+(define-class-accessor class-precedence-list
+ "Return the class precedence list of the class @var{obj}."
+ class-index-cpl)
+(define-class-accessor class-slots
+ "Return the slot list of the class @var{obj}."
+ class-index-slots)
+
+(define (class-subclasses c)
+ "Compute a list of all subclasses of @var{c}, direct and indirect."
+ (define (all-subclasses c)
+ (cons c (append-map all-subclasses
+ (class-direct-subclasses c))))
+ (delete-duplicates (cdr (all-subclasses c)) eq?))
+
+(define (class-methods c)
+ "Compute a list of all methods that specialize on @var{c} or
+subclasses of @var{c}."
+ (delete-duplicates (append-map class-direct-methods
+ (cons c (class-subclasses c)))
+ eq?))
+
+
+\f
+
+;;;
+;;; The "getters-n-setters" define how to access slot values for a
+;;; particular class. In general, there are many ways to access slot
+;;; values, but for standard classes it's pretty easy: each slot is
+;;; associated with a field in the object.
+;;;
+(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)
+ (let ((init-thunk (compute-init-thunk options)))
+ (cons `(,name ,init-thunk . ,n)
+ (lp slots (1+ n))))))))
+
+(struct-set! <class> class-index-getters-n-setters
+ (%compute-getters-n-setters (class-slots <class>)))
+
+
+\f
+
+;;;
+;;; At this point, we have <class> but no other objects. 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 (build-slots-list dslots cpl)
+ (define (check-cpl slots class-slots)
+ (when (or-map (match-lambda ((name . options) (assq name slots)))
+ class-slots)
+ (scm-error 'misc-error #f
+ "a predefined <class> inherited field cannot be redefined"
+ '() '())))
+ (define (remove-duplicate-slots slots)
+ (let lp ((slots (reverse slots)) (res '()) (seen '()))
+ (match slots
+ (() res)
+ (((and slot (name . options)) . slots)
+ (if (memq name seen)
+ (lp slots res seen)
+ (lp slots (cons slot res) (cons name 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 '()))
+ (match cpl
+ (() (remove-duplicate-slots (append class-slots res)))
+ ((head . cpl)
+ (let ((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-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)))
+
+ (define (slot-protection-and-kind options)
+ (define (subclass? class parent)
+ (memq parent (class-precedence-list class)))
+ (let ((type (kw-arg-ref options #:class)))
+ (if (and type (subclass? type <foreign-slot>))
+ (values (cond
+ ((subclass? type <self-slot>) #\s)
+ ((subclass? type <protected-slot>) #\p)
+ (else #\u))
+ (cond
+ ((subclass? type <opaque-slot>) #\o)
+ ((subclass? type <read-only-slot>) #\r)
+ ((subclass? type <hidden-slot>) #\h)
+ (else #\w)))
+ (values #\p #\w))))
+
+ (let ((layout (make-string (* nfields 2))))
+ (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
+ (match getters-n-setters
+ (()
+ (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))))))))))
+
+
+\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?)))
+ (%init-layout! class layout)))
+
+(define (make-standard-class class name dsupers dslots)
+ (let ((z (make-struct/no-tail class)))
+ (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-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)
+ z)))
+
+(define-syntax define-standard-class
+ (syntax-rules ()
+ ((define-standard-class name (super ...) #:metaclass meta slot ...)
+ (define name
+ (make-standard-class meta 'name (list super ...) '(slot ...))))
+ ((define-standard-class name (super ...) slot ...)
+ (define-standard-class name (super ...) #:metaclass <class> slot ...))))
+
+
+\f
+
+;;;
+;;; Sweet! Now we can define <top> and <object>, and finish
+;;; initializing the `direct-subclasses', `direct-supers', and `cpl'
+;;; slots of <class>.
+;;;
+(define-standard-class <top> ())
+(define-standard-class <object> (<top>))
+
+;; <top>, <object>, and <class> were partially initialized. Correct
+;; them here.
+(struct-set! <object> class-index-direct-subclasses (list <class>))
+(struct-set! <class> class-index-direct-supers (list <object>))
+(struct-set! <class> class-index-cpl (list <class> <object> <top>))
+
+
+\f
+
+;;;
+;;; We can also define the various slot types, and finish initializing
+;;; `direct-slots', `slots', and `getters-n-setters' of <class>.
+;;;
+(define-standard-class <foreign-slot> (<top>))
+(define-standard-class <protected-slot> (<foreign-slot>))
+(define-standard-class <hidden-slot> (<foreign-slot>))
+(define-standard-class <opaque-slot> (<foreign-slot>))
+(define-standard-class <read-only-slot> (<foreign-slot>))
+(define-standard-class <self-slot> (<read-only-slot>))
+(define-standard-class <protected-opaque-slot> (<protected-slot>
+ <opaque-slot>))
+(define-standard-class <protected-hidden-slot> (<protected-slot>
+ <hidden-slot>))
+(define-standard-class <protected-read-only-slot> (<protected-slot>
+ <read-only-slot>))
+(define-standard-class <scm-slot> (<protected-slot>))
+(define-standard-class <int-slot> (<foreign-slot>))
+(define-standard-class <float-slot> (<foreign-slot>))
+(define-standard-class <double-slot> (<foreign-slot>))
+
+(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)))
+
+
+\f
+
+;;;
+;;; Now, to build out the class hierarchy.
+;;;
+
+(define-standard-class <procedure-class> (<class>))
+
+(define-standard-class <applicable-struct-class>
+ (<procedure-class>))
+(class-add-flags! <applicable-struct-class>
+ vtable-flag-applicable-vtable)
+
+(define-standard-class <applicable-struct-with-setter-class>
+ (<applicable-struct-class>))
+(class-add-flags! <applicable-struct-with-setter-class>
+ vtable-flag-setter-vtable)
+
+(define-standard-class <applicable> (<top>))
+(define-standard-class <applicable-struct> (<object> <applicable>)
+ #:metaclass <applicable-struct-class>
+ procedure)
+(define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
+ #:metaclass <applicable-struct-with-setter-class>
+ setter)
+(define-standard-class <generic> (<applicable-struct>)
+ #:metaclass <applicable-struct-class>
+ methods
+ (n-specialized #:init-value 0)
+ (extended-by #:init-value ())
+ effective-methods)
+(define-standard-class <extended-generic> (<generic>)
+ #:metaclass <applicable-struct-class>
+ (extends #:init-value ()))
+(define-standard-class <generic-with-setter> (<generic>
+ <applicable-struct-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+(define-standard-class <accessor> (<generic-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+(define-standard-class <extended-generic-with-setter> (<extended-generic>
+ <generic-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+(define-standard-class <extended-accessor> (<accessor>
+ <extended-generic-with-setter>)
+ #:metaclass <applicable-struct-with-setter-class>)
+
+(define-standard-class <method> (<object>)
+ generic-function
+ specializers
+ procedure
+ formals
+ body
+ make-procedure)
+(define-standard-class <accessor-method> (<method>)
+ (slot-definition #:init-keyword #:slot-definition))
+
+(define-standard-class <boolean> (<top>))
+(define-standard-class <char> (<top>))
+(define-standard-class <list> (<top>))
+(define-standard-class <pair> (<list>))
+(define-standard-class <null> (<list>))
+(define-standard-class <string> (<top>))
+(define-standard-class <symbol> (<top>))
+(define-standard-class <vector> (<top>))
+(define-standard-class <foreign> (<top>))
+(define-standard-class <hashtable> (<top>))
+(define-standard-class <fluid> (<top>))
+(define-standard-class <dynamic-state> (<top>))
+(define-standard-class <frame> (<top>))
+(define-standard-class <vm-continuation> (<top>))
+(define-standard-class <bytevector> (<top>))
+(define-standard-class <uvec> (<bytevector>))
+(define-standard-class <array> (<top>))
+(define-standard-class <bitvector> (<top>))
+(define-standard-class <number> (<top>))
+(define-standard-class <complex> (<number>))
+(define-standard-class <real> (<complex>))
+(define-standard-class <integer> (<real>))
+(define-standard-class <fraction> (<real>))
+(define-standard-class <keyword> (<top>))
+(define-standard-class <unknown> (<top>))
+(define-standard-class <procedure> (<applicable>)
+ #:metaclass <procedure-class>)
+(define-standard-class <primitive-generic> (<procedure>)
+ #:metaclass <procedure-class>)
+(define-standard-class <port> (<top>))
+(define-standard-class <input-port> (<port>))
+(define-standard-class <output-port> (<port>))
+(define-standard-class <input-output-port> (<input-port> <output-port>))
+
+(define (inherit-applicable! class)
+ "An internal routine to redefine a SMOB class that was added after
+GOOPS was loaded, and on which scm_set_smob_apply installed an apply
+function."
+ ;; Why not use class-redefinition? We would, except that loading the
+ ;; compiler to compile effective methods can happen while GOOPS has
+ ;; only been partially loaded, and loading the compiler might cause
+ ;; SMOB types to be defined that need this facility. Instead we make
+ ;; a very specific hack, not a general solution. Probably the right
+ ;; solution is to avoid using the compiler, but that is another kettle
+ ;; of fish.
+ (unless (memq <applicable> (class-precedence-list class))
+ (unless (null? (class-slots class))
+ (error "SMOB object has slots?"))
+ (for-each
+ (lambda (super)
+ (let ((subclasses (struct-ref super class-index-direct-subclasses)))
+ (struct-set! super class-index-direct-subclasses
+ (delq class subclasses))))
+ (struct-ref class class-index-direct-supers))
+ (struct-set! class class-index-direct-supers (list <applicable>))
+ (struct-set! class class-index-cpl (compute-cpl class))
+ (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
+ (struct-set! <applicable> class-index-direct-subclasses
+ (cons class subclasses)))))
+
+
+\f
+
+;;;
+;;; At this point we have defined the class hierarchy, and it's time to
+;;; move on to instance allocation and generics. Once we have generics,
+;;; we'll fill out the metaobject protocol.
+;;;
+;;; Here we define a limited version of `make', so that we can allocate
+;;; instances of specific classes. This definition will be replaced
+;;; later.
+;;;
+(define (%invalidate-method-cache! gf)
+ (slot-set! gf 'procedure (delayed-compile gf))
+ (slot-set! gf 'effective-methods '()))
+
+;; Boot definition.
+(define (invalidate-method-cache! gf)
+ (%invalidate-method-cache! gf))
+
+(define* (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 (%allocate-instance class)
+ (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
+ (%clear-fields! obj)
+ obj))
+
+(define (make class . args)
+ (cond
+ ((or (eq? class <generic>) (eq? class <accessor>))
+ (let ((z (make-struct/no-tail class #f '() 0 '())))
+ (set-procedure-property! z 'name (get-keyword #:name args #f))
+ (invalidate-method-cache! z)
+ (when (eq? class <accessor>)
+ (let ((setter (get-keyword #:setter args #f)))
+ (when setter
+ (slot-set! z 'setter setter))))
+ z))
+ (else
+ (let ((z (%allocate-instance class)))
+ (cond
+ ((or (eq? class <method>) (eq? class <accessor-method>))
+ (for-each (match-lambda
+ ((kw slot default)
+ (slot-set! z slot (get-keyword kw args default))))
+ '((#:generic-function generic-function #f)
+ (#:specializers specializers ())
+ (#:procedure procedure #f)
+ (#:formals formals ())
+ (#:body body ())
+ (#:make-procedure make-procedure #f))))
+ ((memq <class> (class-precedence-list class))
+ (class-add-flags! z (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
+ (for-each (match-lambda
+ ((kw slot default)
+ (slot-set! z slot (get-keyword kw args default))))
+ '((#:name name ???)
+ (#:dsupers direct-supers ())
+ (#:slots direct-slots ()))))
+ (else
+ (error "boot `make' does not support this class" class)))
+ z))))
+
+(define (is-a? obj class)
+ "Return @code{#t} if @var{obj} is an instance of @var{class}, or
+@code{#f} otherwise."
+ (and (memq class (class-precedence-list (class-of obj))) #t))
+
+
+\f
+
+;;;
+;;; Slot access. This protocol is a bit of a mess: there's the `slots'
+;;; slot, which ostensibly holds "slot definitions" but really just has
+;;; specially formatted lists. And then there's the `getters-n-setters'
+;;; slot, which mirrors `slots' but should in theory indicates how to
+;;; get at slots for a particular instance -- never mind that `slots'
+;;; was also computed for a particular instance, and that
+;;; `getters-n-setters' is a strangely structured chain of pairs.
+;;; Perhaps we can fix this in the future, following the CLOS MOP, to
+;;; have proper <effective-slot-definition> objects.
+;;;
+(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 (instance? obj)
+ (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))
+
+;;;
+;;; 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 (slot-ref obj slot-name)
+ "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let* ((class (class-of obj))
+ (val (get-slot-value-using-name class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+
+(define (slot-set! obj slot-name value)
+ "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (set-slot-value-using-name! (class-of obj) obj slot-name value))
+
+(define (slot-bound? obj slot-name)
+ "Return the value from @var{obj}'s slot with the nam var{slot_name}."
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (not (unbound? (get-slot-value-using-name (class-of obj) obj slot-name))))
+
+(define (slot-exists? obj slot-name)
+ "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (test-slot-existence (class-of obj) obj slot-name))
+
+
+\f
+
+;;;
+;;; Method accessors.
+;;;
+(define (method-generic-function obj)
+ "Return the generic function for the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'generic-function))
+
+(define (method-specializers obj)
+ "Return specializers of the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'specializers))
+
+(define (method-procedure obj)
+ "Return the procedure of the method @var{obj}."
+ (unless (is-a? obj <method>)
+ (scm-error 'wrong-type-arg #f "Not a method: ~S"
+ (list obj) #f))
+ (slot-ref obj 'procedure))
+
+
+\f
+
+;;;
+;;; Generic functions!
+;;;
+(define *dispatch-module* (current-module))
+
+;;;
+;;; Generic functions have an applicable-methods cache associated with
+;;; them. Every distinct set of types that is dispatched through a
+;;; generic adds an entry to the cache. This cache gets compiled out to
+;;; a dispatch procedure. In steady-state, this dispatch procedure is
+;;; never recompiled; but during warm-up there is some churn, both to
+;;; the cache and to the dispatch procedure.
+;;;
+;;; So what is the deal if warm-up happens in a multithreaded context?
+;;; There is indeed a window between missing the cache for a certain set
+;;; of arguments, and then updating the cache with the newly computed
+;;; applicable methods. One of the updaters is liable to lose their new
+;;; entry.
+;;;
+;;; This is actually OK though, because a subsequent cache miss for the
+;;; race loser will just cause memoization to try again. The cache will
+;;; eventually be consistent. We're not mutating the old part of the
+;;; cache, just consing on the new entry.
+;;;
+;;; It doesn't even matter if the dispatch procedure and the cache are
+;;; inconsistent -- most likely the type-set that lost the dispatch
+;;; procedure race will simply re-trigger a memoization, but since the
+;;; winner isn't in the effective-methods cache, it will likely also
+;;; re-trigger a memoization, and the cache will finally be consistent.
+;;; As you can see there is a possibility for ping-pong effects, but
+;;; it's unlikely given the shortness of the window between slot-set!
+;;; invocations. We could add a mutex, but it is strictly unnecessary,
+;;; and would add runtime cost and complexity.
+;;;
+
+(define (emit-linear-dispatch gf-sym nargs methods free rest?)
+ (define (gen-syms n stem)
+ (let lp ((n (1- n)) (syms '()))
+ (if (< n 0)
+ syms
+ (lp (1- n) (cons (gensym stem) syms)))))
+ (let* ((args (gen-syms nargs "a"))
+ (types (gen-syms nargs "t")))
+ (let lp ((methods methods)
+ (free free)
+ (exp `(cache-miss ,gf-sym
+ ,(if rest?
+ `(cons* ,@args rest)
+ `(list ,@args)))))
+ (match methods
+ (()
+ (values `(,(if rest? `(,@args . rest) args)
+ (let ,(map (lambda (t a)
+ `(,t (class-of ,a)))
+ types args)
+ ,exp))
+ free))
+ ((#(_ specs _ cmethod) . methods)
+ (let build-dispatch ((free free)
+ (types types)
+ (specs specs)
+ (checks '()))
+ (match types
+ (()
+ (let ((m-sym (gensym "p")))
+ (lp methods
+ (acons cmethod m-sym free)
+ `(if (and . ,checks)
+ ,(if rest?
+ `(apply ,m-sym ,@args rest)
+ `(,m-sym . ,args))
+ ,exp))))
+ ((type . types)
+ (match specs
+ ((spec . specs)
+ (let ((var (assq-ref free spec)))
+ (if var
+ (build-dispatch free
+ types
+ specs
+ (cons `(eq? ,type ,var)
+ checks))
+ (let ((var (gensym "c")))
+ (build-dispatch (acons spec var free)
+ types
+ specs
+ (cons `(eq? ,type ,var)
+ checks)))))))))))))))
+
+(define (compute-dispatch-procedure gf cache)
+ (define (scan)
+ (let lp ((ls cache) (nreq -1) (nrest -1))
+ (match ls
+ (()
+ (collate (make-vector (1+ nreq) '())
+ (make-vector (1+ nrest) '())))
+ ((#(len specs rest? cmethod) . ls)
+ (if rest?
+ (lp ls nreq (max nrest len))
+ (lp ls (max nreq len) nrest))))))
+ (define (collate req rest)
+ (let lp ((ls cache))
+ (match ls
+ (() (emit req rest))
+ (((and entry #(len specs rest? cmethod)) . ls)
+ (if rest?
+ (vector-set! rest len (cons entry (vector-ref rest len)))
+ (vector-set! req len (cons entry (vector-ref req len))))
+ (lp ls)))))
+ (define (emit req rest)
+ (let ((gf-sym (gensym "g")))
+ (define (emit-rest n clauses free)
+ (if (< n (vector-length rest))
+ (match (vector-ref rest n)
+ (() (emit-rest (1+ n) clauses free))
+ ;; FIXME: hash dispatch
+ (methods
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #t))
+ (lambda (clause free)
+ (emit-rest (1+ n) (cons clause clauses) free)))))
+ (emit-req (1- (vector-length req)) clauses free)))
+ (define (emit-req n clauses free)
+ (if (< n 0)
+ (comp `(lambda ,(map cdr free)
+ (case-lambda ,@clauses))
+ (map car free))
+ (match (vector-ref req n)
+ (() (emit-req (1- n) clauses free))
+ ;; FIXME: hash dispatch
+ (methods
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #f))
+ (lambda (clause free)
+ (emit-req (1- n) (cons clause clauses) free)))))))
+
+ (emit-rest 0
+ (if (or (zero? (vector-length rest))
+ (null? (vector-ref rest 0)))
+ (list `(args (cache-miss ,gf-sym args)))
+ '())
+ (acons gf gf-sym '()))))
+ (define (comp exp vals)
+ ;; When cross-compiling Guile itself, the native Guile must generate
+ ;; code for the host.
+ (with-target %host-type
+ (lambda ()
+ (let ((p ((@ (system base compile) compile) exp
+ #:env *dispatch-module*
+ #:from 'scheme
+ #:opts '(#:partial-eval? #f #:cse? #f))))
+ (apply p vals)))))
+
+ ;; kick it.
+ (scan))
+
+;; o/~ ten, nine, eight
+;; sometimes that's just how it goes
+;; three, two, one
+;;
+;; get out before it blows o/~
+;;
+(define timer-init 30)
+(define (delayed-compile gf)
+ (let ((timer timer-init))
+ (lambda args
+ (set! timer (1- timer))
+ (cond
+ ((zero? timer)
+ (let ((dispatch (compute-dispatch-procedure
+ gf (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'procedure dispatch)
+ (apply dispatch args)))
+ (else
+ ;; interestingly, this catches recursive compilation attempts as
+ ;; well; in that case, timer is negative
+ (cache-dispatch gf args))))))
+
+(define (cache-dispatch gf args)
+ (define (map-until n f ls)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
+ (define (equal? x y) ; can't use the stock equal? because it's a generic...
+ (cond ((pair? x) (and (pair? y)
+ (eq? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((null? x) (null? y))
+ (else #f)))
+ (if (slot-ref gf 'n-specialized)
+ (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+ (let lp ((cache (slot-ref gf 'effective-methods)))
+ (cond ((null? cache)
+ (cache-miss gf args))
+ ((equal? (vector-ref (car cache) 1) types)
+ (apply (vector-ref (car cache) 3) args))
+ (else (lp (cdr cache))))))
+ (cache-miss gf args)))
+
+(define (cache-miss gf args)
+ (apply (memoize-method! gf args) args))
+
+(define (memoize-effective-method! gf args applicable)
+ (define (first-n ls n)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (car ls) (first-n (cdr ls) (- n 1)))))
+ (define (parse n ls)
+ (cond ((null? ls)
+ (memoize n #f (map class-of args)))
+ ((= n (slot-ref gf 'n-specialized))
+ (memoize n #t (map class-of (first-n args n))))
+ (else
+ (parse (1+ n) (cdr ls)))))
+ (define (memoize len rest? types)
+ (let* ((cmethod (compute-cmethod applicable types))
+ (cache (cons (vector len types rest? cmethod)
+ (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'effective-methods cache)
+ (slot-set! gf 'procedure (delayed-compile gf))
+ cmethod))
+ (parse 0 args))
+
+;;;
+;;; Compiling next methods into method bodies
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+(define (compute-cmethod methods types)
+ (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
+ (if make-procedure
+ (make-procedure
+ (if (null? (cdr methods))
+ (lambda args
+ (no-next-method (method-generic-function (car methods)) args))
+ (compute-cmethod (cdr methods) types)))
+ (method-procedure (car methods)))))
+
+;;;
+;;; Memoization
+;;;
+
+(define (memoize-method! gf args)
+ (let ((applicable ((if (eq? gf compute-applicable-methods)
+ %compute-applicable-methods
+ compute-applicable-methods)
+ gf args)))
+ (cond (applicable
+ (memoize-effective-method! gf args applicable))
+ (else
+ (no-applicable-method gf args)))))
+
+(set-procedure-property! memoize-method! 'system-procedure #t)
+
+(define no-applicable-method
+ (make <generic> #:name 'no-applicable-method))
+
+(%goops-early-init)
;; Then load the rest of GOOPS
-(use-modules (oop goops util)
- (oop goops dispatch)
- (oop goops compile))
\f
;; FIXME: deprecate.
-(eval-when (compile load eval)
- (define min-fixnum (- (expt 2 29)))
- (define max-fixnum (- (expt 2 29) 1)))
+(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 '()))
-;;
-;; is-a?
-;;
-(define (is-a? obj class)
- (and (memq class (class-precedence-list (class-of obj))) #t))
-
-
;;;
;;; {Meta classes}
;;;
(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))))))
+ (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-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)
- (if (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)))))
+ (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}
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (kw-do-map mapper f kwargs)
- (define (keywords l)
- (cond
- ((null? l) '())
- ((or (null? (cdr l)) (not (keyword? (car l))))
- (goops-error "malformed keyword arguments: ~a" kwargs))
- (else (cons (car l) (keywords (cddr l))))))
- (define (args l)
- (if (null? l) '() (cons (cadr l) (args (cddr l)))))
- ;; let* to check keywords first
- (let* ((k (keywords kwargs))
- (a (args kwargs)))
- (mapper f k a)))
-
(define (make-class supers slots . options)
+ (define (find-duplicate l)
+ (match l
+ (() #f)
+ ((head . tail)
+ (if (memq head tail)
+ head
+ (find-duplicate tail)))))
+
(let* ((name (get-keyword #:name options (make-unbound)))
(supers (if (not (or-map (lambda (class)
(memq <object>
;; Everything seems correct, build the class
(apply make metaclass
#:dsupers supers
- #:slots slots
+ #:slots slots
#:name name
options)))
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define-macro (class supers . slots)
- (define (make-slot-definition-forms slots)
- (map
- (lambda (def)
- (cond
- ((pair? def)
- `(list ',(car def)
- ,@(kw-do-map append-map
- (lambda (kw arg)
- (case kw
- ((#:init-form)
- `(#:init-form ',arg
- #:init-thunk (lambda () ,arg)))
- (else (list kw arg))))
- (cdr def))))
- (else
- `(list ',def))))
- slots))
- (if (not (list? supers))
- (goops-error "malformed superclass list: ~S" supers))
- (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
- (options (or (find-tail keyword? slots) '())))
- `(make-class
- ;; evaluate super class variables
- (list ,@supers)
- ;; evaluate slot definitions, except the slot name!
- (list ,@(make-slot-definition-forms slots))
- ;; evaluate class options
- ,@options)))
+(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)
((#: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 ...)
#'(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
#'(define-class-pre-definitions (rest ...)
out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
- #'(define-class-pre-definitions (rest ...)
+ #'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax-rule (define-class name supers slot ...)
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))
-
+
(define-syntax-rule (standard-define-class arg ...)
(define-class arg ...))
;; Apparently the desired semantics are that we extend previous
;; procedural definitions, but that if `name' was already a generic, we
;; overwrite its definition.
-(define-macro (define-generic name)
- (if (not (symbol? name))
- (goops-error "bad generic function name: ~S" name))
- `(define ,name
- (if (and (defined? ',name) (is-a? ,name <generic>))
- (make <generic> #:name ',name)
- (ensure-generic (if (defined? ',name) ,name #f) ',name))))
-
-(define-macro (define-extended-generic name val)
- (if (not (symbol? name))
- (goops-error "bad generic function name: ~S" name))
- `(define ,name (make-extended-generic ,val ',name)))
-
-(define-macro (define-extended-generics names . args)
- (let ((prefixes (get-keyword #:prefix args #f)))
- (if prefixes
- `(begin
- ,@(map (lambda (name)
- `(define-extended-generic ,name
- (list ,@(map (lambda (prefix)
- (symbol-append prefix name))
- prefixes))))
- names))
- (goops-error "no prefixes supplied"))))
+(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)))
+ (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))))
+ (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)
+ (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)
+ (slot-set! gf 'extended-by
+ (delq! eg (slot-ref gf 'extended-by))))
+ gfs)
(invalidate-method-cache! eg))
(define* (ensure-generic old-definition #:optional 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)))
- (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)))
+ (gws (make (if (is-a? generic <extended-generic>)
+ <extended-generic-with-setter>
+ #: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! 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 lp ((specs (method-specializers m)) (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 ((n (length args))
+ (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))
(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!}
;;;
(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)))
- (if (not (memq m dm))
- (slot-set! x 'direct-methods (cons m dm)))))
- (method-specializers m)))
+ (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)
- (slot-set! x
- 'direct-methods
- (delv! m (class-direct-methods x))))
- (method-specializers m)))
+ (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)))
+ (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)))))))
+ (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-method (add-method! (proc <procedure>) (m <method>))
(if (generic-capability? proc)
(begin
- (enable-primitive-generic! proc)
- (add-method! proc m))
+ (enable-primitive-generic! proc)
+ (add-method! proc m))
(next-method)))
(define-method (add-method! (pg <primitive-generic>) (m <method>))
;;;
(define-method (method-source (m <method>))
(let* ((spec (map* class-name (slot-ref m 'specializers)))
- (src (procedure-source (slot-ref m 'procedure))))
+ (src (procedure-source (slot-ref m 'procedure))))
(and src
(let ((args (cadr src))
(body (cddr src)))
(assq slot-name (class-slots class)))
(define (slot-init-function class slot-name)
- (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+ (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))
(define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}."
;; 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))
+(add-method! g-equal? (method (x y) #f))
(set-primitive-generic! equal? g-equal?)
;;;
;;;
; Code for writing objects must test that the slots they use are
-; bound. Otherwise a slot-unbound method will be called and will
+; bound. Otherwise a slot-unbound method will be called and will
; conduct to an infinite loop.
;; 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))))
+ (begin
+ (display "#<" file)
+ (display (class-name class) file)
+ (display #\space file)
+ (display-address o 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))))
+ (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))))
+ (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))))
+ (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)
+(define-method (display o file)
(write-object o file))
;;;
(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>))
+ (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>))
+ (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>))
+ (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))))
+ (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)))
+ 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>))
+ (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>))
+ (name <symbol>)
+ (int1 <module>)
+ (int2 <module>)
+ (var <top>)
+ (val <top>))
(merge-generics module name int1 val1 int2 val2 var val))
(module-define! duplicate-handlers 'merge-accessors merge-accessors)
;;;
(define (class-slot-g-n-s class slot-name)
- (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
- (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
- (slot-missing class slot-name)))))
- (if (not (memq (slot-definition-allocation this-slot)
- '(#:class #:each-subclass)))
- (slot-missing 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)))))
+ (unless (memq (slot-definition-allocation this-slot)
+ '(#:class #:each-subclass))
+ (slot-missing class slot-name))
g-n-s))
(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)))
+ (slot-unbound class slot)
+ x)))
(define (class-slot-set! class slot value)
((cadr (class-slot-g-n-s class slot)) #f value))
(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))
(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)))
+ gf (cons (generic-function-name gf) args)))
(define-method (no-method (gf <generic>) args)
(goops-error "No method defined for ~S" gf))
;;;
(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))))
- slots)
+ (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)))))
- slots)
+ (when (slot-bound? self slot)
+ (slot-set! clone slot
+ (let ((value (slot-ref self slot)))
+ (if (instance? value)
+ (deep-clone value)
+ value)))))
+ slots)
clone))
;;;
;;; Has correct the following conditions:
;;; Methods
-;;;
+;;;
;;; 1. New accessor specializers refer to new header
-;;;
+;;;
;;; Classes
-;;;
+;;;
;;; 1. New class cpl refers to the new class header
;;; 2. Old class header exists on old super classes direct-subclass lists
;;; 3. New class header exists on new super classes direct-subclass lists
(define-method (class-redefinition (old <class>) (new <class>))
;; 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-
+ ;; 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-
+ (update-direct-method! m new old)) ;; -2-
methods)
- (slot-set! new
- 'direct-methods
- (append methods (class-direct-methods old))))
+ (struct-set! new
+ class-index-direct-methods
+ (append methods (class-direct-methods old))))
;; Substitute old for new in new cpl
- (set-car! (slot-ref new 'cpl) old)
-
+ (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) (slot-set! c 'direct-subclasses
- (delv! old (class-direct-subclasses c))))
- (class-direct-supers old))
+ (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)
- (slot-set! c 'direct-subclasses
- (cons old (delv! new (class-direct-subclasses c)))))
- (class-direct-supers new))
+ (struct-set! c class-index-direct-subclasses
+ (cons old (delv! new (class-direct-subclasses c)))))
+ (class-direct-supers new))
;; Swap object headers
(%modify-class 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))
+ (for-each
+ (lambda (c)
+ (update-direct-subclass! c new old))
+ (class-direct-subclasses new))
;; Invalidate class so that subsequent instances slot accesses invoke
;; change-object-class
- (slot-set! new 'redefined old)
- (%invalidate-class new) ;must come after slot-set!
+ (struct-set! new class-index-redefined old)
+ (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))))
- (class-direct-methods c)))
+
(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)))
;;;
;;; update-direct-method!
;;;
(define-method (update-direct-method! (m <method>)
- (old <class>)
- (new <class>))
+ (old <class>)
+ (new <class>))
(let loop ((l (method-specializers m)))
- ;; Note: the <top> in dotted list is never used.
+ ;; 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-method (update-direct-subclass! (c <class>)
- (old <class>)
- (new <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))))
+ (make-class (class-direct-supers c)
+ (class-direct-slots c)
+ #:name (class-name c)
+ #:metaclass (class-of c))))
;;;
;;; {Utilities for INITIALIZE methods}
(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 (slot-ref class 'getters-n-setters)))
+ (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)))
+ (g-n-s (cddr slotdef)))
(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)))
+ #: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)))
(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)))
+ #:procedure (if (pair? g-n-s)
+ (cadr g-n-s)
+ (standard-set g-n-s))
+ #:slot-definition slotdef)))
(define (make-generic-bound-check-getter proc)
- (lambda (o) (assert-bound (proc o) o)))
+ (lambda (o)
+ (let ((val (proc o)))
+ (if (unbound? val)
+ (slot-unbound o)
+ val))))
;;; Pre-generate getters and setters for the first 20 slots.
(define-syntax define-standard-accessor-method
(define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s)))
- (and thunk
- (if (thunk? thunk)
+ (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)))))
+ (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))))))
+ ((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)))
+ (unless (procedure? get)
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ slot class get))
+ (unless (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)
- (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)))))))
+ ;; 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
;;;
-;;; Correct behaviour:
-;;;
-;;; (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-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
-;;;
+
+;; 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))
-;; Support
-
-(define (only-non-null lst)
- (filter (lambda (l) (not (null? l))) lst))
-
-(define (compute-std-cpl c get-direct-supers)
- (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))))))
-
-(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)))
- (if (not 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))))))))
-
-;; Modified from TinyClos:
-;;
-;; A simple topological sort.
-;;
-;; It's in this file so that both TinyClos and Objects can use it.
-;;
-;; This is a fairly modified version of code I originally got from Anurag
-;; Mendhekar <anurag@moose.cs.indiana.edu>.
-;;
-
-(define (compute-clos-cpl c get-direct-supers)
- (top-sort ((build-transitive-closure get-direct-supers) c)
- ((build-constraints get-direct-supers) c)
- (std-tie-breaker get-direct-supers)))
-
-
-(define (top-sort elements constraints tie-breaker)
- (let loop ((elements elements)
- (constraints constraints)
- (result '()))
- (if (null? elements)
- result
- (let ((can-go-in-now
- (filter
- (lambda (x)
- (every (lambda (constraint)
- (or (not (eq? (cadr constraint) x))
- (memq (car constraint) result)))
- constraints))
- elements)))
- (if (null? can-go-in-now)
- (goops-error "top-sort: Invalid constraints")
- (let ((choice (if (null? (cdr can-go-in-now))
- (car can-go-in-now)
- (tie-breaker result
- can-go-in-now))))
- (loop
- (filter (lambda (x) (not (eq? x choice)))
- elements)
- constraints
- (append result (list choice)))))))))
-
-(define (std-tie-breaker get-supers)
- (lambda (partial-cpl min-elts)
- (let loop ((pcpl (reverse partial-cpl)))
- (let ((current-elt (car pcpl)))
- (let ((ds-of-ce (get-supers current-elt)))
- (let ((common (filter (lambda (x)
- (memq x ds-of-ce))
- min-elts)))
- (if (null? common)
- (if (null? (cdr pcpl))
- (goops-error "std-tie-breaker: Nothing valid")
- (loop (cdr pcpl)))
- (car common))))))))
-
-
-(define (build-transitive-closure get-follow-ons)
- (lambda (x)
- (let track ((result '())
- (pending (list x)))
- (if (null? pending)
- result
- (let ((next (car pending)))
- (if (memq next result)
- (track result (cdr pending))
- (track (cons next result)
- (append (get-follow-ons next)
- (cdr pending)))))))))
-
-(define (build-constraints get-follow-ons)
- (lambda (x)
- (let loop ((elements ((build-transitive-closure get-follow-ons) x))
- (this-one '())
- (result '()))
- (if (or (null? this-one) (null? (cdr this-one)))
- (if (null? elements)
- result
- (loop (cdr elements)
- (cons (car elements)
- (get-follow-ons (car elements)))
- result))
- (loop elements
- (cdr this-one)
- (cons (list (car this-one) (cadr this-one))
- result))))))
-
;;; 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))))
+
(case (slot-definition-allocation s)
((#:instance) ;; Instance slot
;; get-n-set is just its offset
- (let ((already-allocated (slot-ref class 'nfields)))
- (slot-set! class 'nfields (+ already-allocated 1))
+ (let ((already-allocated (struct-ref class class-index-nfields)))
+ (struct-set! class class-index-nfields (+ already-allocated 1))
already-allocated))
((#:class) ;; Class slot
- ;; Class-slots accessors are implemented as 2 closures around
+ ;; 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)
- ;; Slot is inherited. Find its definition in superclass
- (let loop ((l (cdr (class-precedence-list class))))
- (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
- (if r
- (cddr r)
- (loop (cdr l))))))))
+ ;; 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))))))))
((#:each-subclass) ;; slot shared by instances of direct subclass.
;; (Thomas Buerger, April 1998)
- (make-closure-variable class))
+ (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)))
- (if (not (and get set))
- (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
- s))
+ (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 (make-closure-variable class)
- (let ((shared-variable (make-unbound)))
- (list (lambda (o) shared-variable)
- (lambda (o v) (set! shared-variable v)))))
+(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)))
(define-method (compute-slots (class <class>))
- (%compute-slots class))
+ (build-slots-list (class-direct-slots class)
+ (class-precedence-list class)))
;;;
;;; {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}."
+ (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"
+ (list initargs) #f))
+ (let ((class (class-of obj)))
+ (define (get-initarg kw)
+ (if kw
+ (get-keyword kw initargs *unbound*)
+ *unbound*))
+ (let lp ((get-n-set (struct-ref class class-index-getters-n-setters))
+ (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))))))))
+
(define-method (initialize (object <object>) initargs)
(%initialize-object object initargs))
(define-method (initialize (class <class>) initargs)
(next-method)
(let ((dslots (get-keyword #:slots initargs '()))
- (supers (get-keyword #:dsupers initargs '())))
- (slot-set! class 'name (get-keyword #:name initargs '???))
- (slot-set! class 'direct-supers supers)
- (slot-set! class 'direct-slots dslots)
- (slot-set! class 'direct-subclasses '())
- (slot-set! class 'direct-methods '())
- (slot-set! class 'cpl (compute-cpl class))
- (slot-set! class 'redefined #f)
+ (supers (get-keyword #:dsupers initargs '())))
+ (class-add-flags! class (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
+ (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)))
- (slot-set! class 'slots slots)
- (slot-set! class 'nfields 0)
- (slot-set! class 'getters-n-setters (compute-getters-n-setters class
- slots))
+ (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)
- (slot-set! x
- 'direct-subclasses
- (cons class (slot-ref x 'direct-subclasses))))
- 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)))
+ (let ((dsubs (struct-ref x class-index-direct-subclasses)))
+ (struct-set! x class-index-direct-subclasses
+ (cons class dsubs))))
+ 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
+ ((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)))
+ (name (get-keyword #:name initargs #f)))
(next-method)
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
- (list (method args
+ (list (method args
(apply previous-definition args)))
- '()))
+ '()))
(if name
- (set-procedure-property! generic 'name name))
- ))
-
-(define-method (initialize (gws <generic-with-setter>) initargs)
- (next-method)
- (%set-object-setter! gws (get-keyword #:setter initargs #f)))
+ (set-procedure-property! generic 'name name))
+ (invalidate-method-cache! generic)))
(define-method (initialize (eg <extended-generic>) 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))
+ (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)))
-
+
;;;
;;; {Change-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)))
+ (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)))
;; 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 (update-instance-for-different-class (old-instance <object>)
- (new-instance
- <object>))
+ (new-instance
+ <object>))
;;not really important what we do, we just need a default method
new-instance)
;;;
(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
+;;; `cache-dispatch' 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-applicable-method gf args))))
+ (apply-methods gf (sort-applicable-methods gf methods args) args)
+ (no-applicable-method gf args))))
;; compute-applicable-methods is bound to %compute-applicable-methods.
;; *fixme* use let
(set! compute-applicable-methods %%compute-applicable-methods)
(define-method (sort-applicable-methods (gf <generic>) methods args)
- (let ((targs (map class-of args)))
- (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
+ (%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-method (apply-method (gf <generic>) methods build-next args)
(apply (method-procedure (car methods))
- (build-next (cdr methods) args)
- args))
+ (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)))))))
+ (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
- ))
-
-;;;
-;;; {<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)))))
+ (set-procedure-property! proc 'system-procedure #t))
+ (list slot-unbound
+ slot-missing
+ no-next-method
+ no-applicable-method
+ no-method
+ ))
;;;
;;; {Final initialization}
(define <random-state> (find-subclass <top> '<random-state>))
(define <async> (find-subclass <top> '<async>))
(define <directory> (find-subclass <top> '<directory>))
-(define <keyword> (find-subclass <top> '<keyword>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))
(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
HCoop / bpt / guile.git / blobdiff