X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/5bc7c6dbab302c8ac991dfd2c3b254ff3524ba65..f15c0f545be3dd4b1da92824b1bf782e3571b4a6:/module/oop/goops.scm diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 0376d9eb0..1babb09f8 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;; 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 ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -26,6 +26,10 @@ (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 @@ -48,8 +52,8 @@ ;; Applicable structs. - - + + @@ -58,6 +62,7 @@ + ;; Numbers. @@ -71,7 +76,7 @@ ;; smob-type-name->class procedure. - + ;; Modules. @@ -93,14 +98,14 @@ 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 @@ -116,8 +121,7 @@ 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? @@ -132,31 +136,1105 @@ 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)) + + +;;; +;;; We then define the slots that must appear in all classes ( +;;; 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) + ((_ 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 ) + (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)))))) + +;;; +;;; 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 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 ) tail) + (string-append "pr" tail)) + ((_ (name ) tail) + (string-append "sr" tail)) + ((_ (name ) tail) + (string-append "uh" tail)) + ((_ (name ) 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 '())) + ( (%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 (length slots)) + (struct-set! class-index-direct-supers '()) + (struct-set! class-index-direct-slots slots) + (struct-set! class-index-direct-subclasses '()) + (struct-set! class-index-direct-methods '()) + (struct-set! class-index-cpl '()) + (struct-set! class-index-slots slots) + (struct-set! class-index-getters-n-setters '()) + (struct-set! class-index-redefined #f) + ))) + +;;; +;;; Accessors to fields of . +;;; +(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?)) + + + + +;;; +;;; 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-index-getters-n-setters + (%compute-getters-n-setters (class-slots ))) + + + + +;;; +;;; At this point, we have 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 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 cpl) + (struct-ref 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 ) + ;; 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 )) + (values (cond + ((subclass? type ) #\s) + ((subclass? type ) #\p) + (else #\u)) + (cond + ((subclass? type ) #\o) + ((subclass? type ) #\r) + ((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 + (() + (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)))))))))) + + + + +;;; +;;; 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?))) + (%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 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 )) +(struct-set! class-index-direct-supers (list )) +(struct-set! class-index-cpl (list )) + + + + +;;; +;;; We can also define the various slot types, and finish initializing +;;; `direct-slots', `slots', and `getters-n-setters' of . +;;; +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ( + )) +(define-standard-class ( + )) +(define-standard-class ( + )) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) + +(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-index-direct-slots dslots) + (struct-set! class-index-slots dslots) + (struct-set! class-index-getters-n-setters g-n-s))) + + + + +;;; +;;; Now, to build out the class hierarchy. +;;; + +(define-standard-class ()) + +(define-standard-class + ()) +(class-add-flags! + vtable-flag-applicable-vtable) + +(define-standard-class + ()) +(class-add-flags! + vtable-flag-setter-vtable) + +(define-standard-class ()) +(define-standard-class ( ) + #:metaclass + procedure) +(define-standard-class () + #:metaclass + setter) +(define-standard-class () + #:metaclass + methods + (n-specialized #:init-value 0) + (extended-by #:init-value ()) + effective-methods) +(define-standard-class () + #:metaclass + (extends #:init-value ())) +(define-standard-class ( + ) + #:metaclass ) +(define-standard-class () + #:metaclass ) +(define-standard-class ( + ) + #:metaclass ) +(define-standard-class ( + ) + #:metaclass ) + +(define-standard-class () + generic-function + specializers + procedure + formals + body + make-procedure) +(define-standard-class () + (slot-definition #:init-keyword #:slot-definition)) + +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class () + #:metaclass ) +(define-standard-class () + #:metaclass ) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ( )) + +(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 (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 )) + (struct-set! class class-index-cpl (compute-cpl class)) + (let ((subclasses (struct-ref class-index-direct-subclasses))) + (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 '())) + +;; 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 ) (eq? class )) + (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 ) + (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 ) (eq? class )) + (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-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)) + + + + +;;; +;;; 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 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)) + + + + +;;; +;;; Method accessors. +;;; +(define (method-generic-function obj) + "Return the generic function for the method @var{obj}." + (unless (is-a? obj ) + (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 ) + (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 ) + (scm-error 'wrong-type-arg #f "Not a method: ~S" + (list obj) #f)) + (slot-ref obj 'procedure)) + + + + +;;; +;;; 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 #:name 'no-applicable-method)) + +(%goops-early-init) ;; Then load the rest of GOOPS -(use-modules (oop goops util) - (oop goops dispatch) - (oop goops compile)) ;; 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 @@ -164,13 +1242,6 @@ (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} ;;; @@ -179,36 +1250,36 @@ (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 #: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 #: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) (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} @@ -220,21 +1291,15 @@ ;;; 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 @@ -259,7 +1324,7 @@ ;; Everything seems correct, build the class (apply make metaclass #:dsupers supers - #:slots slots + #:slots slots #:name name options))) @@ -268,35 +1333,43 @@ ;;; 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) @@ -307,24 +1380,24 @@ ((#: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 ...) #'(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 @@ -342,7 +1415,7 @@ #'(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 ...) @@ -354,7 +1427,7 @@ (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 ...)) @@ -365,72 +1438,79 @@ ;; 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 )) - (make #: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 )) + (make #: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 #:name name)) (define* (make-extended-generic gfs #:optional name) (let* ((gfs (if (list? gfs) gfs (list gfs))) - (gws? (any (lambda (gf) (is-a? gf )) gfs))) + (gws? (any (lambda (gf) (is-a? gf )) gfs))) (let ((ans (if gws? - (let* ((sname (and name (make-setter-name name))) - (setters - (append-map (lambda (gf) - (if (is-a? gf ) - (list (ensure-generic (setter gf) - sname)) - '())) - gfs)) - (es (make - #:name name - #:extends gfs - #:setter (make - #:name sname - #:extends setters)))) - (extended-by! setters (setter es)) - es) - (make - #:name name - #:extends gfs)))) + (let* ((sname (and name (make-setter-name name))) + (setters + (append-map (lambda (gf) + (if (is-a? gf ) + (list (ensure-generic (setter gf) + sname)) + '())) + gfs)) + (es (make + #:name name + #:extends gfs + #:setter (make + #:name sname + #:extends setters)))) + (extended-by! setters (setter es)) + es) + (make + #: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) @@ -484,21 +1564,21 @@ (define (upgrade-accessor generic setter) (let ((methods (slot-ref generic 'methods)) - (gws (make (if (is-a? generic ) - - ) - #: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))) + (gws (make (if (is-a? generic ) + + ) + #:name (generic-function-name generic) + #:extended-by (slot-ref generic 'extended-by) + #:setter setter))) + (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)) - methods) + (slot-set! method 'generic-function gws)) + methods) (slot-set! gws 'methods methods) (invalidate-method-cache! gws) gws)) @@ -507,6 +1587,101 @@ ;;; {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 ) + (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 ) + (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)) @@ -514,11 +1689,11 @@ (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 @@ -527,9 +1702,9 @@ ;; 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 @@ -631,6 +1806,31 @@ #: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!} ;;; @@ -638,32 +1838,32 @@ (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))) @@ -694,8 +1894,8 @@ (define-method (add-method! (proc ) (m )) (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 ) (m )) @@ -713,7 +1913,7 @@ ;;; (define-method (method-source (m )) (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))) @@ -760,7 +1960,7 @@ (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}." @@ -781,7 +1981,7 @@ ;; 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?) ;;; @@ -789,7 +1989,7 @@ ;;; ; 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 @@ -806,66 +2006,66 @@ (define-method (write (o ) 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 ) 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 ) 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 ) 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)) ;;; @@ -887,65 +2087,65 @@ (define (find-subclass ')) (define-method (merge-generics (module ) - (name ) - (int1 ) - (val1 ) - (int2 ) - (val2 ) - (var ) - (val )) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (val )) #f) (define-method (merge-generics (module ) - (name ) - (int1 ) - (val1 ) - (int2 ) - (val2 ) - (var ) - (val )) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (val )) (and (not (eq? val1 val2)) (make-variable (make-extended-generic (list val2 val1) name)))) (define-method (merge-generics (module ) - (name ) - (int1 ) - (val1 ) - (int2 ) - (val2 ) - (var ) - (gf )) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (gf )) (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 ) - (name ) - (int1 ) - (val1 ) - (int2 ) - (val2 ) - (var ) - (val )) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (val )) #f) (define-method (merge-accessors (module ) - (name ) - (int1 ) - (val1 ) - (int2 ) - (val2 ) - (var ) - (val )) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (val )) (merge-generics module name int1 val1 int2 val2 var val)) (module-define! duplicate-handlers 'merge-accessors merge-accessors) @@ -955,19 +2155,20 @@ ;;; (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)) @@ -983,10 +2184,10 @@ (define-method (slot-missing (c ) (o ) s) (goops-error "No slot with name `~S' in object ~S" s o)) - + (define-method (slot-missing (c ) s) (goops-error "No class slot with name `~S' in class ~S" s c)) - + (define-method (slot-missing (c ) (o ) s value) (slot-missing c o s)) @@ -998,7 +2199,7 @@ (define-method (no-applicable-method (gf ) 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 ) args) (goops-error "No method defined for ~S" gf)) @@ -1008,27 +2209,27 @@ ;;; (define-method (shallow-clone (self )) - (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 )) - (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)) ;;; @@ -1041,42 +2242,42 @@ ;;; 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 ) (new )) ;; 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) @@ -1084,15 +2285,15 @@ ;; 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) @@ -1102,44 +2303,43 @@ (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)))) - (class-direct-methods c))) + (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))) ;;; ;;; update-direct-method! ;;; (define-method (update-direct-method! (m ) - (old ) - (new )) + (old ) + (new )) (let loop ((l (method-specializers m))) - ;; Note: the in dotted list is never used. + ;; 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! ;;; (define-method (update-direct-subclass! (c ) - (old ) - (new )) + (old ) + (new )) (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} @@ -1150,47 +2350,51 @@ (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 ) slotdef) (let ((init-thunk (cadr slotdef)) - (g-n-s (cddr slotdef))) + (g-n-s (cddr slotdef))) (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))) + #: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))) (make #:specializers (list class ) - #: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 @@ -1227,318 +2431,230 @@ (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 #:name 'compute-cpl)) (define-method (compute-cpl (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 . -;; - -(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 ) 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 ) s) (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) (define-method (compute-slots (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 ) initargs) (%initialize-object object initargs)) (define-method (initialize (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 ) initargs) (next-method) (initialize-object-procedure applicable-struct initargs)) +(define-method (initialize (applicable-struct ) + initargs) + (next-method) + (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f))) + (define-method (initialize (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 ) - (list (method args + (list (method args (apply previous-definition args))) - '())) + '())) (if name - (set-procedure-property! generic 'name name)) - )) - -(define-method (initialize (gws ) 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 ) initargs) (next-method) @@ -1551,11 +2667,11 @@ (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} @@ -1565,26 +2681,26 @@ (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) @@ -1593,8 +2709,8 @@ (define-method (update-instance-for-different-class (old-instance ) - (new-instance - )) + (new-instance + )) ;;not really important what we do, we just need a default method new-instance) @@ -1608,7 +2724,7 @@ ;;; (define-method (allocate-instance (class ) initargs) - (%allocate-instance class initargs)) + (%allocate-instance class)) (define-method (make-instance (class ) . initargs) (let ((instance (allocate-instance class initargs))) @@ -1620,24 +2736,39 @@ ;;; ;;; {apply-generic} ;;; -;;; Protocol for calling standard generic functions. This protocol is -;;; not used for real functions (in this case we use a -;;; completely C hard-coded protocol). Apply-generic is used by -;;; goops for calls to subclasses of and . -;;; 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 and . 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 ) 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 @@ -1650,70 +2781,34 @@ (set! compute-applicable-methods %%compute-applicable-methods) (define-method (sort-applicable-methods (gf ) 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 ) (m2 ) targs) (%method-more-specific? m1 m2 targs)) (define-method (apply-method (gf ) 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 ) (l ) 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 - )) - -;;; -;;; { and } -;;; - -;(autoload "active-slot" ) -;(autoload "composite-slot" ) -;(export ) - -;;; -;;; {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} @@ -1740,7 +2835,6 @@ (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass '))