X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/984d43b632597e02909843398aacc1f02d501bc5..3f4829e082c2fdd0553a6ce97fe173f8df327e7b:/module/oop/goops.scm diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 5068d14b0..172839a91 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,8 +27,9 @@ (define-module (oop goops) #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:use-module (oop goops util) #:use-module (system base target) + #:use-module ((language tree-il primitives) + :select (add-interesting-primitive!)) #:export-syntax (define-class class standard-define-class define-generic define-accessor define-method define-extended-generic define-extended-generics @@ -97,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 @@ -120,11 +121,9 @@ 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? + + 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,45 +132,453 @@ method-specializers method-formals primitive-generic-generic enable-primitive-generic! method-procedure accessor-method-slot-definition - slot-exists? make find-method get-keyword) - #:no-backtrace) + make find-method get-keyword)) -;; XXX FIXME: figure out why the 'eval-when's in this file must use -;; 'compile' and must avoid 'expand', but only in 2.2, and only when -;; compiling something that imports goops, e.g. (ice-9 occam-channel), -;; before (oop goops) itself has been compiled. -;; First initialize the builtin part of GOOPS -(eval-when (compile load eval) +;;; +;;; Booting GOOPS is a tortuous process. We begin by loading a small +;;; set of primitives from C. +;;; +(eval-when (expand load eval) (load-extension (string-append "libguile-" (effective-version)) - "scm_init_goops_builtins")) - -(eval-when (compile load eval) - (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) + "scm_init_goops_builtins") (add-interesting-primitive! 'class-of)) -;;; The standard class precedence list computation algorithm + + + ;;; -;;; Correct behaviour: +;;; 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-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-syntax macro-fold-left + (syntax-rules () + ((_ folder seed ()) seed) + ((_ folder seed (head . tail)) + (macro-fold-left folder (folder head seed) tail)))) + +(define-syntax macro-fold-right + (syntax-rules () + ((_ folder seed ()) seed) + ((_ folder seed (head . tail)) + (folder head (macro-fold-right folder seed tail))))) + +(define-syntax-rule (define-macro-folder macro-folder value ...) + (define-syntax macro-folder + (lambda (x) + (syntax-case x () + ((_ fold visit seed) + ;; The datum->syntax makes it as if each `value' were present + ;; in the initial form, which allows them to be used as + ;; (components of) introduced identifiers. + #`(fold visit seed #,(datum->syntax #'visit '(value ...)))))))) + +(define-macro-folder fold-class-slots + (layout #:class ) + (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-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 +(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 + (let ((val obj)) + (unless (class? val) + (scm-error 'wrong-type-arg #f "Not a class: ~S" + (list val) #f)) + (struct-ref val field)))) + +(define-class-accessor class-name + "Return the class name of @var{obj}." + class-index-name) +(define-class-accessor class-direct-supers + "Return the direct superclasses of the class @var{obj}." + class-index-direct-supers) +(define-class-accessor class-direct-slots + "Return the direct slots of the class @var{obj}." + class-index-direct-slots) +(define-class-accessor class-direct-subclasses + "Return the direct subclasses of the class @var{obj}." + class-index-direct-subclasses) +(define-class-accessor class-direct-methods + "Return the direct methods of the class @var{obj}." + class-index-direct-methods) +(define-class-accessor class-precedence-list + "Return the class precedence list of the class @var{obj}." + class-index-cpl) +(define-class-accessor class-slots + "Return the slot list of the class @var{obj}." + class-index-slots) + +(define (class-subclasses c) + "Compute a list of all subclasses of @var{c}, direct and indirect." + (define (all-subclasses c) + (cons c (append-map all-subclasses + (class-direct-subclasses c)))) + (delete-duplicates (cdr (all-subclasses c)) eq?)) + +(define (class-methods c) + "Compute a list of all methods that specialize on @var{c} or +subclasses of @var{c}." + (delete-duplicates (append-map class-direct-methods + (cons c (class-subclasses c))) + eq?)) + +(define (is-a? obj class) + "Return @code{#t} if @var{obj} is an instance of @var{class}, or +@code{#f} otherwise." + (and (memq class (class-precedence-list (class-of obj))) #t)) + + + + ;;; +;;; At this point, 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) (filter (lambda (l) (not (null? l))) lst)) @@ -189,8 +596,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) @@ -203,106 +610,109 @@ c-direct-supers) (list c-direct-supers)))))) -;; Bootstrap version. +;; This version of compute-cpl is replaced with a generic function once +;; GOOPS has booted. (define (compute-cpl class) (compute-std-cpl class class-direct-supers)) -;; During boot, the specialized slot classes aren't defined yet, so we -;; initialize with unspecialized slots. -(define-syntax-rule (build--slots specialized?) - (let-syntax ((unspecialized-slot (syntax-rules () - ((_ name) (list 'name)))) - (specialized-slot (syntax-rules () - ((_ name class) - (if specialized? - (list 'name #:class class) - (list 'name)))))) - (list (specialized-slot layout ) - (specialized-slot flags ) - (specialized-slot self ) - (specialized-slot instance-finalizer ) - (unspecialized-slot print) - (specialized-slot name ) - (specialized-slot reserved-0 ) - (specialized-slot reserved-1 ) - (unspecialized-slot redefined) - (unspecialized-slot direct-supers) - (unspecialized-slot direct-slots) - (unspecialized-slot direct-subclasses) - (unspecialized-slot direct-methods) - (unspecialized-slot cpl) - (unspecialized-slot slots) - (unspecialized-slot getters-n-setters) - (unspecialized-slot nfields)))) +(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) (slot-ref '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 (slot-ref head '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) @@ -314,75 +724,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 (symbol->string (slot-ref 'layout)))) - (unless (string-prefix? class-layout layout) + (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 (slot-ref class 'cpl)) #t)) - (layout (%compute-layout (slot-ref class 'slots) - (slot-ref class 'getters-n-setters) - (slot-ref class 'nfields) + (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-nfields) is-class?))) (%init-layout! class layout))) (define (make-standard-class class name dsupers dslots) (let ((z (make-struct/no-tail class))) - (slot-set! z '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))) - (slot-set! z 'name name) - (slot-set! z 'direct-slots dslots) - (slot-set! z 'direct-subclasses '()) - (slot-set! z 'direct-methods '()) - (slot-set! z 'cpl cpl) - (slot-set! z 'slots slots) - (slot-set! z 'nfields nfields) - (slot-set! z 'getters-n-setters g-n-s) - (slot-set! z 'redefined #f) - (for-each (lambda (super) - (let ((subclasses (slot-ref super 'direct-subclasses))) - (slot-set! super 'direct-subclasses (cons z subclasses)))) - dsupers) - (%prep-layout! z) - (%inherit-magic! z dsupers) - z))) - -(define - (let ((dslots (build--slots #f))) - (%make-root-class ' dslots (%compute-getters-n-setters dslots)))) + (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) + (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) + (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 () @@ -392,16 +797,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. -(slot-set! 'direct-subclasses (list )) -(slot-set! 'direct-supers (list )) -(slot-set! 'cpl (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 ()) @@ -418,20 +840,52 @@ (define-standard-class ()) (define-standard-class ()) -;; Finish initialization of . -(let ((dslots (build--slots #t))) - (slot-set! 'direct-slots dslots) - (slot-set! 'slots dslots) - (slot-set! 'getters-n-setters (%compute-getters-n-setters dslots))) -;; 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 ( ) @@ -446,28 +900,21 @@ (n-specialized #:init-value 0) (extended-by #:init-value ()) effective-methods) -(%bless-pure-generic-vtable! ) (define-standard-class () #:metaclass (extends #:init-value ())) -(%bless-pure-generic-vtable! ) (define-standard-class ( ) #:metaclass ) -(%bless-pure-generic-vtable! ) (define-standard-class () #:metaclass ) -(%bless-pure-generic-vtable! ) (define-standard-class ( ) #:metaclass ) -(%bless-pure-generic-vtable! ) (define-standard-class ( ) #:metaclass ) -(%bless-pure-generic-vtable! ) -;; Methods (define-standard-class () generic-function specializers @@ -478,7 +925,6 @@ (define-standard-class () (slot-definition #:init-keyword #:slot-definition)) -;; Primitive types classes (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) @@ -513,6 +959,44 @@ (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 '())) @@ -521,12 +1005,6 @@ (define (invalidate-method-cache! gf) (%invalidate-method-cache! gf)) -;; A simple make which will be redefined later. This version handles -;; only creation of gf, methods and classes (no instances). -;; -;; Since this code will disappear when Goops will be fully booted, -;; no precaution is taken to be efficient. -;; (define (make class . args) (cond ((or (eq? class ) (eq? class )) @@ -539,7 +1017,7 @@ (slot-set! z 'setter setter)))) z)) (else - (let ((z (%allocate-instance class args))) + (let ((z (%allocate-instance class))) (cond ((or (eq? class ) (eq? class )) (for-each (match-lambda @@ -552,17 +1030,190 @@ (#: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)))) + + + +;;; +;;; 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}." + (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}." + (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}." + (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}." + (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 ) + (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)) ;;; @@ -609,101 +1260,94 @@ ,(if rest? `(cons* ,@args rest) `(list ,@args))))) - (cond - ((null? methods) + (match 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)))))))))))) + ((#(_ 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)) - (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))))) + (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)) - (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))))))) + (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)) - (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)))))) + (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)) - (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)))))))) + (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)) @@ -824,13 +1468,13 @@ (define (memoize-method! gf args) (let ((applicable ((if (eq? gf compute-applicable-methods) - %compute-applicable-methods - compute-applicable-methods) - gf args))) + %compute-applicable-methods + compute-applicable-methods) + gf args))) (cond (applicable (memoize-effective-method! gf args applicable)) - (else - (no-applicable-method gf args))))) + (else + (no-applicable-method gf args))))) (set-procedure-property! memoize-method! 'system-procedure #t) @@ -852,13 +1496,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} ;;; @@ -867,36 +1504,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} @@ -904,12 +1541,25 @@ ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...) ;;; -;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; SLOT-DEFINITION ::= INSTANCE-OF- | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; (define (make-class supers slots . options) - (let* ((name (get-keyword #:name options (make-unbound))) + (define (find-duplicate l) + (match l + (() #f) + ((head . tail) + (if (memq head tail) + head + (find-duplicate tail))))) + (define (slot-spec->name slot-spec) + (match slot-spec + (((? symbol? name) . args) name) + ;; We can get here when redefining classes. + ((? slot? slot) (%slot-definition-name slot)))) + + (let* ((name (get-keyword #:name options *unbound*)) (supers (if (not (or-map (lambda (class) (memq (class-precedence-list class))) @@ -922,7 +1572,7 @@ ;; 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)) @@ -933,7 +1583,7 @@ ;; Everything seems correct, build the class (apply make metaclass #:dsupers supers - #:slots slots + #:slots slots #:name name options))) @@ -989,24 +1639,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 @@ -1024,7 +1674,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 ...) @@ -1036,7 +1686,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 ...)) @@ -1084,42 +1734,42 @@ (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) @@ -1173,21 +1823,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)) @@ -1206,9 +1856,9 @@ ;; ;; (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)) @@ -1242,6 +1892,30 @@ (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)) @@ -1274,11 +1948,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 @@ -1287,9 +1961,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 @@ -1391,6 +2065,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!} ;;; @@ -1398,32 +2097,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))) @@ -1454,8 +2153,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 )) @@ -1473,7 +2172,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))) @@ -1487,40 +2186,9 @@ ;;; ;;; 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 (slot-ref class '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}." @@ -1541,7 +2209,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?) ;;; @@ -1549,7 +2217,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 @@ -1566,66 +2234,80 @@ (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 (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) - (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)) ;;; @@ -1647,65 +2329,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) @@ -1714,23 +2396,20 @@ ;;; slot access ;;; -(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)) - 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))) +(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-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)) @@ -1743,10 +2422,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)) @@ -1758,7 +2437,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)) @@ -1768,27 +2447,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)) ;;; @@ -1801,42 +2480,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) @@ -1844,15 +2523,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) @@ -1862,44 +2541,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} @@ -1909,45 +2587,42 @@ ;;; (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))) - -(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) @@ -1985,69 +2660,6 @@ (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 ;;; @@ -2060,6 +2672,9 @@ ;;; 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))) @@ -2067,27 +2682,36 @@ (thunk) (slot-definition-init-value s)))) + (define (make-closure-variable class value) + (list (lambda (o) value) + (lambda (o v) (set! value v)))) + (case (slot-definition-allocation s) ((#:instance) ;; Instance slot ;; get-n-set is just its offset - (let ((already-allocated (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) ;; Class slot + ;; Class-slots accessors are implemented as 2 closures around ;; a Scheme variable. As instance slots, class slots must be ;; unbound at init time. (let ((name (slot-definition-name s))) (if (memq name (map slot-definition-name (class-direct-slots class))) - ;; This slot is direct; create a new shared variable - (make-closure-variable class (class-slot-init-value)) - ;; Slot is inherited. Find its definition in superclass - (let 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 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) @@ -2096,17 +2720,12 @@ ((#: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 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))) @@ -2118,48 +2737,116 @@ ;;; {Initialize} ;;; +;; FIXME: This could be much more efficient. +(define (%initialize-object obj initargs) + "Initialize the object @var{obj} with the given arguments +var{initargs}." + (define (valid-initargs? initargs) + (match initargs + (() #t) + (((? keyword?) _ . initargs) (valid-initargs? initargs)) + (_ #f))) + (unless (instance? obj) + (scm-error 'wrong-type-arg #f "Not an object: ~S" + (list obj) #f)) + (unless (valid-initargs? initargs) + (scm-error 'wrong-type-arg #f "Invalid initargs: ~S" + (list initargs) #f)) + (let ((class (class-of obj))) + (define (get-initarg kw) + (if kw + ;; Inlined get-keyword to avoid checking initargs for validity + ;; each time. + (let lp ((initargs initargs)) + (match initargs + ((kw* val . initargs) + (if (eq? kw* kw) + val + (lp initargs))) + (_ *unbound*))) + *unbound*)) + (let lp ((slots (struct-ref class class-index-slots))) + (match slots + (() obj) + ((slot . slots) + (define (initialize-slot! value) + (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 '()))) - (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) - (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)) - ;; 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))) + (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))) (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) @@ -2173,14 +2860,14 @@ (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)) + (set-procedure-property! generic 'name name)) (invalidate-method-cache! generic))) (define-method (initialize (eg ) initargs) @@ -2194,11 +2881,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} @@ -2207,27 +2894,20 @@ (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) @@ -2236,8 +2916,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) @@ -2251,7 +2931,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))) @@ -2263,24 +2943,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 @@ -2300,62 +2995,27 @@ (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}