X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/12b8487d5d7272ae5bda62477df60d3e795aa645..3f4829e082c2fdd0553a6ce97fe173f8df327e7b:/module/oop/goops.scm diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 0376d9eb0..172839a91 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. +;;;; 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 @@ -26,6 +26,10 @@ (define-module (oop goops) #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (system base target) + #:use-module ((language tree-il primitives) + :select (add-interesting-primitive!)) #:export-syntax (define-class class standard-define-class define-generic define-accessor define-method define-extended-generic define-extended-generics @@ -48,8 +52,8 @@ ;; Applicable structs. - - + + @@ -58,6 +62,7 @@ + ;; Numbers. @@ -71,7 +76,7 @@ ;; smob-type-name->class procedure. - + ;; Modules. @@ -93,14 +98,14 @@ make-extended-generic make-accessor ensure-accessor add-method! - class-slot-ref class-slot-set! slot-unbound slot-missing + class-slot-ref class-slot-set! slot-unbound slot-missing slot-definition-name slot-definition-options slot-definition-allocation slot-definition-getter slot-definition-setter slot-definition-accessor slot-definition-init-value slot-definition-init-form - slot-definition-init-thunk slot-definition-init-keyword + slot-definition-init-thunk slot-definition-init-keyword slot-init-function class-slot-definition method-source compute-cpl compute-std-cpl compute-get-n-set compute-slots @@ -116,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 @@ -129,34 +132,1363 @@ 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)) -(define *goops-module* (current-module)) -;; XXX FIXME: figure out why the 'eval-when's in this file must use -;; 'compile' and must avoid 'expand', but only in 2.2, and only when -;; compiling something that imports goops, e.g. (ice-9 occam-channel), -;; before (oop goops) itself has been compiled. +;;; +;;; Booting GOOPS is a tortuous process. We begin by loading a small +;;; set of primitives from C. +;;; +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_goops_builtins") + (add-interesting-primitive! 'class-of)) -;; First initialize the builtin part of GOOPS -(eval-when (compile load eval) - (%init-goops-builtins)) -(eval-when (compile load eval) - (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) - (add-interesting-primitive! 'class-of)) + + +;;; +;;; We then define the slots that must appear in all classes ( +;;; objects) and slot definitions ( objects). These slots must +;;; appear in order. We'll use this list to statically compute offsets +;;; for the various fields, to compute the struct layout for +;;; instances, and to compute the slot definition lists for . +;;; Because the list is needed at expansion-time, we define it as a +;;; macro. +;;; +(define-syntax macro-fold-left + (syntax-rules () + ((_ folder seed ()) seed) + ((_ 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 + (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)) + + (define (merge-lists reversed-partial-result inputs) + (cond + ((every null? inputs) + (reverse! reversed-partial-result)) + (else + (let* ((candidate (lambda (c) + (and (not (any (lambda (l) + (memq c (cdr l))) + inputs)) + c))) + (candidate-car (lambda (l) + (and (not (null? l)) + (candidate (car l))))) + (next (any candidate-car inputs))) + (unless next + (goops-error "merge-lists: Inconsistent precedence graph")) + (let ((remove-next (lambda (l) + (if (eq? (car l) next) + (cdr l) + l)))) + (merge-lists (cons next reversed-partial-result) + (only-non-null (map remove-next inputs)))))))) + (let ((c-direct-supers (get-direct-supers c))) + (merge-lists (list c) + (only-non-null (append (map class-precedence-list + c-direct-supers) + (list c-direct-supers)))))) + +;; This version of compute-cpl is replaced with a generic function once +;; GOOPS has booted. +(define (compute-cpl class) + (compute-std-cpl class class-direct-supers)) + +(define (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 (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 static inherited field cannot be redefined" + '() '()))) + (define (remove-duplicate-slots slots) + (let lp ((slots (reverse slots)) (res '()) (seen '())) + (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))))))))) + +;; 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 (%slot-definition-options slot) #:class))) + (if (and type (subclass? type )) + (values (cond + ((subclass? type ) #\s) + ((subclass? type ) #\p) + (else #\u)) + (cond + ((subclass? type ) #\o) + ((subclass? type ) #\r) + ((subclass? type ) #\h) + (else #\w))) + (values #\p #\w)))) + (let ((layout (make-string (* nfields 2)))) + (let lp ((n 0) (slots slots)) + (match slots + (() + (unless (= n nfields) (error "bad nfields")) + (when is-class? + (let ((class-layout (struct-ref class-index-layout))) + (unless (string-prefix? (symbol->string class-layout) layout) + (error "bad layout for class")))) + layout) + ((slot . slots) + (unless (= n (%slot-definition-index slot)) (error "bad allocation")) + (call-with-values (lambda () (slot-protection-and-kind slot)) + (lambda (protection kind) + (let init ((n n) (size (%slot-definition-size slot))) + (cond + ((zero? size) (lp n slots)) + (else + (unless (< n nfields) (error "bad nfields")) + (string-set! layout (* n 2) protection) + (string-set! layout (1+ (* n 2)) kind) + (init (1+ n) (1- size)))))))))))) + + + + +;;; +;;; With all of this, we are now able to define subclasses of . +;;; +(define (%prep-layout! class) + (let* ((is-class? (and (memq (struct-ref class class-index-cpl)) #t)) + (layout (%compute-layout (struct-ref class class-index-slots) + (struct-ref class class-index-nfields) + is-class?))) + (%init-layout! class layout))) + +(define (make-standard-class class name dsupers dslots) + (let ((z (make-struct/no-tail class))) + (define (make-direct-slot-definition dslot) + (let ((initargs (compute-direct-slot-definition-initargs z dslot))) + (compute-direct-slot-definition z initargs))) + + (struct-set! z class-index-name name) + (struct-set! z class-index-nfields 0) + (struct-set! z class-index-direct-supers dsupers) + (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 () + ((define-standard-class name (super ...) #:metaclass meta slot ...) + (define name + (make-standard-class meta 'name (list super ...) '(slot ...)))) + ((define-standard-class name (super ...) slot ...) + (define-standard-class name (super ...) #:metaclass slot ...)))) + + + + +;;; +;;; Sweet! Now we can define and , and finish +;;; initializing the `direct-subclasses', `direct-supers', and `cpl' +;;; slots of . +;;; +(define-standard-class ()) +(define-standard-class ()) + +;; 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 )) + + + + +;;; +;;; 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 ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ( + )) +(define-standard-class ( + )) +(define-standard-class ( + )) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) + + + + +;;; +;;; 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 + ()) +(class-add-flags! + vtable-flag-setter-vtable) + +(define-standard-class ()) +(define-standard-class ( ) + #:metaclass + procedure) +(define-standard-class () + #:metaclass + setter) +(define-standard-class () + #:metaclass + methods + (n-specialized #:init-value 0) + (extended-by #:init-value ()) + effective-methods) +(define-standard-class () + #:metaclass + (extends #:init-value ())) +(define-standard-class ( + ) + #:metaclass ) +(define-standard-class () + #:metaclass ) +(define-standard-class ( + ) + #:metaclass ) +(define-standard-class ( + ) + #:metaclass ) + +(define-standard-class () + generic-function + specializers + procedure + formals + body + make-procedure) +(define-standard-class () + (slot-definition #:init-keyword #:slot-definition)) + +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class () + #:metaclass ) +(define-standard-class () + #:metaclass ) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) +(define-standard-class ( )) + +(define (inherit-applicable! class) + "An internal routine to redefine a SMOB class that was added after +GOOPS was loaded, and on which scm_set_smob_apply installed an apply +function." + ;; Why not use class-redefinition? We would, except that loading the + ;; compiler to compile effective methods can happen while GOOPS has + ;; only been partially loaded, and loading the compiler might cause + ;; SMOB types to be defined that need this facility. Instead we make + ;; a very specific hack, not a general solution. Probably the right + ;; solution is to avoid using the compiler, but that is another kettle + ;; of fish. + (unless (memq (class-precedence-list class)) + (unless (null? (class-slots class)) + (error "SMOB object has slots?")) + (for-each + (lambda (super) + (let ((subclasses (struct-ref super class-index-direct-subclasses))) + (struct-set! super class-index-direct-subclasses + (delq class subclasses)))) + (struct-ref class class-index-direct-supers)) + (struct-set! class class-index-direct-supers (list )) + (struct-set! class class-index-cpl (compute-cpl class)) + (let ((subclasses (struct-ref class-index-direct-subclasses))) + (struct-set! class-index-direct-subclasses + (cons class subclasses))))) + + + + +;;; +;;; At this point we have defined the class hierarchy, and it's time to +;;; move on to instance allocation and generics. Once we have generics, +;;; we'll fill out the metaobject protocol. +;;; +;;; Here we define a limited version of `make', so that we can allocate +;;; instances of specific classes. This definition will be replaced +;;; later. +;;; +(define (%invalidate-method-cache! gf) + (slot-set! gf 'procedure (delayed-compile gf)) + (slot-set! gf 'effective-methods '())) + +;; Boot definition. +(define (invalidate-method-cache! gf) + (%invalidate-method-cache! gf)) + +(define (make class . args) + (cond + ((or (eq? class ) (eq? class )) + (let ((z (make-struct/no-tail class #f '() 0 '()))) + (set-procedure-property! z 'name (get-keyword #:name args #f)) + (invalidate-method-cache! z) + (when (eq? class ) + (let ((setter (get-keyword #:setter args #f))) + (when setter + (slot-set! z 'setter setter)))) + z)) + (else + (let ((z (%allocate-instance class))) + (cond + ((or (eq? class ) (eq? class )) + (for-each (match-lambda + ((kw slot default) + (slot-set! z slot (get-keyword kw args default)))) + '((#:generic-function generic-function #f) + (#:specializers specializers ()) + (#:procedure procedure #f) + (#:formals formals ()) + (#:body body ()) + (#:make-procedure make-procedure #f)))) + ((memq (class-precedence-list class)) + (class-add-flags! z (logior vtable-flag-goops-class + vtable-flag-goops-valid)) + (for-each (match-lambda + ((kw slot default) + (slot-set! z slot (get-keyword kw args default)))) + '((#:name name ???) + (#:dsupers direct-supers ()) + (#:slots direct-slots ())))) + (else + (error "boot `make' does not support this class" class))) + z)))) + + + + +;;; +;;; 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)) + +;;; +;;; Generic functions have an applicable-methods cache associated with +;;; them. Every distinct set of types that is dispatched through a +;;; generic adds an entry to the cache. This cache gets compiled out to +;;; a dispatch procedure. In steady-state, this dispatch procedure is +;;; never recompiled; but during warm-up there is some churn, both to +;;; the cache and to the dispatch procedure. +;;; +;;; So what is the deal if warm-up happens in a multithreaded context? +;;; There is indeed a window between missing the cache for a certain set +;;; of arguments, and then updating the cache with the newly computed +;;; applicable methods. One of the updaters is liable to lose their new +;;; entry. +;;; +;;; This is actually OK though, because a subsequent cache miss for the +;;; race loser will just cause memoization to try again. The cache will +;;; eventually be consistent. We're not mutating the old part of the +;;; cache, just consing on the new entry. +;;; +;;; It doesn't even matter if the dispatch procedure and the cache are +;;; inconsistent -- most likely the type-set that lost the dispatch +;;; procedure race will simply re-trigger a memoization, but since the +;;; winner isn't in the effective-methods cache, it will likely also +;;; re-trigger a memoization, and the cache will finally be consistent. +;;; As you can see there is a possibility for ping-pong effects, but +;;; it's unlikely given the shortness of the window between slot-set! +;;; invocations. We could add a mutex, but it is strictly unnecessary, +;;; and would add runtime cost and complexity. +;;; + +(define (emit-linear-dispatch gf-sym nargs methods free rest?) + (define (gen-syms n stem) + (let lp ((n (1- n)) (syms '())) + (if (< n 0) + syms + (lp (1- n) (cons (gensym stem) syms))))) + (let* ((args (gen-syms nargs "a")) + (types (gen-syms nargs "t"))) + (let lp ((methods methods) + (free free) + (exp `(cache-miss ,gf-sym + ,(if rest? + `(cons* ,@args rest) + `(list ,@args))))) + (match methods + (() + (values `(,(if rest? `(,@args . rest) args) + (let ,(map (lambda (t a) + `(,t (class-of ,a))) + types args) + ,exp)) + free)) + ((#(_ specs _ cmethod) . methods) + (let build-dispatch ((free free) + (types types) + (specs specs) + (checks '())) + (match types + (() + (let ((m-sym (gensym "p"))) + (lp methods + (acons cmethod m-sym free) + `(if (and . ,checks) + ,(if rest? + `(apply ,m-sym ,@args rest) + `(,m-sym . ,args)) + ,exp)))) + ((type . types) + (match specs + ((spec . specs) + (let ((var (assq-ref free spec))) + (if var + (build-dispatch free + types + specs + (cons `(eq? ,type ,var) + checks)) + (let ((var (gensym "c"))) + (build-dispatch (acons spec var free) + types + specs + (cons `(eq? ,type ,var) + checks))))))))))))))) + +(define (compute-dispatch-procedure gf cache) + (define (scan) + (let lp ((ls cache) (nreq -1) (nrest -1)) + (match ls + (() + (collate (make-vector (1+ nreq) '()) + (make-vector (1+ nrest) '()))) + ((#(len specs rest? cmethod) . ls) + (if rest? + (lp ls nreq (max nrest len)) + (lp ls (max nreq len) nrest)))))) + (define (collate req rest) + (let lp ((ls cache)) + (match ls + (() (emit req rest)) + (((and entry #(len specs rest? cmethod)) . ls) + (if rest? + (vector-set! rest len (cons entry (vector-ref rest len))) + (vector-set! req len (cons entry (vector-ref req len)))) + (lp ls))))) + (define (emit req rest) + (let ((gf-sym (gensym "g"))) + (define (emit-rest n clauses free) + (if (< n (vector-length rest)) + (match (vector-ref rest n) + (() (emit-rest (1+ n) clauses free)) + ;; FIXME: hash dispatch + (methods + (call-with-values + (lambda () + (emit-linear-dispatch gf-sym n methods free #t)) + (lambda (clause free) + (emit-rest (1+ n) (cons clause clauses) free))))) + (emit-req (1- (vector-length req)) clauses free))) + (define (emit-req n clauses free) + (if (< n 0) + (comp `(lambda ,(map cdr free) + (case-lambda ,@clauses)) + (map car free)) + (match (vector-ref req n) + (() (emit-req (1- n) clauses free)) + ;; FIXME: hash dispatch + (methods + (call-with-values + (lambda () + (emit-linear-dispatch gf-sym n methods free #f)) + (lambda (clause free) + (emit-req (1- n) (cons clause clauses) free))))))) + + (emit-rest 0 + (if (or (zero? (vector-length rest)) + (null? (vector-ref rest 0))) + (list `(args (cache-miss ,gf-sym args))) + '()) + (acons gf gf-sym '())))) + (define (comp exp vals) + ;; When cross-compiling Guile itself, the native Guile must generate + ;; code for the host. + (with-target %host-type + (lambda () + (let ((p ((@ (system base compile) compile) exp + #:env *dispatch-module* + #:from 'scheme + #:opts '(#:partial-eval? #f #:cse? #f)))) + (apply p vals))))) + + ;; kick it. + (scan)) + +;; o/~ ten, nine, eight +;; sometimes that's just how it goes +;; three, two, one +;; +;; get out before it blows o/~ +;; +(define timer-init 30) +(define (delayed-compile gf) + (let ((timer timer-init)) + (lambda args + (set! timer (1- timer)) + (cond + ((zero? timer) + (let ((dispatch (compute-dispatch-procedure + gf (slot-ref gf 'effective-methods)))) + (slot-set! gf 'procedure dispatch) + (apply dispatch args))) + (else + ;; interestingly, this catches recursive compilation attempts as + ;; well; in that case, timer is negative + (cache-dispatch gf args)))))) + +(define (cache-dispatch gf args) + (define (map-until n f ls) + (if (or (zero? n) (null? ls)) + '() + (cons (f (car ls)) (map-until (1- n) f (cdr ls))))) + (define (equal? x y) ; can't use the stock equal? because it's a generic... + (cond ((pair? x) (and (pair? y) + (eq? (car x) (car y)) + (equal? (cdr x) (cdr y)))) + ((null? x) (null? y)) + (else #f))) + (if (slot-ref gf 'n-specialized) + (let ((types (map-until (slot-ref gf 'n-specialized) class-of args))) + (let lp ((cache (slot-ref gf 'effective-methods))) + (cond ((null? cache) + (cache-miss gf args)) + ((equal? (vector-ref (car cache) 1) types) + (apply (vector-ref (car cache) 3) args)) + (else (lp (cdr cache)))))) + (cache-miss gf args))) + +(define (cache-miss gf args) + (apply (memoize-method! gf args) args)) + +(define (memoize-effective-method! gf args applicable) + (define (first-n ls n) + (if (or (zero? n) (null? ls)) + '() + (cons (car ls) (first-n (cdr ls) (- n 1))))) + (define (parse n ls) + (cond ((null? ls) + (memoize n #f (map class-of args))) + ((= n (slot-ref gf 'n-specialized)) + (memoize n #t (map class-of (first-n args n)))) + (else + (parse (1+ n) (cdr ls))))) + (define (memoize len rest? types) + (let* ((cmethod (compute-cmethod applicable types)) + (cache (cons (vector len types rest? cmethod) + (slot-ref gf 'effective-methods)))) + (slot-set! gf 'effective-methods cache) + (slot-set! gf 'procedure (delayed-compile gf)) + cmethod)) + (parse 0 args)) + +;;; +;;; Compiling next methods into method bodies +;;; + +;;; So, for the reader: there basic idea is that, given that the +;;; semantics of `next-method' depend on the concrete types being +;;; dispatched, why not compile a specific procedure to handle each type +;;; combination that we see at runtime. +;;; +;;; In theory we can do much better than a bytecode compilation, because +;;; we know the *exact* types of the arguments. It's ideal for native +;;; compilation. A task for the future. +;;; +;;; I think this whole generic application mess would benefit from a +;;; strict MOP. + +(define (compute-cmethod methods types) + (let ((make-procedure (slot-ref (car methods) 'make-procedure))) + (if make-procedure + (make-procedure + (if (null? (cdr methods)) + (lambda args + (no-next-method (method-generic-function (car methods)) args)) + (compute-cmethod (cdr methods) types))) + (method-procedure (car methods))))) + +;;; +;;; Memoization +;;; + +(define (memoize-method! gf args) + (let ((applicable ((if (eq? gf compute-applicable-methods) + %compute-applicable-methods + compute-applicable-methods) + gf args))) + (cond (applicable + (memoize-effective-method! gf args applicable)) + (else + (no-applicable-method gf args))))) + +(set-procedure-property! memoize-method! 'system-procedure #t) + +(define no-applicable-method + (make #:name 'no-applicable-method)) + +(%goops-early-init) ;; Then load the rest of GOOPS -(use-modules (oop goops util) - (oop goops dispatch) - (oop goops compile)) ;; FIXME: deprecate. -(eval-when (compile load eval) - (define min-fixnum (- (expt 2 29))) - (define max-fixnum (- (expt 2 29) 1))) +(define min-fixnum (- (expt 2 29))) +(define max-fixnum (- (expt 2 29) 1)) ;; ;; goops-error @@ -164,13 +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} ;;; @@ -179,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} @@ -216,26 +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 (kw-do-map mapper f kwargs) - (define (keywords l) - (cond - ((null? l) '()) - ((or (null? (cdr l)) (not (keyword? (car l)))) - (goops-error "malformed keyword arguments: ~a" kwargs)) - (else (cons (car l) (keywords (cddr l)))))) - (define (args l) - (if (null? l) '() (cons (cadr l) (args (cddr l))))) - ;; let* to check keywords first - (let* ((k (keywords kwargs)) - (a (args kwargs))) - (mapper f k a))) - (define (make-class supers slots . options) - (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))) @@ -248,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)) @@ -259,7 +1583,7 @@ ;; Everything seems correct, build the class (apply make metaclass #:dsupers supers - #:slots slots + #:slots slots #:name name options))) @@ -268,35 +1592,43 @@ ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; -(define-macro (class supers . slots) - (define (make-slot-definition-forms slots) - (map - (lambda (def) - (cond - ((pair? def) - `(list ',(car def) - ,@(kw-do-map append-map - (lambda (kw arg) - (case kw - ((#:init-form) - `(#:init-form ',arg - #:init-thunk (lambda () ,arg))) - (else (list kw arg)))) - (cdr def)))) - (else - `(list ',def)))) - slots)) - (if (not (list? supers)) - (goops-error "malformed superclass list: ~S" supers)) - (let ((slots (take-while (lambda (x) (not (keyword? x))) slots)) - (options (or (find-tail keyword? slots) '()))) - `(make-class - ;; evaluate super class variables - (list ,@supers) - ;; evaluate slot definitions, except the slot name! - (list ,@(make-slot-definition-forms slots)) - ;; evaluate class options - ,@options))) +(define-syntax class + (lambda (x) + (define (parse-options options) + (syntax-case options () + (() #'()) + ((kw arg . options) (keyword? (syntax->datum #'kw)) + (with-syntax ((options (parse-options #'options))) + (syntax-case #'kw () + (#:init-form + #'(kw 'arg #:init-thunk (lambda () arg) . options)) + (_ + #'(kw arg . options))))))) + (define (check-valid-kwargs args) + (syntax-case args () + (() #'()) + ((kw arg . args) (keyword? (syntax->datum #'kw)) + #`(kw arg . #,(check-valid-kwargs #'args))))) + (define (parse-slots-and-kwargs args) + (syntax-case args () + (() + #'(() ())) + ((kw . _) (keyword? (syntax->datum #'kw)) + #`(() #,(check-valid-kwargs args))) + (((name option ...) args ...) + (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))) + ((option ...) (parse-options #'(option ...)))) + #'(((list 'name option ...) . slots) kwargs))) + ((name args ...) (symbol? (syntax->datum #'name)) + (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))) + #'(('(name) . slots) kwargs))))) + (syntax-case x () + ((class (super ...) arg ...) + (with-syntax ((((slot-def ...) (option ...)) + (parse-slots-and-kwargs #'(arg ...)))) + #'(make-class (list super ...) + (list slot-def ...) + option ...)))))) (define-syntax define-class-pre-definition (lambda (x) @@ -307,24 +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 @@ -342,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 ...) @@ -354,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 ...)) @@ -365,72 +1697,79 @@ ;; Apparently the desired semantics are that we extend previous ;; procedural definitions, but that if `name' was already a generic, we ;; overwrite its definition. -(define-macro (define-generic name) - (if (not (symbol? name)) - (goops-error "bad generic function name: ~S" name)) - `(define ,name - (if (and (defined? ',name) (is-a? ,name )) - (make #:name ',name) - (ensure-generic (if (defined? ',name) ,name #f) ',name)))) - -(define-macro (define-extended-generic name val) - (if (not (symbol? name)) - (goops-error "bad generic function name: ~S" name)) - `(define ,name (make-extended-generic ,val ',name))) - -(define-macro (define-extended-generics names . args) - (let ((prefixes (get-keyword #:prefix args #f))) - (if prefixes - `(begin - ,@(map (lambda (name) - `(define-extended-generic ,name - (list ,@(map (lambda (prefix) - (symbol-append prefix name)) - prefixes)))) - names)) - (goops-error "no prefixes supplied")))) +(define-syntax define-generic + (lambda (x) + (syntax-case x () + ((define-generic name) (symbol? (syntax->datum #'name)) + #'(define name + (if (and (defined? 'name) (is-a? name )) + (make #:name 'name) + (ensure-generic (if (defined? 'name) name #f) 'name))))))) + +(define-syntax define-extended-generic + (lambda (x) + (syntax-case x () + ((define-extended-generic name val) (symbol? (syntax->datum #'name)) + #'(define name (make-extended-generic val 'name)))))) + +(define-syntax define-extended-generics + (lambda (x) + (define (id-append ctx a b) + (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) + (syntax-case x () + ((define-extended-generic (name ...) #:prefix (prefix ...)) + (and (and-map symbol? (syntax->datum #'(name ...))) + (and-map symbol? (syntax->datum #'(prefix ...)))) + (with-syntax ((((val ...)) (map (lambda (name) + (map (lambda (prefix) + (id-append name prefix name)) + #'(prefix ...))) + #'(name ...)))) + #'(begin + (define-extended-generic name (list val ...)) + ...)))))) (define* (make-generic #:optional name) (make #:name name)) (define* (make-extended-generic gfs #:optional name) (let* ((gfs (if (list? gfs) gfs (list gfs))) - (gws? (any (lambda (gf) (is-a? gf )) gfs))) + (gws? (any (lambda (gf) (is-a? gf )) gfs))) (let ((ans (if gws? - (let* ((sname (and name (make-setter-name name))) - (setters - (append-map (lambda (gf) - (if (is-a? gf ) - (list (ensure-generic (setter gf) - sname)) - '())) - gfs)) - (es (make - #:name name - #:extends gfs - #:setter (make - #:name sname - #:extends setters)))) - (extended-by! setters (setter es)) - es) - (make - #:name name - #:extends gfs)))) + (let* ((sname (and name (make-setter-name name))) + (setters + (append-map (lambda (gf) + (if (is-a? gf ) + (list (ensure-generic (setter gf) + sname)) + '())) + gfs)) + (es (make + #:name name + #:extends gfs + #:setter (make + #:name sname + #:extends setters)))) + (extended-by! setters (setter es)) + es) + (make + #:name name + #:extends gfs)))) (extended-by! gfs ans) ans))) (define (extended-by! gfs eg) (for-each (lambda (gf) - (slot-set! gf 'extended-by - (cons eg (slot-ref gf 'extended-by)))) - gfs) + (slot-set! gf 'extended-by + (cons eg (slot-ref gf 'extended-by)))) + gfs) (invalidate-method-cache! eg)) (define (not-extended-by! gfs eg) (for-each (lambda (gf) - (slot-set! gf 'extended-by - (delq! eg (slot-ref gf 'extended-by)))) - gfs) + (slot-set! gf 'extended-by + (delq! eg (slot-ref gf 'extended-by)))) + gfs) (invalidate-method-cache! eg)) (define* (ensure-generic old-definition #:optional name) @@ -484,21 +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)) @@ -507,6 +1846,101 @@ ;;; {Methods} ;;; +;; Note: `a' and `b' can have unequal lengths (i.e. one can be one +;; element longer than the other when we have a dotted parameter +;; list). For instance, with the call +;; +;; (M 1) +;; +;; with +;; +;; (define-method M (a . l) ....) +;; (define-method M (a) ....) +;; +;; we consider that the second method is more specific. +;; +;; Precondition: `a' and `b' are methods and are applicable to `types'. +(define (%method-more-specific? a b types) + (let lp ((a-specializers (method-specializers a)) + (b-specializers (method-specializers b)) + (types types)) + (cond + ;; (a) less specific than (a b ...) or (a . b) + ((null? a-specializers) #t) + ;; (a b ...) or (a . b) less specific than (a) + ((null? b-specializers) #f) + ;; (a . b) less specific than (a b ...) + ((not (pair? a-specializers)) #f) + ;; (a b ...) more specific than (a . b) + ((not (pair? b-specializers)) #t) + (else + (let ((a-specializer (car a-specializers)) + (b-specializer (car b-specializers)) + (a-specializers (cdr a-specializers)) + (b-specializers (cdr b-specializers)) + (type (car types)) + (types (cdr types))) + (if (eq? a-specializer b-specializer) + (lp a-specializers b-specializers types) + (let lp ((cpl (class-precedence-list type))) + (let ((elt (car cpl))) + (cond + ((eq? a-specializer elt) #t) + ((eq? b-specializer elt) #f) + (else (lp (cdr cpl)))))))))))) + +(define (%sort-applicable-methods methods types) + (sort methods (lambda (a b) (%method-more-specific? a b types)))) + +(define (generic-function-methods obj) + "Return the methods of the generic function @var{obj}." + (define (fold-upward method-lists gf) + (cond + ((is-a? gf ) + (let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends))) + (match gfs + (() method-lists) + ((gf . gfs) + (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf) + gfs))))) + (else method-lists))) + (define (fold-downward method-lists gf) + (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists)) + (gfs (slot-ref gf 'extended-by))) + (match gfs + (() method-lists) + ((gf . gfs) + (lp (fold-downward method-lists gf) gfs))))) + (unless (is-a? obj ) + (scm-error 'wrong-type-arg #f "Not a generic: ~S" + (list obj) #f)) + (concatenate (fold-downward (fold-upward '() obj) obj))) + +(define (%compute-applicable-methods gf args) + (define (method-applicable? m types) + (let lp ((specs (method-specializers m)) (types types)) + (cond + ((null? specs) (null? types)) + ((not (pair? specs)) #t) + ((null? types) #f) + (else + (and (memq (car specs) (class-precedence-list (car types))) + (lp (cdr specs) (cdr types))))))) + (let ((n (length args)) + (types (map class-of args))) + (let lp ((methods (generic-function-methods gf)) + (applicable '())) + (if (null? methods) + (and (not (null? applicable)) + (%sort-applicable-methods applicable types)) + (let ((m (car methods))) + (lp (cdr methods) + (if (method-applicable? m types) + (cons m applicable) + applicable))))))) + +(define compute-applicable-methods %compute-applicable-methods) + (define (toplevel-define! name val) (module-define! (current-module) name val)) @@ -514,11 +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 @@ -527,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 @@ -631,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!} ;;; @@ -638,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))) @@ -694,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 )) @@ -713,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))) @@ -727,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}." @@ -781,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?) ;;; @@ -789,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 @@ -806,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)) ;;; @@ -887,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) @@ -954,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)) @@ -983,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)) @@ -998,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)) @@ -1008,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)) ;;; @@ -1041,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) @@ -1084,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) @@ -1102,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} @@ -1149,48 +2587,49 @@ ;;; (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) (assert-bound (proc o) o))) + (lambda (o) + (let ((val (proc o))) + (if (unbound? val) + (slot-unbound o) + val)))) ;;; Pre-generate getters and setters for the first 20 slots. (define-syntax define-standard-accessor-method @@ -1221,324 +2660,215 @@ (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) - (cons name - (cons (compute-slot-init-function name s) - (if (or (integer? g-n-s) - (zero? size)) - g-n-s - (append g-n-s (list index size))))))) - slots)) - ;;; compute-cpl ;;; -;;; Correct behaviour: -;;; -;;; (define-class food ()) -;;; (define-class fruit (food)) -;;; (define-class spice (food)) -;;; (define-class apple (fruit)) -;;; (define-class cinnamon (spice)) -;;; (define-class pie (apple cinnamon)) -;;; => cpl (pie) = pie apple fruit cinnamon spice food object top -;;; -;;; (define-class d ()) -;;; (define-class e ()) -;;; (define-class f ()) -;;; (define-class b (d e)) -;;; (define-class c (e f)) -;;; (define-class a (b c)) -;;; => cpl (a) = a b d c e f object top -;;; + +;; Replace the bootstrap compute-cpl with this definition. +(define compute-cpl + (make #:name 'compute-cpl)) (define-method (compute-cpl (class )) (compute-std-cpl class class-direct-supers)) -;; Support - -(define (only-non-null lst) - (filter (lambda (l) (not (null? l))) lst)) - -(define (compute-std-cpl c get-direct-supers) - (let ((c-direct-supers (get-direct-supers c))) - (merge-lists (list c) - (only-non-null (append (map class-precedence-list - c-direct-supers) - (list c-direct-supers)))))) - -(define (merge-lists reversed-partial-result inputs) - (cond - ((every null? inputs) - (reverse! reversed-partial-result)) - (else - (let* ((candidate (lambda (c) - (and (not (any (lambda (l) - (memq c (cdr l))) - inputs)) - c))) - (candidate-car (lambda (l) - (and (not (null? l)) - (candidate (car l))))) - (next (any candidate-car inputs))) - (if (not next) - (goops-error "merge-lists: Inconsistent precedence graph")) - (let ((remove-next (lambda (l) - (if (eq? (car l) next) - (cdr l) - l)))) - (merge-lists (cons next reversed-partial-result) - (only-non-null (map remove-next inputs)))))))) - -;; Modified from TinyClos: -;; -;; A simple topological sort. -;; -;; It's in this file so that both TinyClos and Objects can use it. -;; -;; This is a fairly modified version of code I originally got from Anurag -;; Mendhekar . -;; - -(define (compute-clos-cpl c get-direct-supers) - (top-sort ((build-transitive-closure get-direct-supers) c) - ((build-constraints get-direct-supers) c) - (std-tie-breaker get-direct-supers))) - - -(define (top-sort elements constraints tie-breaker) - (let loop ((elements elements) - (constraints constraints) - (result '())) - (if (null? elements) - result - (let ((can-go-in-now - (filter - (lambda (x) - (every (lambda (constraint) - (or (not (eq? (cadr constraint) x)) - (memq (car constraint) result))) - constraints)) - elements))) - (if (null? can-go-in-now) - (goops-error "top-sort: Invalid constraints") - (let ((choice (if (null? (cdr can-go-in-now)) - (car can-go-in-now) - (tie-breaker result - can-go-in-now)))) - (loop - (filter (lambda (x) (not (eq? x choice))) - elements) - constraints - (append result (list choice))))))))) - -(define (std-tie-breaker get-supers) - (lambda (partial-cpl min-elts) - (let loop ((pcpl (reverse partial-cpl))) - (let ((current-elt (car pcpl))) - (let ((ds-of-ce (get-supers current-elt))) - (let ((common (filter (lambda (x) - (memq x ds-of-ce)) - min-elts))) - (if (null? common) - (if (null? (cdr pcpl)) - (goops-error "std-tie-breaker: Nothing valid") - (loop (cdr pcpl))) - (car common)))))))) - - -(define (build-transitive-closure get-follow-ons) - (lambda (x) - (let track ((result '()) - (pending (list x))) - (if (null? pending) - result - (let ((next (car pending))) - (if (memq next result) - (track result (cdr pending)) - (track (cons next result) - (append (get-follow-ons next) - (cdr pending))))))))) - -(define (build-constraints get-follow-ons) - (lambda (x) - (let loop ((elements ((build-transitive-closure get-follow-ons) x)) - (this-one '()) - (result '())) - (if (or (null? this-one) (null? (cdr this-one))) - (if (null? elements) - result - (loop (cdr elements) - (cons (car elements) - (get-follow-ons (car elements))) - result)) - (loop elements - (cdr this-one) - (cons (list (car this-one) (cadr this-one)) - result)))))) - ;;; compute-get-n-set ;;; +(define 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))) + (if thunk + (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) - ;; 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) - (make-closure-variable class)) + (make-closure-variable class (class-slot-init-value))) ((#:virtual) ;; No allocation ;; slot-ref and slot-set! function must be given by the user (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f)) - (set (get-keyword #:slot-set! (slot-definition-options s) #f))) - (if (not (and get set)) - (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" - s)) + (set (get-keyword #:slot-set! (slot-definition-options s) #f))) + (unless (and get set) + (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" s)) (list get set))) (else (next-method)))) -(define (make-closure-variable class) - (let ((shared-variable (make-unbound))) - (list (lambda (o) shared-variable) - (lambda (o v) (set! shared-variable v))))) - (define-method (compute-get-n-set (o ) s) (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) (define-method (compute-slots (class )) - (%compute-slots class)) + (build-slots-list (class-direct-slots class) + (class-precedence-list class))) ;;; ;;; {Initialize} ;;; +;; 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) (next-method) (initialize-object-procedure applicable-struct initargs)) +(define-method (initialize (applicable-struct ) + initargs) + (next-method) + (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f))) + (define-method (initialize (generic ) initargs) (let ((previous-definition (get-keyword #:default initargs #f)) - (name (get-keyword #:name initargs #f))) + (name (get-keyword #:name initargs #f))) (next-method) (slot-set! generic 'methods (if (is-a? previous-definition ) - (list (method args + (list (method args (apply previous-definition args))) - '())) + '())) (if name - (set-procedure-property! generic 'name name)) - )) - -(define-method (initialize (gws ) initargs) - (next-method) - (%set-object-setter! gws (get-keyword #:setter initargs #f))) + (set-procedure-property! generic 'name name)) + (invalidate-method-cache! generic))) (define-method (initialize (eg ) initargs) (next-method) @@ -1551,11 +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} @@ -1564,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) @@ -1593,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) @@ -1608,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))) @@ -1620,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 @@ -1650,70 +2988,34 @@ (set! compute-applicable-methods %%compute-applicable-methods) (define-method (sort-applicable-methods (gf ) methods args) - (let ((targs (map class-of args))) - (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs))))) + (%sort-applicable-methods methods (map class-of args))) (define-method (method-more-specific? (m1 ) (m2 ) targs) (%method-more-specific? m1 m2 targs)) (define-method (apply-method (gf ) methods build-next args) (apply (method-procedure (car methods)) - (build-next (cdr methods) args) - args)) + (build-next (cdr methods) args) + args)) (define-method (apply-methods (gf ) (l ) args) (letrec ((next (lambda (procs args) - (lambda new-args - (let ((a (if (null? new-args) args new-args))) - (if (null? procs) - (no-next-method gf a) - (apply-method gf procs next a))))))) + (lambda new-args + (let ((a (if (null? new-args) args new-args))) + (if (null? procs) + (no-next-method gf a) + (apply-method gf procs next a))))))) (apply-method gf l next args))) ;; We don't want the following procedure to turn up in backtraces: (for-each (lambda (proc) - (set-procedure-property! proc 'system-procedure #t)) - (list slot-unbound - slot-missing - no-next-method - no-applicable-method - no-method - )) - -;;; -;;; { and } -;;; - -;(autoload "active-slot" ) -;(autoload "composite-slot" ) -;(export ) - -;;; -;;; {Tools} -;;; - -;; list2set -;; -;; duplicate the standard list->set function but using eq instead of -;; eqv which really sucks a lot, uselessly here -;; -(define (list2set l) - (let loop ((l l) - (res '())) - (cond - ((null? l) res) - ((memq (car l) res) (loop (cdr l) res)) - (else (loop (cdr l) (cons (car l) res)))))) - -(define (class-subclasses c) - (letrec ((allsubs (lambda (c) - (cons c (mapappend allsubs - (class-direct-subclasses c)))))) - (list2set (cdr (allsubs c))))) - -(define (class-methods c) - (list2set (mapappend class-direct-methods - (cons c (class-subclasses c))))) + (set-procedure-property! proc 'system-procedure #t)) + (list slot-unbound + slot-missing + no-next-method + no-applicable-method + no-method + )) ;;; ;;; {Final initialization} @@ -1740,7 +3042,6 @@ (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass '))