X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/9c49d475f548270314c88cc643615b35c612f49b..0d96acac33b867f45203e0a0c7b6e87a3a09cdad:/module/oop/goops.scm diff --git a/module/oop/goops.scm b/module/oop/goops.scm index a8d1679ff..ef2fc34be 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc. +;;;; goops.scm -- The Guile Object-Oriented Programming System +;;;; +;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -27,7 +27,6 @@ (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 @@ -122,9 +121,8 @@ goops-error min-fixnum max-fixnum - instance? slot-ref-using-class - slot-set-using-class! slot-bound-using-class? - slot-exists-using-class? slot-ref slot-set! slot-bound? + instance? + slot-ref slot-set! slot-bound? slot-exists? class-name class-direct-supers class-direct-subclasses class-direct-methods class-direct-slots class-precedence-list class-slots @@ -133,15 +131,30 @@ method-specializers method-formals primitive-generic-generic enable-primitive-generic! method-procedure accessor-method-slot-definition - slot-exists? make find-method get-keyword) - #:no-backtrace) + make find-method get-keyword)) + -;; First initialize the builtin part of GOOPS +;;; +;;; Booting GOOPS is a tortuous process. We begin by loading a small +;;; set of primitives from C. +;;; (eval-when (expand load eval) (load-extension (string-append "libguile-" (effective-version)) "scm_init_goops_builtins") (add-interesting-primitive! 'class-of)) + + + +;;; +;;; We then define the slots that must appear in all classes ( +;;; objects) and slot definitions ( 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 +;;; instances, and to compute the slot definition lists for . +;;; Because the list is needed at expansion-time, we define it as a +;;; macro. +;;; (define-syntax macro-fold-left (syntax-rules () ((_ folder seed ()) seed) @@ -154,50 +167,159 @@ ((_ folder seed (head . tail)) (folder head (macro-fold-right folder seed tail))))) -(define-syntax fold--slots - (lambda (x) - (define slots - '((layout ) - (flags ) - (self ) - (instance-finalizer ) - (print) - (name ) - (nfields ) - (%reserved ) - (redefined) - (direct-supers) - (direct-slots) - (direct-subclasses) - (direct-methods) - (cpl) - (slots) - (getters-n-setters))) - (syntax-case x () - ((_ fold visit seed) - ;; The datum->syntax makes it as if the identifiers in `slots' - ;; were present in the initial form, which allows them to be used - ;; as (components of) introduced identifiers. - #`(fold visit seed #,(datum->syntax #'visit slots)))))) - -;; Define class-index-layout to 0, class-index-flags to 1, and so on. -(let-syntax ((define-class-index - (lambda (x) - (define (id-append ctx a b) - (datum->syntax ctx (symbol-append (syntax->datum a) - (syntax->datum b)))) - (define (tail-length tail) - (syntax-case tail () - ((begin) 0) - ((visit head tail) (1+ (tail-length #'tail))))) - (syntax-case x () - ((_ (name . _) tail) - #`(begin - (define #,(id-append #'name #'class-index- #'name) - #,(tail-length #'tail)) - tail)))))) - (fold--slots macro-fold-left define-class-index (begin))) +(define-syntax-rule (define-macro-folder macro-folder value ...) + (define-syntax macro-folder + (lambda (x) + (syntax-case x () + ((_ fold visit seed) + ;; The datum->syntax makes it as if each `value' were present + ;; in the initial form, which allows them to be used as + ;; (components of) introduced identifiers. + #`(fold visit seed #,(datum->syntax #'visit '(value ...)))))))) + +(define-macro-folder fold-class-slots + (layout #:class ) + (flags #:class ) + (self #:class ) + (instance-finalizer #:class ) + (print) + (name #:class ) + (nfields #:class ) + (%reserved #:class ) + (redefined) + (direct-supers) + (direct-slots) + (direct-subclasses) + (direct-methods) + (cpl) + (slots)) + +(define-macro-folder fold-slot-slots + (name #:init-keyword #:name) + (allocation #:init-keyword #:allocation #:init-value #:instance) + (init-keyword #:init-keyword #:init-keyword #:init-value #f) + (init-form #:init-keyword #:init-form) + (init-value #:init-keyword #:init-value) + (init-thunk #:init-keyword #:init-thunk #:init-value #f) + (options) + (getter #:init-keyword #:getter #:init-value #f) + (setter #:init-keyword #:setter #:init-value #f) + (accessor #:init-keyword #:accessor #:init-value #f) + ;; These last don't have #:init-keyword because they are meant to be + ;; set by `allocate-slots', not in compute-effective-slot-definition. + (slot-ref #:init-value #f) + (slot-set! #:init-value #f) + (index #:init-value #f) + (size #:init-value #f)) + +;;; +;;; Statically define variables for slot offsets: `class-index-layout' +;;; will be 0, `class-index-flags' will be 1, and so on, and the same +;;; for `slot-index-name' and such for . +;;; +(let-syntax ((define-slot-indexer + (syntax-rules () + ((_ define-index prefix) + (define-syntax define-index + (lambda (x) + (define (id-append ctx a b) + (datum->syntax ctx (symbol-append (syntax->datum a) + (syntax->datum b)))) + (define (tail-length tail) + (syntax-case tail () + ((begin) 0) + ((visit head tail) (1+ (tail-length #'tail))))) + (syntax-case x () + ((_ (name . _) tail) + #`(begin + (define-syntax #,(id-append #'name #'prefix #'name) + (identifier-syntax #,(tail-length #'tail))) + tail))))))))) + (define-slot-indexer define-class-index class-index-) + (define-slot-indexer define-slot-index slot-index-) + (fold-class-slots macro-fold-left define-class-index (begin)) + (fold-slot-slots macro-fold-left define-slot-index (begin))) + +;;; +;;; Structs that are vtables have a "flags" slot, which corresponds to +;;; class-index-flags. `vtable-flag-vtable' indicates that instances of +;;; a vtable are themselves vtables, and `vtable-flag-validated' +;;; indicates that the struct's layout has been validated. goops.c +;;; defines a few additional flags: one to indicate that a vtable is +;;; actually a class, one to indicate that the class is "valid" (meaning +;;; that it hasn't been redefined), and one to indicate that instances +;;; of a class are slot definition objects ( instances). +;;; +(define vtable-flag-goops-metaclass + (logior vtable-flag-vtable vtable-flag-goops-class)) + +(define-inlinable (class-add-flags! class flags) + (struct-set! class class-index-flags + (logior flags (struct-ref class class-index-flags)))) + +(define-inlinable (class-clear-flags! class flags) + (struct-set! class class-index-flags + (logand (lognot flags) (struct-ref class class-index-flags)))) + +(define-inlinable (class-has-flags? class flags) + (eqv? flags + (logand (struct-ref class class-index-flags) flags))) + +(define-inlinable (class? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass)) + +(define-inlinable (slot? obj) + (and (struct? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot))) + +(define-inlinable (instance? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-class)) + +;;; +;;; Now that we know the slots that must be present in classes, and +;;; their offsets, we can create the root of the class hierarchy. +;;; +;;; Note that the `direct-supers', `direct-slots', `cpl', and `slots' +;;; fields will be updated later, once we can create slot definition +;;; objects and once we have definitions for and . +;;; +(define + (let-syntax ((cons-layout + ;; A simple way to compute class layout for the concrete + ;; types used in . + (syntax-rules ( + + + ) + ((_ (name) tail) + (string-append "pw" tail)) + ((_ (name #:class ) tail) + (string-append "pr" tail)) + ((_ (name #:class ) tail) + (string-append "sr" tail)) + ((_ (name #:class ) tail) + (string-append "uh" tail)) + ((_ (name #:class ) tail) + (string-append "ph" tail))))) + (let* ((layout (fold-class-slots macro-fold-right cons-layout "")) + (nfields (/ (string-length layout) 2)) + ( (%make-vtable-vtable layout))) + (class-add-flags! (logior vtable-flag-goops-class + vtable-flag-goops-valid)) + (struct-set! class-index-name ') + (struct-set! class-index-nfields nfields) + (struct-set! class-index-direct-supers '()) + (struct-set! class-index-direct-slots '()) + (struct-set! class-index-direct-subclasses '()) + (struct-set! class-index-direct-methods '()) + (struct-set! class-index-cpl '()) + (struct-set! class-index-slots '()) + (struct-set! class-index-redefined #f) + ))) +;;; +;;; Accessors to fields of . +;;; (define-syntax-rule (define-class-accessor name docstring field) (define (name obj) docstring @@ -230,22 +352,230 @@ 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?)) -;; -;; is-a? -;; (define (is-a? obj class) + "Return @code{#t} if @var{obj} is an instance of @var{class}, or +@code{#f} otherwise." (and (memq class (class-precedence-list (class-of obj))) #t)) + + + +;;; +;;; At this point, is missing slot definitions, but we can't +;;; create slot definitions until we have a slot definition class. +;;; Continue with manual object creation until we're able to bootstrap +;;; more of the protocol. Again, the CPL and class hierarchy slots +;;; remain uninitialized. +;;; +(define* (get-keyword key l #:optional default) + "Determine an associated value for the keyword @var{key} from the list +@var{l}. The list @var{l} has to consist of an even number of elements, +where, starting with the first, every second element is a keyword, +followed by its associated value. If @var{l} does not hold a value for +@var{key}, the value @var{default} is returned." + (unless (keyword? key) + (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f)) + (let lp ((l l)) + (match l + (() default) + ((kw arg . l) + (unless (keyword? kw) + (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f)) + (if (eq? kw key) arg (lp l)))))) + +(define *unbound* (list 'unbound)) + +(define-inlinable (unbound? x) + (eq? x *unbound*)) + +(define (%allocate-instance class) + (let ((obj (allocate-struct class (struct-ref class class-index-nfields)))) + (%clear-fields! obj *unbound*) + obj)) + +(define + (let-syntax ((cons-layout + ;; All slots are "pw" in . + (syntax-rules () + ((_ _ tail) (string-append "pw" tail))))) + (let* ((layout (fold-slot-slots macro-fold-right cons-layout "")) + (nfields (/ (string-length layout) 2)) + ( (make-struct/no-tail (make-struct-layout layout)))) + (class-add-flags! (logior vtable-flag-goops-class + vtable-flag-goops-slot + vtable-flag-goops-valid)) + (struct-set! class-index-name ') + (struct-set! class-index-nfields nfields) + (struct-set! class-index-direct-supers '()) + (struct-set! class-index-direct-slots '()) + (struct-set! class-index-direct-subclasses '()) + (struct-set! class-index-direct-methods '()) + (struct-set! class-index-cpl (list )) + (struct-set! class-index-slots '()) + (struct-set! class-index-redefined #f) + ))) + +;;; Access to slot objects is performance-sensitive for slot-ref, so in +;;; addition to the type-checking accessors that we export, we also +;;; define some internal inlined helpers that just do an unchecked +;;; struct-ref in cases where we know the object must be a slot, as +;;; when accessing class-slots. +;;; +(define-syntax-rule (define-slot-accessor name docstring %name field) + (begin + (define-syntax-rule (%name obj) + (struct-ref obj field)) + (define (name obj) + docstring + (unless (slot? obj) + (scm-error 'wrong-type-arg #f "Not a slot: ~S" + (list obj) #f)) + (%name obj)))) + +(define-slot-accessor slot-definition-name + "Return the name of @var{obj}." + %slot-definition-name slot-index-name) +(define-slot-accessor slot-definition-allocation + "Return the allocation of the slot @var{obj}." + %slot-definition-allocation slot-index-allocation) +(define-slot-accessor slot-definition-init-keyword + "Return the init keyword of the slot @var{obj}, or @code{#f}." + %slot-definition-init-keyword slot-index-init-keyword) +(define-slot-accessor slot-definition-init-form + "Return the init form of the slot @var{obj}, or the unbound value" + %slot-definition-init-form slot-index-init-form) +(define-slot-accessor slot-definition-init-value + "Return the init value of the slot @var{obj}, or the unbound value." + %slot-definition-init-value slot-index-init-value) +(define-slot-accessor slot-definition-init-thunk + "Return the init thunk of the slot @var{obj}, or @code{#f}." + %slot-definition-init-thunk slot-index-init-thunk) +(define-slot-accessor slot-definition-options + "Return the initargs given when creating the slot @var{obj}." + %slot-definition-options slot-index-options) +(define-slot-accessor slot-definition-getter + "Return the getter of the slot @var{obj}, or @code{#f}." + %slot-definition-getter slot-index-getter) +(define-slot-accessor slot-definition-setter + "Return the setter of the slot @var{obj}, or @code{#f}." + %slot-definition-setter slot-index-setter) +(define-slot-accessor slot-definition-accessor + "Return the accessor of the slot @var{obj}, or @code{#f}." + %slot-definition-accessor slot-index-accessor) +(define-slot-accessor slot-definition-slot-ref + "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}." + %slot-definition-slot-ref slot-index-slot-ref) +(define-slot-accessor slot-definition-slot-set! + "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}." + %slot-definition-slot-set! slot-index-slot-set!) +(define-slot-accessor slot-definition-index + "Return the allocated struct offset of the slot @var{obj}, or @code{#f}." + %slot-definition-index slot-index-index) +(define-slot-accessor slot-definition-size + "Return the number fields used by the slot @var{obj}, or @code{#f}." + %slot-definition-size slot-index-size) + +;; Boot definition. +(define (direct-slot-definition-class class initargs) + (get-keyword #:class initargs )) + +;; Boot definition. +(define (make-slot class initargs) + (let ((slot (make-struct/no-tail class))) + (define-syntax-rule (init-slot offset kw default) + (struct-set! slot offset (get-keyword kw initargs default))) + (init-slot slot-index-name #:name #f) + (init-slot slot-index-allocation #:allocation #:instance) + (init-slot slot-index-init-keyword #:init-keyword #f) + (init-slot slot-index-init-form #:init-form *unbound*) + (init-slot slot-index-init-value #:init-value *unbound*) + (struct-set! slot slot-index-init-thunk + (or (get-keyword #:init-thunk initargs #f) + (let ((val (%slot-definition-init-value slot))) + (if (unbound? val) + #f + (lambda () val))))) + (struct-set! slot slot-index-options initargs) + (init-slot slot-index-getter #:getter #f) + (init-slot slot-index-setter #:setter #f) + (init-slot slot-index-accessor #:accessor #f) + (init-slot slot-index-slot-ref #:slot-ref #f) + (init-slot slot-index-slot-set! #:slot-set! #f) + (init-slot slot-index-index #:index #f) + (init-slot slot-index-size #:size #f) + slot)) + +;; Boot definition. +(define (make class . args) + (unless (memq (class-precedence-list class)) + (error "Unsupported class: ~S" class)) + (make-slot class args)) + +;; Boot definition. +(define (compute-direct-slot-definition class initargs) + (apply make (direct-slot-definition-class class initargs) initargs)) + +(define (compute-direct-slot-definition-initargs class slot-spec) + (match slot-spec + ((? symbol? name) (list #:name name)) + (((? symbol? name) . initargs) + (cons* #:name name + ;; If there is an #:init-form, the `class' macro will have + ;; already added an #:init-thunk. Still, if there isn't an + ;; #:init-thunk already but we do have an #:init-value, + ;; synthesize an #:init-thunk initarg. This will ensure + ;; that the #:init-thunk gets passed on to the effective + ;; slot definition too. + (if (get-keyword #:init-thunk initargs) + initargs + (let ((value (get-keyword #:init-value initargs *unbound*))) + (if (unbound? value) + initargs + (cons* #:init-thunk (lambda () value) initargs)))))))) + +(let () + (define-syntax cons-slot + (syntax-rules () + ((_ (name #:class class) tail) + ;; Special case to avoid referencing specialized kinds, + ;; which are not defined yet. + (cons (list 'name) tail)) + ((_ (name . initargs) tail) + (cons (list 'name . initargs) tail)))) + (define-syntax-rule (initialize-direct-slots! class fold-slots) + (let ((specs (fold-slots macro-fold-right cons-slot '()))) + (define (make-direct-slot-definition spec) + (let ((initargs (compute-direct-slot-definition-initargs class spec))) + (compute-direct-slot-definition class initargs))) + (struct-set! class class-index-direct-slots + (map make-direct-slot-definition specs)))) + + (initialize-direct-slots! fold-class-slots) + (initialize-direct-slots! fold-slot-slots)) + + + + +;;; +;;; OK, at this point we have initialized `direct-slots' on both +;;; and . 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) @@ -265,8 +595,8 @@ (and (not (null? l)) (candidate (car l))))) (next (any candidate-car inputs))) - (if (not next) - (goops-error "merge-lists: Inconsistent precedence graph")) + (unless next + (goops-error "merge-lists: Inconsistent precedence graph")) (let ((remove-next (lambda (l) (if (eq? (car l) next) (cdr l) @@ -284,75 +614,104 @@ (define (compute-cpl class) (compute-std-cpl class class-direct-supers)) +(define (effective-slot-definition-class class slot) + (class-of slot)) + +(define (compute-effective-slot-definition class slot) + ;; FIXME: Support slot being a list of slots, as in CLOS. + (apply make + (effective-slot-definition-class class slot) + (slot-definition-options slot))) + (define (build-slots-list dslots cpl) - (define (check-cpl slots class-slots) - (when (or-map (lambda (slot-def) (assq (car slot-def) slots)) - class-slots) + (define (slot-memq slot slots) + (let ((name (%slot-definition-name slot))) + (let lp ((slots slots)) + (match slots + (() #f) + ((slot . slots) + (or (eq? (%slot-definition-name slot) name) (lp slots))))))) + (define (check-cpl slots static-slots) + (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots) (scm-error 'misc-error #f - "a predefined inherited field cannot be redefined" + "a predefined static inherited field cannot be redefined" '() '()))) (define (remove-duplicate-slots slots) (let lp ((slots (reverse slots)) (res '()) (seen '())) - (cond - ((null? slots) res) - ((memq (caar slots) seen) - (lp (cdr slots) res seen)) - (else - (lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen)))))) - (let* ((class-slots (and (memq cpl) - (struct-ref class-index-slots)))) - (when class-slots - (check-cpl dslots class-slots)) - (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '())) - (if (null? cpl) - (remove-duplicate-slots (append class-slots res)) - (let* ((head (car cpl)) - (cpl (cdr cpl)) - (new-slots (struct-ref head class-index-direct-slots))) - (cond - ((not class-slots) - (lp cpl (append new-slots res) class-slots)) - ((eq? head ) - ;; Move class slots to the head of the list. - (lp cpl res new-slots)) - (else - (check-cpl new-slots class-slots) - (lp cpl (append new-slots res) class-slots)))))))) - -(define (%compute-getters-n-setters slots) - (define (compute-init-thunk options) - (cond - ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val))) - ((kw-arg-ref options #:init-thunk)) - (else #f))) - (let lp ((slots slots) (n 0)) - (match slots - (() '()) - (((name . options) . slots) - (cons (cons name (cons (compute-init-thunk options) n)) - (lp slots (1+ n))))))) - -(define (%compute-layout slots getters-n-setters nfields is-class?) - (define (instance-allocated? g-n-s) - (match g-n-s - ((name init-thunk . (? exact-integer? index)) #t) - ((name init-thunk getter setter index size) #t) - (_ #f))) - - (define (allocated-index g-n-s) - (match g-n-s - ((name init-thunk . (? exact-integer? index)) index) - ((name init-thunk getter setter index size) index))) - - (define (allocated-size g-n-s) - (match g-n-s - ((name init-thunk . (? exact-integer? index)) 1) - ((name init-thunk getter setter index size) size))) + (match slots + (() res) + ((slot . slots) + (let ((name (%slot-definition-name slot))) + (if (memq name seen) + (lp slots res seen) + (lp slots (cons slot res) (cons name seen)))))))) + ;; For subclases of and , we need to ensure that the + ;; or slots come first. + (let* ((static-slots (cond + ((memq cpl) + (when (memq cpl) (error "invalid class")) + (struct-ref class-index-slots)) + ((memq cpl) + (struct-ref class-index-slots)) + (else #f)))) + (when static-slots + (check-cpl dslots static-slots)) + (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '())) + (match cpl + (() (remove-duplicate-slots (append static-slots res))) + ((head . cpl) + (let ((new-slots (struct-ref head class-index-direct-slots))) + (cond + ((not static-slots) + (lp cpl (append new-slots res) static-slots)) + ((or (eq? head ) (eq? head )) + ;; Move static slots to the head of the list. + (lp cpl res new-slots)) + (else + (check-cpl new-slots static-slots) + (lp cpl (append new-slots res) static-slots))))))))) - (define (slot-protection-and-kind options) +;; Boot definition. +(define (compute-get-n-set class slot) + (let ((index (struct-ref class class-index-nfields))) + (struct-set! class class-index-nfields (1+ index)) + index)) + +(define (allocate-slots class slots) + "Transform the computed list of direct slot definitions @var{slots} +into a corresponding list of effective slot definitions, allocating +slots as we go." + (define (make-effective-slot-definition slot) + ;; `compute-get-n-set' is expected to mutate `nfields' if it + ;; allocates a field to the object. Pretty strange, but we preserve + ;; the behavior for backward compatibility. + (let* ((slot (compute-effective-slot-definition class slot)) + (index (struct-ref class class-index-nfields)) + (g-n-s (compute-get-n-set class slot)) + (size (- (struct-ref class class-index-nfields) index))) + (call-with-values + (lambda () + (match g-n-s + ((? integer?) + (unless (= size 1) + (error "unexpected return from compute-get-n-set")) + (values #f #f)) + (((? procedure? get) (? procedure? set)) + (values get set)))) + (lambda (get set) + (struct-set! slot slot-index-index index) + (struct-set! slot slot-index-size size) + (struct-set! slot slot-index-slot-ref get) + (struct-set! slot slot-index-slot-set! set))) + slot)) + (struct-set! class class-index-nfields 0) + (map-in-order make-effective-slot-definition slots)) + +(define (%compute-layout slots nfields is-class?) + (define (slot-protection-and-kind slot) (define (subclass? class parent) (memq parent (class-precedence-list class))) - (let ((type (kw-arg-ref options #:class))) + (let ((type (kw-arg-ref (%slot-definition-options slot) #:class))) (if (and type (subclass? type )) (values (cond ((subclass? type ) #\s) @@ -364,113 +723,70 @@ ((subclass? type ) #\h) (else #\w))) (values #\p #\w)))) - (let ((layout (make-string (* nfields 2)))) - (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters)) - (match getters-n-setters + (let lp ((n 0) (slots slots)) + (match slots (() (unless (= n nfields) (error "bad nfields")) - (unless (null? slots) (error "inconsistent g-n-s/slots")) (when is-class? (let ((class-layout (struct-ref class-index-layout))) (unless (string-prefix? (symbol->string class-layout) layout) (error "bad layout for class")))) layout) - ((g-n-s . getters-n-setters) - (match slots - (((name . options) . slots) - (cond - ((instance-allocated? g-n-s) - (unless (< n nfields) (error "bad nfields")) - (unless (= n (allocated-index g-n-s)) (error "bad allocation")) - (call-with-values (lambda () (slot-protection-and-kind options)) - (lambda (protection kind) - (let init ((n n) (size (allocated-size g-n-s))) - (cond - ((zero? size) (lp n slots getters-n-setters)) - (else - (string-set! layout (* n 2) protection) - (string-set! layout (1+ (* n 2)) kind) - (init (1+ n) (1- size)))))))) - (else - (lp n slots getters-n-setters)))))))))) + ((slot . slots) + (unless (= n (%slot-definition-index slot)) (error "bad allocation")) + (call-with-values (lambda () (slot-protection-and-kind slot)) + (lambda (protection kind) + (let init ((n n) (size (%slot-definition-size slot))) + (cond + ((zero? size) (lp n slots)) + (else + (unless (< n nfields) (error "bad nfields")) + (string-set! layout (* n 2) protection) + (string-set! layout (1+ (* n 2)) kind) + (init (1+ n) (1- size)))))))))))) + + + +;;; +;;; With all of this, we are now able to define subclasses of . +;;; (define (%prep-layout! class) (let* ((is-class? (and (memq (struct-ref class class-index-cpl)) #t)) - (layout (%compute-layout - (struct-ref class class-index-slots) - (struct-ref class class-index-getters-n-setters) - (struct-ref class class-index-nfields) - is-class?))) + (layout (%compute-layout (struct-ref class class-index-slots) + (struct-ref class class-index-nfields) + is-class?))) (%init-layout! class layout))) (define (make-standard-class class name dsupers dslots) (let ((z (make-struct/no-tail class))) + (define (make-direct-slot-definition dslot) + (let ((initargs (compute-direct-slot-definition-initargs z dslot))) + (compute-direct-slot-definition z initargs))) + + (struct-set! z class-index-name name) + (struct-set! z class-index-nfields 0) (struct-set! z class-index-direct-supers dsupers) - (let* ((cpl (compute-cpl z)) - (dslots (map (lambda (slot) - (if (pair? slot) slot (list slot))) - dslots)) - (slots (build-slots-list dslots cpl)) - (nfields (length slots)) - (g-n-s (%compute-getters-n-setters slots))) - (struct-set! z class-index-name name) - (struct-set! z class-index-nfields nfields) - (struct-set! z class-index-direct-slots dslots) - (struct-set! z class-index-direct-subclasses '()) - (struct-set! z class-index-direct-methods '()) + (struct-set! z class-index-direct-subclasses '()) + (struct-set! z class-index-direct-methods '()) + (struct-set! z class-index-redefined #f) + (let ((cpl (compute-cpl z))) (struct-set! z class-index-cpl cpl) - (struct-set! z class-index-slots slots) - (struct-set! z class-index-getters-n-setters g-n-s) - (struct-set! z class-index-redefined #f) - (for-each (lambda (super) - (let ((subclasses - (struct-ref super class-index-direct-subclasses))) - (struct-set! super class-index-direct-subclasses - (cons z subclasses)))) - dsupers) - (%prep-layout! z) - z))) - -(define - (let-syntax ((cons-dslot - ;; The specialized slot classes have not been defined - ;; yet; initialize with unspecialized slots. - (syntax-rules () - ((_ (name) tail) (cons (list 'name) tail)) - ((_ (name class) tail) (cons (list 'name) tail)))) - (cons-layout - ;; A simple way to compute class layout for the concrete - ;; types used in . - (syntax-rules ( - ) - ((_ (name) tail) - (string-append "pw" tail)) - ((_ (name ) tail) - (string-append "pr" tail)) - ((_ (name ) tail) - (string-append "sr" tail)) - ((_ (name ) tail) - (string-append "uh" tail)) - ((_ (name ) tail) - (string-append "ph" tail))))) - (let* ((dslots (fold--slots macro-fold-right cons-dslot '())) - (layout (fold--slots macro-fold-right cons-layout "")) - ( (%make-root-class layout))) - ;; The `direct-supers', `direct-slots', `cpl', `slots', and - ;; `getters-n-setters' fields will be updated later. - (struct-set! class-index-name ') - (struct-set! class-index-nfields (length dslots)) - (struct-set! class-index-direct-supers '()) - (struct-set! class-index-direct-slots dslots) - (struct-set! class-index-direct-subclasses '()) - (struct-set! class-index-direct-methods '()) - (struct-set! class-index-cpl '()) - (struct-set! class-index-slots dslots) - (struct-set! class-index-getters-n-setters - (%compute-getters-n-setters dslots)) - (struct-set! class-index-redefined #f) - ))) + (when (memq cpl) + (class-add-flags! z vtable-flag-goops-slot)) + (let* ((dslots (map make-direct-slot-definition dslots)) + (slots (allocate-slots z (build-slots-list dslots cpl)))) + (struct-set! z class-index-direct-slots dslots) + (struct-set! z class-index-slots slots))) + (for-each + (lambda (super) + (let ((subclasses (struct-ref super class-index-direct-subclasses))) + (struct-set! super class-index-direct-subclasses + (cons z subclasses)))) + dsupers) + (%prep-layout! z) + z)) (define-syntax define-standard-class (syntax-rules () @@ -480,16 +796,33 @@ ((define-standard-class name (super ...) slot ...) (define-standard-class name (super ...) #:metaclass slot ...)))) + + + +;;; +;;; Sweet! Now we can define and , and finish +;;; initializing the `direct-subclasses', `direct-supers', and `cpl' +;;; slots of . +;;; (define-standard-class ()) (define-standard-class ()) -;; , , and were partially initialized. Correct -;; them here. -(struct-set! class-index-direct-subclasses (list )) +;; The inheritance links for , , , and were +;; partially initialized. Correct them here. +(struct-set! class-index-direct-subclasses (list )) (struct-set! class-index-direct-supers (list )) +(struct-set! class-index-direct-supers (list )) (struct-set! class-index-cpl (list )) +(struct-set! class-index-cpl (list )) -(define-standard-class ()) + + + +;;; +;;; We can also define the various slot types, and finish initializing +;;; `direct-slots' and `slots' on and . +;;; +(define-standard-class ()) (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) @@ -506,27 +839,52 @@ (define-standard-class ()) (define-standard-class ()) -;; Finish initialization of with specialized slots. -(let-syntax ((visit - (syntax-rules () - ((_ (name) tail) - (cons (list 'name) tail)) - ((_ (name class) tail) - (cons (list 'name #:class class) tail))))) - (let* ((dslots (fold--slots macro-fold-right visit '())) - (g-n-s (%compute-getters-n-setters dslots))) - (struct-set! class-index-direct-slots dslots) - (struct-set! class-index-slots dslots) - (struct-set! class-index-getters-n-setters g-n-s))) - -;; Applicables and their classes. + + + +;;; +;;; Finally! Initialize `direct-slots' and `slots' on , and +;;; `slots' on . +;;; +(let () + (define-syntax-rule (cons-slot (name . initargs) tail) + (cons (list 'name . initargs) tail)) + (define-syntax-rule (initialize-direct-slots! class fold-slots) + (let ((specs (fold-slots macro-fold-right cons-slot '()))) + (define (make-direct-slot-definition spec) + (let ((initargs (compute-direct-slot-definition-initargs class spec))) + (compute-direct-slot-definition class initargs))) + (struct-set! class class-index-direct-slots + (map make-direct-slot-definition specs)))) + (define (initialize-slots! class) + (let ((slots (build-slots-list (class-direct-slots class) + (class-precedence-list class)))) + (struct-set! class class-index-slots (allocate-slots class slots)))) + + ;; Finish initializing with the specialized slot kinds. + (initialize-direct-slots! fold-class-slots) + + (initialize-slots! ) + (initialize-slots! )) + + + + +;;; +;;; Now, to build out the class hierarchy. +;;; + (define-standard-class ()) + (define-standard-class ()) +(class-add-flags! + vtable-flag-applicable-vtable) + (define-standard-class ()) -(%bless-applicable-struct-vtables! - ) +(class-add-flags! + vtable-flag-setter-vtable) (define-standard-class ()) (define-standard-class ( ) @@ -556,7 +914,6 @@ ) #:metaclass ) -;; Methods (define-standard-class () generic-function specializers @@ -567,10 +924,11 @@ (define-standard-class () (slot-definition #:init-keyword #:slot-definition)) -;; Primitive types classes (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) +;; Not all pairs are lists, but there is code out there that relies on +;; (is-a? '(1 2 3) ) to work. Terrible. How to fix? (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) @@ -628,41 +986,26 @@ function." (struct-set! class-index-direct-subclasses (cons class subclasses))))) + + + +;;; +;;; At this point we have defined the class hierarchy, and it's time to +;;; move on to instance allocation and generics. Once we have generics, +;;; we'll fill out the metaobject protocol. +;;; +;;; Here we define a limited version of `make', so that we can allocate +;;; instances of specific classes. This definition will be replaced +;;; later. +;;; (define (%invalidate-method-cache! gf) - (slot-set! gf 'procedure (delayed-compile gf)) - (slot-set! gf 'effective-methods '())) + (slot-set! gf 'effective-methods '()) + (recompute-generic-function-dispatch-procedure! gf)) ;; Boot definition. (define (invalidate-method-cache! gf) (%invalidate-method-cache! gf)) -(define* (get-keyword key l #:optional default) - "Determine an associated value for the keyword @var{key} from the list -@var{l}. The list @var{l} has to consist of an even number of elements, -where, starting with the first, every second element is a keyword, -followed by its associated value. If @var{l} does not hold a value for -@var{key}, the value @var{default} is returned." - (unless (keyword? key) - (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f)) - (let lp ((l l)) - (match l - (() default) - ((kw arg . l) - (unless (keyword? kw) - (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f)) - (if (eq? kw key) arg (lp l)))))) - -;; A simple make which will be redefined later. This version handles -;; only creation of gf, methods and classes (no instances). -;; -;; Since this code will disappear when Goops will be fully booted, -;; no precaution is taken to be efficient. -;; -(define (%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 ) (eq? class )) @@ -688,113 +1031,163 @@ followed by its associated value. If @var{l} does not hold a value for (#:body body ()) (#:make-procedure make-procedure #f)))) ((memq (class-precedence-list class)) + (class-add-flags! z (logior vtable-flag-goops-class + vtable-flag-goops-valid)) (for-each (match-lambda ((kw slot default) (slot-set! z slot (get-keyword kw args default)))) '((#:name name ???) (#:dsupers direct-supers ()) - (#:slots direct-slots ()) - ))) + (#:slots direct-slots ())))) (else (error "boot `make' does not support this class" class))) z)))) -;; In the future, this function will return the effective slot -;; definition associated with SLOT_NAME. Now it just returns some of -;; the information which will be stored in the effective slot -;; definition. -;; -(define (get-slot-value-using-name class obj slot-name) - (match (assq slot-name (struct-ref class class-index-getters-n-setters)) - (#f (slot-missing class obj slot-name)) - ((name init-thunk . (? exact-integer? index)) - (struct-ref obj index)) - ((name init-thunk getter setter . _) - (getter obj)))) - -(define (set-slot-value-using-name! class obj slot-name value) - (match (assq slot-name (struct-ref class class-index-getters-n-setters)) - (#f (slot-missing class obj slot-name value)) - ((name init-thunk . (? exact-integer? index)) - (struct-set! obj index value)) - ((name init-thunk getter setter . _) - (setter obj value)))) - -(define (test-slot-existence class obj slot-name) - (and (assq slot-name (struct-ref class class-index-getters-n-setters)) - #t)) - -;; ======================================== - -(define (check-slot-args class obj slot-name) - (unless (class? class) - (scm-error 'wrong-type-arg #f "Not a class: ~S" - (list class) #f)) - (unless (is-a? obj ) - (scm-error 'wrong-type-arg #f "Not an instance: ~S" - (list obj) #f)) - (unless (symbol? slot-name) - (scm-error 'wrong-type-arg #f "Not a symbol: ~S" - (list slot-name) #f))) - -(define (slot-ref-using-class class obj slot-name) - (check-slot-args class obj slot-name) - (let ((val (get-slot-value-using-name class obj slot-name))) - (if (unbound? val) - (slot-unbound class obj slot-name) - val))) - -(define (slot-set-using-class! class obj slot-name value) - (check-slot-args class obj slot-name) - (set-slot-value-using-name! class obj slot-name value)) - -(define (slot-bound-using-class? class obj slot-name) - (check-slot-args class obj slot-name) - (not (unbound? (get-slot-value-using-name class obj slot-name)))) - -(define (slot-exists-using-class? class obj slot-name) - (check-slot-args class obj slot-name) - (test-slot-existence class obj slot-name)) - -;; Class redefinition protocol: -;; -;; A class is represented by a heap header h1 which points to a -;; malloc:ed memory block m1. -;; -;; When a new version of a class is created, a new header h2 and -;; memory block m2 are allocated. The headers h1 and h2 then switch -;; pointers so that h1 refers to m2 and h2 to m1. In this way, names -;; bound to h1 will point to the new class at the same time as h2 will -;; be a handle which the GC will use to free m1. -;; -;; The `redefined' slot of m1 will be set to point to h1. An old -;; instance will have its class pointer (the CAR of the heap header) -;; pointing to m1. The non-immediate `redefined'-slot in m1 indicates -;; the class modification and the new class pointer can be found via -;; h1. -;; -;; In the following interfaces, class-of handles the redefinition -;; protocol. There would seem to be some thread-unsafety though as the -;; { class, object data } pair needs to be accessed atomically, not the -;; { class, object } pair. + + +;;; +;;; Slot access. +;;; +;;; Before we go on, some notes about class redefinition. In GOOPS, +;;; classes can be redefined. Redefinition of a class marks the class +;;; as invalid, and instances will be lazily migrated over to the new +;;; representation as they are accessed. Migration happens when +;;; `class-of' is called on an instance. For more technical details on +;;; object redefinition, see struct.h. +;;; +;;; In the following interfaces, class-of handles the redefinition +;;; protocol. I would think though that there is some thread-unsafety +;;; here though as the { class, object data } pair needs to be accessed +;;; atomically, not the { class, object } pair. +;;; +(define-inlinable (%class-slot-definition class slot-name kt kf) + (let lp ((slots (struct-ref class class-index-slots))) + (match slots + ((slot . slots) + (if (eq? (%slot-definition-name slot) slot-name) + (kt slot) + (lp slots))) + (_ (kf))))) + +(define (class-slot-definition class slot-name) + (unless (class? class) + (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f)) + (%class-slot-definition class slot-name + (lambda (slot) slot) + (lambda () #f))) (define (slot-ref obj slot-name) "Return the value from @var{obj}'s slot with the nam var{slot_name}." - (slot-ref-using-class (class-of obj) obj slot-name)) + (let ((class (class-of obj))) + (define (slot-value slot) + (cond + ((%slot-definition-slot-ref slot) + => (lambda (slot-ref) (slot-ref obj))) + (else + (struct-ref obj (%slot-definition-index slot))))) + (define (have-slot slot) + (let ((val (slot-value slot))) + (if (unbound? val) + (slot-unbound class obj slot-name) + val))) + (define (no-slot) + (unless (symbol? slot-name) + (scm-error 'wrong-type-arg #f "Not a symbol: ~S" + (list slot-name) #f)) + (let ((val (slot-missing class obj slot-name))) + (if (unbound? val) + (slot-unbound class obj slot-name) + val))) + (%class-slot-definition class slot-name have-slot no-slot))) (define (slot-set! obj slot-name value) "Set the slot named @var{slot_name} of @var{obj} to @var{value}." - (slot-set-using-class! (class-of obj) obj slot-name value)) + (let ((class (class-of obj))) + (define (have-slot slot) + (cond + ((%slot-definition-slot-set! slot) + => (lambda (slot-set!) (slot-set! obj value))) + (else + (struct-set! obj (%slot-definition-index slot) value)))) + (define (no-slot) + (unless (symbol? slot-name) + (scm-error 'wrong-type-arg #f "Not a symbol: ~S" + (list slot-name) #f)) + (slot-missing class obj slot-name value)) + + (%class-slot-definition class slot-name have-slot no-slot))) (define (slot-bound? obj slot-name) "Return the value from @var{obj}'s slot with the nam var{slot_name}." - (slot-bound-using-class? (class-of obj) obj slot-name)) + (let ((class (class-of obj))) + (define (slot-value slot) + (cond + ((%slot-definition-slot-ref slot) + => (lambda (slot-ref) (slot-ref obj))) + (else + (struct-ref obj (%slot-definition-index slot))))) + (define (have-slot slot) + (not (unbound? (slot-value slot)))) + (define (no-slot) + (unless (symbol? slot-name) + (scm-error 'wrong-type-arg #f "Not a symbol: ~S" + (list slot-name) #f)) + (let ((val (slot-missing class obj slot-name))) + (if (unbound? val) + (slot-unbound class obj slot-name) + val))) + (%class-slot-definition class slot-name have-slot no-slot))) (define (slot-exists? obj slot-name) "Return @code{#t} if @var{obj} has a slot named @var{slot_name}." - (slot-exists-using-class? (class-of obj) obj slot-name)) + (define (have-slot slot) #t) + (define (no-slot) + (unless (symbol? slot-name) + (scm-error 'wrong-type-arg #f "Not a symbol: ~S" + (list slot-name) #f)) + #f) + (%class-slot-definition (class-of obj) slot-name have-slot no-slot)) + +(begin-deprecated + (define (check-slot-args class obj slot-name) + (unless (eq? class (class-of obj)) + (scm-error 'wrong-type-arg #f "~S is not the class of ~S" + (list class obj) #f)) + (unless (symbol? slot-name) + (scm-error 'wrong-type-arg #f "Not a symbol: ~S" + (list slot-name) #f))) + + (define (slot-ref-using-class class obj slot-name) + (issue-deprecation-warning "slot-ref-using-class is deprecated. " + "Use slot-ref instead.") + (check-slot-args class obj slot-name) + (slot-ref obj slot-name)) + + (define (slot-set-using-class! class obj slot-name value) + (issue-deprecation-warning "slot-set-using-class! is deprecated. " + "Use slot-set! instead.") + (check-slot-args class obj slot-name) + (slot-set! obj slot-name value)) + + (define (slot-bound-using-class? class obj slot-name) + (issue-deprecation-warning "slot-bound-using-class? is deprecated. " + "Use slot-bound? instead.") + (check-slot-args class obj slot-name) + (slot-bound? obj slot-name)) + + (define (slot-exists-using-class? class obj slot-name) + (issue-deprecation-warning "slot-exists-using-class? is deprecated. " + "Use slot-exists? instead.") + (check-slot-args class obj slot-name) + (slot-exists? obj slot-name))) + + + +;;; +;;; Method accessors. +;;; (define (method-generic-function obj) "Return the generic function for the method @var{obj}." (unless (is-a? obj ) @@ -816,15 +1209,20 @@ followed by its associated value. If @var{l} does not hold a value for (list obj) #f)) (slot-ref obj 'procedure)) -(define *dispatch-module* (current-module)) + + +;;; +;;; Generic functions! ;;; ;;; Generic functions have an applicable-methods cache associated with ;;; them. Every distinct set of types that is dispatched through a -;;; generic adds an entry to the cache. This cache gets compiled out to -;;; a dispatch procedure. In steady-state, this dispatch procedure is -;;; never recompiled; but during warm-up there is some churn, both to -;;; the cache and to the dispatch procedure. +;;; generic adds an entry to the cache. A composite dispatch procedure +;;; is recomputed every time an entry gets added to the cache, or when +;;; the cache is invalidated. +;;; +;;; In steady-state, this dispatch procedure is never regenerated; but +;;; during warm-up there is some churn. ;;; ;;; So what is the deal if warm-up happens in a multithreaded context? ;;; There is indeed a window between missing the cache for a certain set @@ -834,7 +1232,7 @@ followed by its associated value. If @var{l} does not hold a value for ;;; ;;; This is actually OK though, because a subsequent cache miss for the ;;; race loser will just cause memoization to try again. The cache will -;;; eventually be consistent. We're not mutating the old part of the +;;; eventually be consistent. We're not mutating the old part of the ;;; cache, just consing on the new entry. ;;; ;;; It doesn't even matter if the dispatch procedure and the cache are @@ -844,185 +1242,191 @@ followed by its associated value. If @var{l} does not hold a value for ;;; re-trigger a memoization, and the cache will finally be consistent. ;;; As you can see there is a possibility for ping-pong effects, but ;;; it's unlikely given the shortness of the window between slot-set! -;;; invocations. We could add a mutex, but it is strictly unnecessary, -;;; and would add runtime cost and complexity. -;;; - -(define (emit-linear-dispatch gf-sym nargs methods free rest?) - (define (gen-syms n stem) - (let lp ((n (1- n)) (syms '())) - (if (< n 0) - syms - (lp (1- n) (cons (gensym stem) syms))))) - (let* ((args (gen-syms nargs "a")) - (types (gen-syms nargs "t"))) - (let lp ((methods methods) - (free free) - (exp `(cache-miss ,gf-sym - ,(if rest? - `(cons* ,@args rest) - `(list ,@args))))) - (cond - ((null? methods) - (values `(,(if rest? `(,@args . rest) args) - (let ,(map (lambda (t a) - `(,t (class-of ,a))) - types args) - ,exp)) - free)) - (else - ;; jeez - (let preddy ((free free) - (types types) - (specs (vector-ref (car methods) 1)) - (checks '())) - (if (null? types) - (let ((m-sym (gensym "p"))) - (lp (cdr methods) - (acons (vector-ref (car methods) 3) - m-sym - free) - `(if (and . ,checks) - ,(if rest? - `(apply ,m-sym ,@args rest) - `(,m-sym . ,args)) - ,exp))) - (let ((var (assq-ref free (car specs)))) - (if var - (preddy free - (cdr types) - (cdr specs) - (cons `(eq? ,(car types) ,var) - checks)) - (let ((var (gensym "c"))) - (preddy (acons (car specs) var free) - (cdr types) - (cdr specs) - (cons `(eq? ,(car types) ,var) - checks)))))))))))) - -(define (compute-dispatch-procedure gf cache) - (define (scan) - (let lp ((ls cache) (nreq -1) (nrest -1)) - (cond - ((null? ls) - (collate (make-vector (1+ nreq) '()) - (make-vector (1+ nrest) '()))) - ((vector-ref (car ls) 2) ; rest - (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0)))) - (else ; req - (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest))))) - (define (collate req rest) - (let lp ((ls cache)) - (cond - ((null? ls) - (emit req rest)) - ((vector-ref (car ls) 2) ; rest - (let ((n (vector-ref (car ls) 0))) - (vector-set! rest n (cons (car ls) (vector-ref rest n))) - (lp (cdr ls)))) - (else ; req - (let ((n (vector-ref (car ls) 0))) - (vector-set! req n (cons (car ls) (vector-ref req n))) - (lp (cdr ls))))))) - (define (emit req rest) - (let ((gf-sym (gensym "g"))) - (define (emit-rest n clauses free) - (if (< n (vector-length rest)) - (let ((methods (vector-ref rest n))) - (cond - ((null? methods) - (emit-rest (1+ n) clauses free)) - ;; FIXME: hash dispatch - (else - (call-with-values - (lambda () - (emit-linear-dispatch gf-sym n methods free #t)) - (lambda (clause free) - (emit-rest (1+ n) (cons clause clauses) free)))))) - (emit-req (1- (vector-length req)) clauses free))) - (define (emit-req n clauses free) - (if (< n 0) - (comp `(lambda ,(map cdr free) - (case-lambda ,@clauses)) - (map car free)) - (let ((methods (vector-ref req n))) - (cond - ((null? methods) - (emit-req (1- n) clauses free)) - ;; FIXME: hash dispatch - (else - (call-with-values - (lambda () - (emit-linear-dispatch gf-sym n methods free #f)) - (lambda (clause free) - (emit-req (1- n) (cons clause clauses) free)))))))) - - (emit-rest 0 - (if (or (zero? (vector-length rest)) - (null? (vector-ref rest 0))) - (list `(args (cache-miss ,gf-sym args))) - '()) - (acons gf gf-sym '())))) - (define (comp exp vals) - ;; When cross-compiling Guile itself, the native Guile must generate - ;; code for the host. - (with-target %host-type - (lambda () - (let ((p ((@ (system base compile) compile) exp - #:env *dispatch-module* - #:from 'scheme - #:opts '(#:partial-eval? #f #:cse? #f)))) - (apply p vals))))) - - ;; kick it. - (scan)) - -;; o/~ ten, nine, eight -;; sometimes that's just how it goes -;; three, two, one -;; -;; get out before it blows o/~ -;; -(define timer-init 30) -(define (delayed-compile gf) - (let ((timer timer-init)) - (lambda args - (set! timer (1- timer)) - (cond - ((zero? timer) - (let ((dispatch (compute-dispatch-procedure - gf (slot-ref gf 'effective-methods)))) - (slot-set! gf 'procedure dispatch) - (apply dispatch args))) - (else - ;; interestingly, this catches recursive compilation attempts as - ;; well; in that case, timer is negative - (cache-dispatch gf args)))))) +;;; invocations. +;;; +;;; We probably do need to use atomic access primitives to correctly +;;; handle concurrency, but that's a more general Guile concern. +;;; -(define (cache-dispatch gf args) - (define (map-until n f ls) - (if (or (zero? n) (null? ls)) - '() - (cons (f (car ls)) (map-until (1- n) f (cdr ls))))) - (define (equal? x y) ; can't use the stock equal? because it's a generic... - (cond ((pair? x) (and (pair? y) - (eq? (car x) (car y)) - (equal? (cdr x) (cdr y)))) - ((null? x) (null? y)) - (else #f))) - (if (slot-ref gf 'n-specialized) - (let ((types (map-until (slot-ref gf 'n-specialized) class-of args))) - (let lp ((cache (slot-ref gf 'effective-methods))) - (cond ((null? cache) - (cache-miss gf args)) - ((equal? (vector-ref (car cache) 1) types) - (apply (vector-ref (car cache) 3) args)) - (else (lp (cdr cache)))))) - (cache-miss gf args))) - -(define (cache-miss gf args) - (apply (memoize-method! gf args) args)) +(define-syntax arity-case + (lambda (x) + (syntax-case x () + ;; (arity-case n 2 foo bar) + ;; => (case n + ;; ((0) (foo)) + ;; ((1) (foo a)) + ;; ((2) (foo a b)) + ;; (else bar)) + ((arity-case n max form alternate) + (let ((max (syntax->datum #'max))) + #`(case n + #,@(let lp ((n 0)) + (let ((ids (map (lambda (n) + (let* ((n (+ (char->integer #\a) n)) + (c (integer->char n))) + (datum->syntax #'here (symbol c)))) + (iota n)))) + #`(((#,n) (form #,@ids)) + . #,(if (< n max) + (lp (1+ n)) + #'())))) + (else alternate))))))) + +;;; +;;; These dispatchers are set as the "procedure" field of +;;; instances. Unlike CLOS, in GOOPS a generic function can have +;;; multiple arities. +;;; +;;; We pre-generate fast dispatchers for applications of up to 20 +;;; arguments. More arguments than that will go through slower generic +;;; routines that cons arguments into a rest list. +;;; +(define (multiple-arity-dispatcher fv miss) + (define-syntax dispatch + (lambda (x) + (define (build-clauses args) + (let ((len (length (syntax->datum args)))) + #`((#,args ((vector-ref fv #,len) . #,args)) + . #,(syntax-case args () + (() #'()) + ((arg ... _) (build-clauses #'(arg ...))))))) + (syntax-case x () + ((dispatch arg ...) + #`(case-lambda + #,@(build-clauses #'(arg ...)) + (args (apply miss args))))))) + (arity-case (vector-length fv) 20 dispatch + (lambda args + (let ((nargs (length args))) + (if (< nargs (vector-length fv)) + (apply (vector-ref fv nargs) args) + (apply miss args)))))) + +;;; +;;; The above multiple-arity-dispatcher is entirely sufficient, and +;;; should be fast enough. Still, for no good reason we also have an +;;; arity dispatcher for generics that are only called with one arity. +;;; +(define (single-arity-dispatcher f nargs miss) + (define-syntax-rule (dispatch arg ...) + (case-lambda + ((arg ...) (f arg ...)) + (args (apply miss args)))) + (arity-case nargs 20 dispatch + (lambda args + (if (eqv? (length args) nargs) + (apply f args) + (apply miss args))))) + +;;; +;;; The guts of generic function dispatch are here. Once we've selected +;;; an arity, we need to map from arguments to effective method. Until +;;; we have `eqv?' specializers, this map is entirely a function of the +;;; types (classes) of the arguments. So, we look in the cache to see +;;; if we have seen this set of concrete types, and if so we apply the +;;; previously computed effective method. Otherwise we miss the cache, +;;; so we'll have to compute the right answer for this set of types, add +;;; the mapping to the cache, and apply the newly computed method. +;;; +;;; The cached mapping is invalidated whenever a new method is defined +;;; on this generic, or whenever the class hierarchy of any method +;;; specializer changes. +;;; +(define (single-arity-cache-dispatch cache nargs cache-miss) + (match cache + (() cache-miss) + ((#(len types rest? cmethod nargs*) . cache) + (define (type-ref n) + (and (< n len) (list-ref types n))) + (cond + ((eqv? nargs nargs*) + (let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss))) + (define-syntax args-match? + (syntax-rules () + ((args-match?) #t) + ((args-match? (arg type) (arg* type*) ...) + ;; Check that the arg has the exact type that we saw. It + ;; could be that `type' is #f, which indicates the end of + ;; the specializers list. Once all specializers have been + ;; examined, we don't need to look at any more arguments + ;; to know that this is a cache hit. + (or (not type) + (and (eq? (class-of arg) type) + (args-match? (arg* type*) ...)))))) + (define-syntax dispatch + (lambda (x) + (define (bind-types types k) + (let lp ((types types) (n 0)) + (syntax-case types () + (() (k)) + ((type . types) + #`(let ((type (type-ref #,n))) + #,(lp #'types (1+ n))))))) + (syntax-case x () + ((dispatch arg ...) + (with-syntax (((type ...) (generate-temporaries #'(arg ...)))) + (bind-types + #'(type ...) + (lambda () + #'(lambda (arg ...) + (if (args-match? (arg type) ...) + (cmethod arg ...) + (cache-miss arg ...)))))))))) + (arity-case nargs 20 dispatch + (lambda args + (define (args-match? args) + (let lp ((args args) (types types)) + (match types + ((type . types) + (let ((arg (car args)) + (args (cdr args))) + (and (eq? type (class-of arg)) + (lp args types)))) + (_ #t)))) + (if (args-match? args) + (apply cmethod args) + (apply cache-miss args)))))) + (else + (single-arity-cache-dispatch cache nargs cache-miss)))))) + +(define (compute-generic-function-dispatch-procedure gf) + (define (seen-arities cache) + (let lp ((arities 0) (cache cache)) + (match cache + (() arities) + ((#(_ _ _ _ nargs) . cache) + (lp (logior arities (ash 1 nargs)) cache))))) + (define (cache-miss . args) + (memoize-generic-function-application! gf args) + (apply gf args)) + (let* ((cache (slot-ref gf 'effective-methods)) + (arities (seen-arities cache)) + (max-arity (let lp ((max -1)) + (if (< arities (ash 1 (1+ max))) + max + (lp (1+ max)))))) + (cond + ((= max-arity -1) + ;; Nothing in the cache. + cache-miss) + ((= arities (ash 1 max-arity)) + ;; Only one arity in the cache. + (let ((nargs (match cache ((#(_ _ _ _ nargs) . _) nargs)))) + (let ((f (single-arity-cache-dispatch cache nargs cache-miss))) + (single-arity-dispatcher f nargs cache-miss)))) + (else + ;; Multiple arities. + (let ((fv (make-vector (1+ max-arity) #f))) + (let lp ((n 0)) + (when (<= n max-arity) + (let ((f (single-arity-cache-dispatch cache n cache-miss))) + (vector-set! fv n f) + (lp (1+ n))))) + (multiple-arity-dispatcher fv cache-miss)))))) + +(define (recompute-generic-function-dispatch-procedure! gf) + (slot-set! gf 'procedure + (compute-generic-function-dispatch-procedure gf))) (define (memoize-effective-method! gf args applicable) (define (first-n ls n) @@ -1038,44 +1442,43 @@ followed by its associated value. If @var{l} does not hold a value for (parse (1+ n) (cdr ls))))) (define (memoize len rest? types) (let* ((cmethod (compute-cmethod applicable types)) - (cache (cons (vector len types rest? cmethod) + (cache (cons (vector len types rest? cmethod (length args)) (slot-ref gf 'effective-methods)))) (slot-set! gf 'effective-methods cache) - (slot-set! gf 'procedure (delayed-compile gf)) + (recompute-generic-function-dispatch-procedure! gf) cmethod)) (parse 0 args)) ;;; -;;; Compiling next methods into method bodies +;;; If a method refers to `next-method' in its body, that method will be +;;; able to dispatch to the next most specific method. The exact +;;; `next-method' implementation is only known at runtime, as it is a +;;; function of which precise argument types are being dispatched, which +;;; might be subclasses of the method's declared specializers. ;;; - -;;; So, for the reader: there basic idea is that, given that the -;;; semantics of `next-method' depend on the concrete types being -;;; dispatched, why not compile a specific procedure to handle each type -;;; combination that we see at runtime. -;;; -;;; In theory we can do much better than a bytecode compilation, because -;;; we know the *exact* types of the arguments. It's ideal for native -;;; compilation. A task for the future. +;;; Guile implements `next-method' by binding it as a closure variable. +;;; An effective method is bound to a specific `next-method' by the +;;; `make-procedure' slot of a , which returns the new closure. ;;; -;;; I think this whole generic application mess would benefit from a -;;; strict MOP. - (define (compute-cmethod methods types) - (let ((make-procedure (slot-ref (car methods) 'make-procedure))) - (if make-procedure + (match methods + ((method . methods) + (match (slot-ref method 'make-procedure) + (#f (method-procedure method)) + (make-procedure (make-procedure - (if (null? (cdr methods)) - (lambda args - (no-next-method (method-generic-function (car methods)) args)) - (compute-cmethod (cdr methods) types))) - (method-procedure (car methods))))) + (match methods + (() + (lambda args + (no-next-method (method-generic-function method) args))) + (methods + (compute-cmethod methods types))))))))) ;;; ;;; Memoization ;;; -(define (memoize-method! gf args) +(define (memoize-generic-function-application! gf args) (let ((applicable ((if (eq? gf compute-applicable-methods) %compute-applicable-methods compute-applicable-methods) @@ -1085,8 +1488,6 @@ followed by its associated value. If @var{l} does not hold a value for (else (no-applicable-method gf args))))) -(set-procedure-property! memoize-method! 'system-procedure #t) - (define no-applicable-method (make #:name 'no-applicable-method)) @@ -1135,7 +1536,7 @@ followed by its associated value. If @var{l} does not hold a value for ;; a subclass of these. (for-each (lambda (meta) - (if (and (not (member meta all-cpls)) + (when (and (not (member meta all-cpls)) (not (member meta needed-metas))) (set! needed-metas (append needed-metas (list meta))))) all-metas) @@ -1150,7 +1551,7 @@ followed by its associated value. If @var{l} does not hold a value for ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...) ;;; -;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; SLOT-DEFINITION ::= INSTANCE-OF- | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; @@ -1162,8 +1563,13 @@ followed by its associated value. If @var{l} does not hold a value for (if (memq head tail) head (find-duplicate tail))))) + (define (slot-spec->name slot-spec) + (match slot-spec + (((? symbol? name) . args) name) + ;; We can get here when redefining classes. + ((? slot? slot) (%slot-definition-name slot)))) - (let* ((name (get-keyword #:name options (make-unbound))) + (let* ((name (get-keyword #:name options *unbound*)) (supers (if (not (or-map (lambda (class) (memq (class-precedence-list class))) @@ -1176,7 +1582,7 @@ followed by its associated value. If @var{l} does not hold a value for ;; Verify that all direct slots are different and that we don't inherit ;; several time from the same class (let ((tmp1 (find-duplicate supers)) - (tmp2 (find-duplicate (map slot-definition-name slots)))) + (tmp2 (find-duplicate (map slot-spec->name slots)))) (if tmp1 (goops-error "make-class: super class ~S is duplicate in class ~S" tmp1 name)) @@ -1243,19 +1649,19 @@ followed by its associated value. If @var{l} does not hold a value for ((#:getter #:setter) #'(define-class-pre-definition (rest ...) out ... - (if (or (not (defined? 'arg)) - (not (is-a? arg ))) - (toplevel-define! - 'arg - (ensure-generic (if (defined? 'arg) arg #f) 'arg))))) + (when (or (not (defined? 'arg)) + (not (is-a? arg ))) + (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 ))) - (toplevel-define! - 'arg - (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))) + (when (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))) (else #'(define-class-pre-definition (rest ...) out ...)))) ((_ () out ...) @@ -1433,11 +1839,11 @@ followed by its associated value. If @var{l} does not hold a value for #:name (generic-function-name generic) #:extended-by (slot-ref generic 'extended-by) #:setter setter))) - (if (is-a? generic ) - (let ((gfs (slot-ref generic 'extends))) - (not-extended-by! gfs generic) - (slot-set! gws 'extends gfs) - (extended-by! gfs gws))) + (when (is-a? generic ) + (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)) @@ -1552,11 +1958,11 @@ followed by its associated value. If @var{l} does not hold a value for (syntax-rules (setter) ((_ ((setter name) . args) body ...) (begin - (if (or (not (defined? 'name)) - (not (is-a? name ))) - (toplevel-define! 'name - (ensure-accessor - (if (defined? 'name) name #f) 'name))) + (when (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) (add-method! (setter name) (method args body ...)))) ((_ (name . args) body ...) (begin @@ -1565,9 +1971,9 @@ followed by its associated value. If @var{l} does not hold a value for ;; 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 ) and see. - (if (or (not (defined? 'name)) - (not name)) - (toplevel-define! 'name (make #:name 'name))) + (when (or (not (defined? 'name)) + (not name)) + (toplevel-define! 'name (make #:name 'name))) (add-method! name (method args body ...)))))) (define-syntax method @@ -1737,8 +2143,8 @@ followed by its associated value. If @var{l} does not hold a value for (generic-function-methods gf))) (define (invalidate-method-cache! gf) - (%invalidate-method-cache! gf) (slot-set! gf 'n-specialized (calculate-n-specialized gf)) + (%invalidate-method-cache! gf) (for-each (lambda (gf) (invalidate-method-cache! gf)) (slot-ref gf 'extended-by))) @@ -1790,40 +2196,9 @@ followed by its associated value. If @var{l} does not hold a value for ;;; ;;; Slots ;;; -(define slot-definition-name car) - -(define slot-definition-options cdr) - -(define (slot-definition-allocation s) - (get-keyword #:allocation (cdr s) #:instance)) - -(define (slot-definition-getter s) - (get-keyword #:getter (cdr s) #f)) - -(define (slot-definition-setter s) - (get-keyword #:setter (cdr s) #f)) - -(define (slot-definition-accessor s) - (get-keyword #:accessor (cdr s) #f)) - -(define (slot-definition-init-value s) - ;; can be #f, so we can't use #f as non-value - (get-keyword #:init-value (cdr s) (make-unbound))) - -(define (slot-definition-init-form s) - (get-keyword #:init-form (cdr s) (make-unbound))) - -(define (slot-definition-init-thunk s) - (get-keyword #:init-thunk (cdr s) #f)) - -(define (slot-definition-init-keyword s) - (get-keyword #:init-keyword (cdr s) #f)) - -(define (class-slot-definition class slot-name) - (assq slot-name (class-slots class))) - (define (slot-init-function class slot-name) - (cadr (assq slot-name (struct-ref class class-index-getters-n-setters)))) + (%slot-definition-init-thunk (or (class-slot-definition class slot-name) + (error "slot not found" slot-name)))) (define (accessor-method-slot-definition obj) "Return the slot definition of the accessor @var{obj}." @@ -1877,6 +2252,20 @@ followed by its associated value. If @var{l} does not hold a value for (display #\> file)) (next-method)))) +(define-method (write (slot ) file) + (let ((class (class-of slot))) + (if (and (slot-bound? class 'name) + (slot-bound? slot 'name)) + (begin + (display "#<" file) + (display (class-name class) file) + (display #\space file) + (display (%slot-definition-name slot) file) + (display #\space file) + (display-address slot file) + (display #\> file)) + (next-method)))) + (define-method (write (class ) file) (let ((meta (class-of class))) (if (and (slot-bound? class 'name) @@ -2017,24 +2406,20 @@ followed by its associated value. If @var{l} does not hold a value for ;;; slot access ;;; -(define (class-slot-g-n-s class slot-name) - (let* ((this-slot (assq slot-name (struct-ref class class-index-slots))) - (getters-n-setters (struct-ref class class-index-getters-n-setters)) - (g-n-s (cddr (or (assq slot-name getters-n-setters) - (slot-missing class slot-name))))) - (if (not (memq (slot-definition-allocation this-slot) - '(#:class #:each-subclass))) - (slot-missing class slot-name)) - g-n-s)) +(define (class-slot-ref class slot-name) + (let ((slot (class-slot-definition class slot-name))) + (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass)) + (slot-missing class slot-name)) + (let ((x ((%slot-definition-slot-ref slot) #f))) + (if (unbound? x) + (slot-unbound class slot-name) + x)))) -(define (class-slot-ref class slot) - (let ((x ((car (class-slot-g-n-s class slot)) #f))) - (if (unbound? x) - (slot-unbound class slot) - x))) - -(define (class-slot-set! class slot value) - ((cadr (class-slot-g-n-s class slot)) #f value)) +(define (class-slot-set! class slot-name value) + (let ((slot (class-slot-definition class slot-name))) + (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass)) + (slot-missing class slot-name)) + ((%slot-definition-slot-set! slot) #f value))) (define-method (slot-unbound (c ) (o ) s) (goops-error "Slot `~S' is unbound in object ~S" s o)) @@ -2076,8 +2461,8 @@ followed by its associated value. If @var{l} does not hold a value for (clone (%allocate-instance class)) (slots (map slot-definition-name (class-slots class)))) (for-each (lambda (slot) - (if (slot-bound? self slot) - (slot-set! clone slot (slot-ref self slot)))) + (when (slot-bound? self slot) + (slot-set! clone slot (slot-ref self slot)))) slots) clone)) @@ -2086,12 +2471,12 @@ followed by its associated value. If @var{l} does not hold a value for (clone (%allocate-instance class)) (slots (map slot-definition-name (class-slots class)))) (for-each (lambda (slot) - (if (slot-bound? self slot) - (slot-set! clone slot - (let ((value (slot-ref self slot))) - (if (instance? value) - (deep-clone value) - value))))) + (when (slot-bound? self slot) + (slot-set! clone slot + (let ((value (slot-ref self slot))) + (if (instance? value) + (deep-clone value) + value))))) slots) clone)) @@ -2156,7 +2541,7 @@ followed by its associated value. If @var{l} does not hold a value for ;; Invalidate class so that subsequent instances slot accesses invoke ;; change-object-class (struct-set! new class-index-redefined old) - (%invalidate-class new) ;must come after slot-set! + (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set! old) @@ -2166,14 +2551,14 @@ followed by its associated value. If @var{l} does not hold a value for (define-method (remove-class-accessors! (c )) (for-each (lambda (m) - (if (is-a? m ) - (let ((gf (slot-ref m 'generic-function))) - ;; remove the method from its GF - (slot-set! gf 'methods - (delq1! m (slot-ref gf 'methods))) - (invalidate-method-cache! gf) - ;; remove the method from its specializers - (remove-method-in-classes! m)))) + (when (is-a? m ) + (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))) ;;; @@ -2186,11 +2571,10 @@ followed by its associated value. If @var{l} does not hold a value for (let loop ((l (method-specializers m))) ;; Note: the 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! @@ -2213,45 +2597,42 @@ followed by its associated value. If @var{l} does not hold a value for ;;; (define (compute-slot-accessors class slots) (for-each - (lambda (s g-n-s) - (let ((getter-function (slot-definition-getter s)) - (setter-function (slot-definition-setter s)) - (accessor (slot-definition-accessor s))) - (if getter-function - (add-method! getter-function - (compute-getter-method class g-n-s))) - (if setter-function - (add-method! setter-function - (compute-setter-method class g-n-s))) - (if accessor - (begin - (add-method! accessor - (compute-getter-method class g-n-s)) - (add-method! (setter accessor) - (compute-setter-method class g-n-s)))))) - slots (struct-ref class class-index-getters-n-setters))) - -(define-method (compute-getter-method (class ) slotdef) - (let ((init-thunk (cadr slotdef)) - (g-n-s (cddr slotdef))) + (lambda (slot) + (let ((getter (%slot-definition-getter slot)) + (setter (%slot-definition-setter slot)) + (accessor-setter setter) + (accessor (%slot-definition-accessor slot))) + (when getter + (add-method! getter (compute-getter-method class slot))) + (when setter + (add-method! setter (compute-setter-method class slot))) + (when accessor + (add-method! accessor (compute-getter-method class slot)) + (add-method! (accessor-setter accessor) + (compute-setter-method class slot))))) + slots)) + +(define-method (compute-getter-method (class ) slot) + (let ((init-thunk (slot-definition-init-thunk slot)) + (slot-ref (slot-definition-slot-ref slot)) + (index (slot-definition-index slot))) (make #:specializers (list class) - #:procedure (cond ((pair? g-n-s) - (make-generic-bound-check-getter (car g-n-s))) - (init-thunk - (standard-get g-n-s)) - (else - (bound-check-get g-n-s))) - #:slot-definition slotdef))) - -(define-method (compute-setter-method (class ) slotdef) - (let ((g-n-s (cddr slotdef))) + #:procedure (cond + (slot-ref (make-generic-bound-check-getter slot-ref)) + (init-thunk (standard-get index)) + (else (bound-check-get index))) + #:slot-definition slot))) + +(define-method (compute-setter-method (class ) slot) + (let ((slot-set! (slot-definition-slot-set! slot)) + (index (slot-definition-index slot))) (make - #:specializers (list class ) - #:procedure (if (pair? g-n-s) - (cadr g-n-s) - (standard-set g-n-s)) - #:slot-definition slotdef))) + #:specializers (list class ) + #:procedure (cond + (slot-set! slot-set!) + (else (standard-set index))) + #:slot-definition slot))) (define (make-generic-bound-check-getter proc) (lambda (o) @@ -2289,69 +2670,6 @@ followed by its associated value. If @var{l} does not hold a value for (define-standard-accessor-method ((standard-set n) o v) (struct-set! o n v)) -;;; compute-getters-n-setters -;;; -(define (compute-getters-n-setters class slots) - - (define (compute-slot-init-function name s) - (or (let ((thunk (slot-definition-init-thunk s))) - (and thunk - (if (thunk? thunk) - thunk - (goops-error "Bad init-thunk for slot `~S' in ~S: ~S" - name class thunk)))) - (let ((init (slot-definition-init-value s))) - (and (not (unbound? init)) - (lambda () init))))) - - (define (verify-accessors slot l) - (cond ((integer? l)) - ((not (and (list? l) (= (length l) 2))) - (goops-error "Bad getter and setter for slot `~S' in ~S: ~S" - slot class l)) - (else - (let ((get (car l)) - (set (cadr l))) - (if (not (procedure? get)) - (goops-error "Bad getter closure for slot `~S' in ~S: ~S" - slot class get)) - (if (not (procedure? set)) - (goops-error "Bad setter closure for slot `~S' in ~S: ~S" - slot class set)))))) - - (map (lambda (s) - ;; The strange treatment of nfields is due to backward compatibility. - (let* ((index (slot-ref class 'nfields)) - (g-n-s (compute-get-n-set class s)) - (size (- (slot-ref class 'nfields) index)) - (name (slot-definition-name s))) - ;; NOTE: The following is interdependent with C macros - ;; defined above goops.c:scm_sys_prep_layout_x. - ;; - ;; For simple instance slots, we have the simplest form - ;; '(name init-function . index) - ;; For other slots we have - ;; '(name init-function getter setter . alloc) - ;; where alloc is: - ;; '(index size) for instance allocated slots - ;; '() for other slots - (verify-accessors name g-n-s) - (case (slot-definition-allocation s) - ((#:each-subclass #:class) - (unless (and (zero? size) (pair? g-n-s)) - (error "Class-allocated slots should not reserve fields")) - ;; Don't initialize the slot; that's handled when the slot - ;; is allocated, in compute-get-n-set. - (cons name (cons #f g-n-s))) - (else - (cons name - (cons (compute-slot-init-function name s) - (if (or (integer? g-n-s) - (zero? size)) - g-n-s - (append g-n-s (list index size))))))))) - slots)) - ;;; compute-cpl ;;; @@ -2364,6 +2682,9 @@ followed by its associated value. If @var{l} does not hold a value for ;;; compute-get-n-set ;;; +(define compute-get-n-set + (make #:name 'compute-get-n-set)) + (define-method (compute-get-n-set (class ) s) (define (class-slot-init-value) (let ((thunk (slot-definition-init-thunk s))) @@ -2371,6 +2692,10 @@ followed by its associated value. If @var{l} does not hold a value for (thunk) (slot-definition-init-value s)))) + (define (make-closure-variable class value) + (list (lambda (o) value) + (lambda (o v) (set! value v)))) + (case (slot-definition-allocation s) ((#:instance) ;; Instance slot ;; get-n-set is just its offset @@ -2378,7 +2703,7 @@ followed by its associated value. If @var{l} does not hold a value for (struct-set! class class-index-nfields (+ already-allocated 1)) already-allocated)) - ((#:class) ;; Class slot + ((#:class) ;; Class slot ;; Class-slots accessors are implemented as 2 closures around ;; a Scheme variable. As instance slots, class slots must be ;; unbound at init time. @@ -2387,13 +2712,16 @@ followed by its associated value. If @var{l} does not hold a value for ;; This slot is direct; create a new shared variable (make-closure-variable class (class-slot-init-value)) ;; Slot is inherited. Find its definition in superclass - (let loop ((l (cdr (class-precedence-list class)))) - (let ((r (assoc name - (struct-ref (car l) - class-index-getters-n-setters)))) - (if r - (cddr r) - (loop (cdr l)))))))) + (let lp ((cpl (cdr (class-precedence-list class)))) + (match cpl + ((super . cpl) + (let ((s (class-slot-definition super name))) + (if s + (list (slot-definition-slot-ref s) + (slot-definition-slot-set! s)) + ;; Multiple inheritance means that we might have + ;; to look deeper in the CPL. + (lp cpl))))))))) ((#:each-subclass) ;; slot shared by instances of direct subclass. ;; (Thomas Buerger, April 1998) @@ -2403,16 +2731,11 @@ followed by its associated value. If @var{l} does not hold a value for ;; slot-ref and slot-set! function must be given by the user (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f)) (set (get-keyword #:slot-set! (slot-definition-options s) #f))) - (if (not (and get set)) - (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" - s)) + (unless (and get set) + (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" s)) (list get set))) (else (next-method)))) -(define (make-closure-variable class value) - (list (lambda (o) value) - (lambda (o v) (set! value v)))) - (define-method (compute-get-n-set (o ) s) (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) @@ -2424,71 +2747,109 @@ followed by its associated value. If @var{l} does not hold a value for ;;; {Initialize} ;;; -(define *unbound* (make-unbound)) - ;; FIXME: This could be much more efficient. (define (%initialize-object obj initargs) "Initialize the object @var{obj} with the given arguments var{initargs}." + (define (valid-initargs? initargs) + (match initargs + (() #t) + (((? keyword?) _ . initargs) (valid-initargs? initargs)) + (_ #f))) (unless (instance? obj) (scm-error 'wrong-type-arg #f "Not an object: ~S" (list obj) #f)) - (unless (even? (length initargs)) - (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S" + (unless (valid-initargs? initargs) + (scm-error 'wrong-type-arg #f "Invalid initargs: ~S" (list initargs) #f)) (let ((class (class-of obj))) (define (get-initarg kw) (if kw - (get-keyword kw initargs *unbound*) + ;; Inlined get-keyword to avoid checking initargs for validity + ;; each time. + (let lp ((initargs initargs)) + (match initargs + ((kw* val . initargs) + (if (eq? kw* kw) + val + (lp initargs))) + (_ *unbound*))) *unbound*)) - (let lp ((get-n-set (struct-ref class class-index-getters-n-setters)) - (slots (struct-ref class class-index-slots))) + (let lp ((slots (struct-ref class class-index-slots))) (match slots (() obj) - (((name . options) . slots) - (match get-n-set - (((_ init-thunk . _) . get-n-set) - (let ((initarg (get-initarg (get-keyword #:init-keyword options)))) - (cond - ((not (unbound? initarg)) - (slot-set! obj name initarg)) - (init-thunk - (slot-set! obj name (init-thunk))))) - (lp get-n-set slots)))))))) + ((slot . slots) + (define (initialize-slot! value) + (cond + ((%slot-definition-slot-set! slot) + => (lambda (slot-set!) (slot-set! obj value))) + (else + (struct-set! obj (%slot-definition-index slot) value)))) + (let ((initarg (get-initarg (%slot-definition-init-keyword slot)))) + (cond + ((not (unbound? initarg)) + (initialize-slot! initarg)) + ((%slot-definition-init-thunk slot) + => (lambda (init-thunk) + (unless (memq (slot-definition-allocation slot) + '(#:class #:each-subclass)) + (initialize-slot! (init-thunk))))))) + (lp slots)))))) (define-method (initialize (object ) initargs) (%initialize-object object initargs)) +(define-method (initialize (slot ) initargs) + (next-method) + (struct-set! slot slot-index-options initargs) + (let ((init-thunk (%slot-definition-init-thunk slot))) + (when init-thunk + (unless (thunk? init-thunk) + (goops-error "Bad init-thunk for slot `~S': ~S" + (%slot-definition-name slot) init-thunk))))) + (define-method (initialize (class ) initargs) + (define (make-direct-slot-definition dslot) + (let ((initargs (compute-direct-slot-definition-initargs class dslot))) + (compute-direct-slot-definition class initargs))) + (next-method) - (let ((dslots (get-keyword #:slots initargs '())) - (supers (get-keyword #:dsupers initargs '()))) - (let ((name (get-keyword #:name initargs '???))) - (struct-set! class class-index-name name)) - (struct-set! class class-index-nfields 0) - (struct-set! class class-index-direct-supers supers) - (struct-set! class class-index-direct-slots dslots) - (struct-set! class class-index-direct-subclasses '()) - (struct-set! class class-index-direct-methods '()) - (struct-set! class class-index-cpl (compute-cpl class)) - (struct-set! class class-index-redefined #f) - (let ((slots (compute-slots class))) - (struct-set! class class-index-slots slots) - (let ((getters-n-setters (compute-getters-n-setters class slots))) - (struct-set! class class-index-getters-n-setters getters-n-setters)) - ;; Build getters - setters - accessors - (compute-slot-accessors class slots)) - - ;; Update the "direct-subclasses" of each inherited classes - (for-each (lambda (x) - (let ((dsubs (struct-ref x class-index-direct-subclasses))) - (struct-set! x class-index-direct-subclasses - (cons class dsubs)))) - supers) - - ;; Compute struct layout of instances, set the `layout' slot, and - ;; update class flags. - (%prep-layout! class))) + (class-add-flags! class (logior vtable-flag-goops-class + vtable-flag-goops-valid)) + (struct-set! class class-index-name (get-keyword #:name initargs '???)) + (struct-set! class class-index-nfields 0) + (struct-set! class class-index-direct-supers + (get-keyword #:dsupers initargs '())) + (struct-set! class class-index-direct-subclasses '()) + (struct-set! class class-index-direct-methods '()) + (struct-set! class class-index-redefined #f) + (struct-set! class class-index-cpl (compute-cpl class)) + (struct-set! class class-index-direct-slots + (map (lambda (slot) + (if (slot? slot) + slot + (make-direct-slot-definition slot))) + (get-keyword #:slots initargs '()))) + (struct-set! class class-index-slots + (allocate-slots class (compute-slots class))) + + ;; This is a hack. + (when (memq (struct-ref class class-index-cpl)) + (class-add-flags! class vtable-flag-goops-slot)) + + ;; Build getters - setters - accessors + (compute-slot-accessors class (struct-ref class class-index-slots)) + + ;; Update the "direct-subclasses" of each inherited classes + (for-each (lambda (x) + (let ((dsubs (struct-ref x class-index-direct-subclasses))) + (struct-set! x class-index-direct-subclasses + (cons class dsubs)))) + (struct-ref class class-index-direct-supers)) + + ;; Compute struct layout of instances, set the `layout' slot, and + ;; update class flags. + (%prep-layout! class)) (define (initialize-object-procedure object initargs) (let ((proc (get-keyword #:procedure initargs #f))) @@ -2543,27 +2904,20 @@ var{initargs}." (define (change-object-class old-instance old-class new-class) (let ((new-instance (allocate-instance new-class '()))) ;; Initialize the slots of the new instance - (for-each (lambda (slot) - (if (and (slot-exists-using-class? old-class old-instance slot) - (eq? (slot-definition-allocation - (class-slot-definition old-class slot)) - #:instance) - (slot-bound-using-class? old-class old-instance slot)) - ;; Slot was present and allocated in old instance; copy it - (slot-set-using-class! - new-class - new-instance - slot - (slot-ref-using-class old-class old-instance slot)) - ;; slot was absent; initialize it with its default value - (let ((init (slot-init-function new-class slot))) - (if init - (slot-set-using-class! - new-class - new-instance - slot - (apply init '())))))) - (map slot-definition-name (class-slots new-class))) + (for-each + (lambda (slot) + (if (and (slot-exists? old-instance slot) + (eq? (%slot-definition-allocation + (class-slot-definition old-class slot)) + #:instance) + (slot-bound? old-instance slot)) + ;; Slot was present and allocated in old instance; copy it + (slot-set! new-instance slot (slot-ref old-instance slot)) + ;; slot was absent; initialize it with its default value + (let ((init (slot-init-function new-class slot))) + (when init + (slot-set! new-instance slot (init)))))) + (map slot-definition-name (class-slots new-class))) ;; Exchange old and new instance in place to keep pointers valid (%modify-instance old-instance new-instance) ;; Allow class specific updates of instances (which now are swapped) @@ -2605,11 +2959,12 @@ var{initargs}." ;;; ;;; 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 :) +;;; `dispatch-generic-function-application-from-cache' routine +;;; implements this. `apply-generic' isn't called currently; the +;;; generic function MOP was never fully implemented in GOOPS. However +;;; now that GOOPS is implemented entirely in Scheme (2015) it's much +;;; easier to complete this work. Contributions gladly accepted! +;;; Please read the AMOP first though :) ;;; ;;; The protocol is: ;;; @@ -2626,8 +2981,8 @@ var{initargs}." ;;; (define-method (apply-generic (gf ) 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)