From feea06ce0acba516d739867b23341509e9c36d50 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 9 Sep 2005 20:27:59 +0000 Subject: [PATCH] 0.9.4.57: Implement the METAOBJECT class as per AMOP. ... we can do this safely now that INSTANCE and FUNCALLABLE-INSTANCE confusion has been resolved. Woohoo. --- NEWS | 6 + doc/manual/beyond-ansi.texinfo | 5 - package-data-list.lisp-expr | 3 +- src/pcl/defs.lisp | 453 ++++++++++++++++++++-------------------- src/pcl/std-class.lisp | 2 +- tests/mop.impure.lisp | 2 +- tests/mop.pure.lisp | 7 + version.lisp-expr | 2 +- 8 files changed, 242 insertions(+), 238 deletions(-) diff --git a/NEWS b/NEWS index fe01370..fbdb0c5 100644 --- a/NEWS +++ b/NEWS @@ -30,6 +30,12 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: consistent, even on internal alternate-metaclass objects. * bug fix: SB-MOP:FUNCALLABLE-STANDARD-OBJECT is now a subclass of STANDARD-OBJECT, as required by AMOP. + * bug fix: the classes STANDARD-CLASS and + SB-MOP:FUNCALLABLE-STANDARD-CLASS are now compatible in the + SB-MOP:VALIDATE-SUPERCLASS sense; there remains a constraint about + finalized classes and the FUNCTION class. + * bug fix: the SB-MOP:METAOBJECT class is now implemented as + specified by AMOP. * threads ** bug fix: parent thread now can be gc'ed even with a live child thread diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 7960c08..9cc2a9e 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -45,11 +45,6 @@ are: @itemize @item -@tindex metaobject -the abstract @code{metaobject} class is not present in the class -hierarchy; - -@item @findex compute-effective-method @findex sb-mop:compute-effective-method @code{compute-effective-method} only returns one value, not two; diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 93922bc..76c7b45 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1677,8 +1677,7 @@ ISBN 0-262-61074-4, with exceptions as noted in the User Manual." "INTERN-EQL-SPECIALIZER" "MAKE-METHOD-LAMBDA" "MAP-DEPENDENTS" - ;; KLUDGE: See the User Manual - ;; "METAOBJECT" + "METAOBJECT" "METHOD-FUNCTION" "METHOD-GENERIC-FUNCTION" "METHOD-LAMBDA-LIST" diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 5b181e1..781f4c6 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -345,150 +345,130 @@ () (:metaclass funcallable-standard-class)) -(defclass specializer (standard-object) - ((type :initform nil :reader specializer-type))) - -(defclass definition-source-mixin (standard-object) - ((source :initform *load-pathname* :reader definition-source - :initarg :definition-source))) - -(defclass plist-mixin (standard-object) - ((plist :initform () :accessor object-plist))) +(defclass metaobject (standard-object) ()) -(defclass dependent-update-mixin (plist-mixin) ()) +(defclass generic-function (dependent-update-mixin + definition-source-mixin + metaobject + funcallable-standard-object) + ((documentation + :initform nil + :initarg :documentation) + ;; We need to make a distinction between the methods initially set + ;; up by :METHOD options to DEFGENERIC and the ones set up later by + ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on + ;; an already-DEFGENERICed function clears the methods set by the + ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making + ;; this distinction seems a little kludgy, but it has the positive + ;; effect of making it so that loading a file a.lisp containing + ;; DEFGENERIC, then loading a second file b.lisp containing + ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp + ;; tends to leave the generic function in a state consistent with + ;; the most-recently-loaded state of a.lisp and b.lisp.) + (initial-methods + :initform () + :accessor generic-function-initial-methods)) + (:metaclass funcallable-standard-class)) -;;; The class CLASS is a specified basic class. It is the common -;;; superclass of any kind of class. That is, any class that can be a -;;; metaclass must have the class CLASS in its class precedence list. -(defclass class (dependent-update-mixin - definition-source-mixin - specializer) +(defclass standard-generic-function (generic-function) ((name :initform nil - :initarg :name - :accessor class-name) - (class-eq-specializer - :initform nil - :reader class-eq-specializer) - (direct-superclasses + :initarg :name + :accessor generic-function-name) + (methods :initform () - :reader class-direct-superclasses) - ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and - ;; CONDITION-CLASSes are lazily computed whenever the subclass info - ;; becomes available, i.e. when the PCL class is created. - (direct-subclasses + :accessor generic-function-methods + :type list) + (method-class + :initarg :method-class + :accessor generic-function-method-class) + (method-combination + :initarg :method-combination + :accessor generic-function-method-combination) + (declarations + ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies + ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning + ;; might be appropriate). + :initarg :declarations + :initarg :declare :initform () - :reader class-direct-subclasses) - (direct-methods - :initform (cons nil nil)) - (predicate-name - :initform nil - :reader class-predicate-name) - (documentation - :initform nil - :initarg :documentation) - (finalized-p - :initform nil - :reader class-finalized-p))) + :accessor generic-function-declarations) + (arg-info + :initform (make-arg-info) + :reader gf-arg-info) + (dfun-state + :initform () + :accessor gf-dfun-state)) + (:metaclass funcallable-standard-class) + (:default-initargs :method-class *the-class-standard-method* + :method-combination *standard-method-combination*)) -(def!method make-load-form ((class class) &optional env) - ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably - ;; doesn't matter while all our environments are the same... - (declare (ignore env)) - (let ((name (class-name class))) - (unless (and name (eq (find-class name nil) class)) - (error "~@" - class)) - `(find-class ',name))) +(defclass method (metaobject) ()) -;;; The class PCL-CLASS is an implementation-specific common -;;; superclass of all specified subclasses of the class CLASS. -(defclass pcl-class (class) - ((class-precedence-list - :reader class-precedence-list) - ;; KLUDGE: see note in CPL-OR-NIL - (cpl-available-p - :reader cpl-available-p - :initform nil) - (can-precede-list +(defclass standard-method (definition-source-mixin plist-mixin method) + ((generic-function + :initform nil + :accessor method-generic-function) +;;; (qualifiers +;;; :initform () +;;; :initarg :qualifiers +;;; :reader method-qualifiers) + (specializers :initform () - :reader class-can-precede-list) - (incompatible-superclass-list + :initarg :specializers + :reader method-specializers) + (lambda-list :initform () - :accessor class-incompatible-superclass-list) - (wrapper + :initarg :lambda-list + :reader method-lambda-list) + (function :initform nil - :reader class-wrapper) - (prototype + :initarg :function) ;no writer + (fast-function :initform nil - :reader class-prototype))) - -(defclass slot-class (pcl-class) - ((direct-slots - :initform () - :accessor class-direct-slots) - (slots - :initform () - :accessor class-slots))) - -;;; The class STD-CLASS is an implementation-specific common -;;; superclass of the classes STANDARD-CLASS and -;;; FUNCALLABLE-STANDARD-CLASS. -(defclass std-class (slot-class) - ()) - -(defclass standard-class (std-class) - ()) - -(defclass funcallable-standard-class (std-class) - ()) - -(defclass forward-referenced-class (pcl-class) ()) - -(defclass built-in-class (pcl-class) ()) - -(defclass condition-class (slot-class) ()) - -(defclass structure-class (slot-class) - ((defstruct-form - :initform () - :accessor class-defstruct-form) - (defstruct-constructor - :initform nil - :accessor class-defstruct-constructor) - (from-defclass-p + :initarg :fast-function ;no writer + :reader method-fast-function) + (documentation :initform nil - :initarg :from-defclass-p))) - -(defclass specializer-with-object (specializer) ()) - -(defclass exact-class-specializer (specializer) ()) + :initarg :documentation))) -(defclass class-eq-specializer (exact-class-specializer - specializer-with-object) - ((object :initarg :class - :reader specializer-class - :reader specializer-object))) +(defclass standard-accessor-method (standard-method) + ((slot-name :initform nil + :initarg :slot-name + :reader accessor-method-slot-name) + (slot-definition :initform nil + :initarg :slot-definition + :reader accessor-method-slot-definition))) -(defclass class-prototype-specializer (specializer-with-object) - ((object :initarg :class - :reader specializer-class - :reader specializer-object))) +(defclass standard-reader-method (standard-accessor-method) ()) +(defclass standard-writer-method (standard-accessor-method) ()) +;;; an extension, apparently. +(defclass standard-boundp-method (standard-accessor-method) ()) -(defclass eql-specializer (exact-class-specializer specializer-with-object) - ((object :initarg :object :reader specializer-object - :reader eql-specializer-object))) +(defclass method-combination (metaobject) + ((documentation + :reader method-combination-documentation + :initform nil + :initarg :documentation))) -(defvar *eql-specializer-table* (make-hash-table :test 'eql)) +(defclass standard-method-combination (definition-source-mixin + method-combination) + ((type + :reader method-combination-type + :initarg :type) + (options + :reader method-combination-options + :initarg :options))) -(defun intern-eql-specializer (object) - (or (gethash object *eql-specializer-table*) - (setf (gethash object *eql-specializer-table*) - (make-instance 'eql-specializer :object object)))) - -;;;; slot definitions +(defclass long-method-combination (standard-method-combination) + ((function + :initarg :function + :reader long-method-combination-function) + (args-lambda-list + :initarg :args-lambda-list + :reader long-method-combination-args-lambda-list))) -(defclass slot-definition (standard-object) +(defclass slot-definition (metaobject) ((name :initform nil :initarg :name @@ -598,126 +578,143 @@ effective-slot-definition) ()) -(defclass method (standard-object) ()) +(defclass specializer (metaobject) + ((type :initform nil :reader specializer-type))) + +(defclass specializer-with-object (specializer) ()) -(defclass standard-method (definition-source-mixin plist-mixin method) - ((generic-function +(defclass exact-class-specializer (specializer) ()) + +(defclass class-eq-specializer (exact-class-specializer + specializer-with-object) + ((object :initarg :class + :reader specializer-class + :reader specializer-object))) + +(defclass class-prototype-specializer (specializer-with-object) + ((object :initarg :class + :reader specializer-class + :reader specializer-object))) + +(defclass eql-specializer (exact-class-specializer specializer-with-object) + ((object :initarg :object :reader specializer-object + :reader eql-specializer-object))) + +(defvar *eql-specializer-table* (make-hash-table :test 'eql)) + +(defun intern-eql-specializer (object) + (or (gethash object *eql-specializer-table*) + (setf (gethash object *eql-specializer-table*) + (make-instance 'eql-specializer :object object)))) + +(defclass class (dependent-update-mixin + definition-source-mixin + specializer) + ((name :initform nil - :accessor method-generic-function) -;;; (qualifiers -;;; :initform () -;;; :initarg :qualifiers -;;; :reader method-qualifiers) - (specializers + :initarg :name + :accessor class-name) + (class-eq-specializer + :initform nil + :reader class-eq-specializer) + (direct-superclasses :initform () - :initarg :specializers - :reader method-specializers) - (lambda-list + :reader class-direct-superclasses) + ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and + ;; CONDITION-CLASSes are lazily computed whenever the subclass info + ;; becomes available, i.e. when the PCL class is created. + (direct-subclasses :initform () - :initarg :lambda-list - :reader method-lambda-list) - (function - :initform nil - :initarg :function) ;no writer - (fast-function + :reader class-direct-subclasses) + (direct-methods + :initform (cons nil nil)) + (predicate-name :initform nil - :initarg :fast-function ;no writer - :reader method-fast-function) + :reader class-predicate-name) (documentation :initform nil - :initarg :documentation))) - -(defclass standard-accessor-method (standard-method) - ((slot-name :initform nil - :initarg :slot-name - :reader accessor-method-slot-name) - (slot-definition :initform nil - :initarg :slot-definition - :reader accessor-method-slot-definition))) - -(defclass standard-reader-method (standard-accessor-method) ()) - -(defclass standard-writer-method (standard-accessor-method) ()) + :initarg :documentation) + (finalized-p + :initform nil + :reader class-finalized-p))) -(defclass standard-boundp-method (standard-accessor-method) ()) +(def!method make-load-form ((class class) &optional env) + ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably + ;; doesn't matter while all our environments are the same... + (declare (ignore env)) + (let ((name (class-name class))) + (unless (and name (eq (find-class name nil) class)) + (error "~@" + class)) + `(find-class ',name))) -(defclass generic-function (dependent-update-mixin - definition-source-mixin - funcallable-standard-object) - ((documentation - :initform nil - :initarg :documentation) - ;; We need to make a distinction between the methods initially set - ;; up by :METHOD options to DEFGENERIC and the ones set up later by - ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on - ;; an already-DEFGENERICed function clears the methods set by the - ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making - ;; this distinction seems a little kludgy, but it has the positive - ;; effect of making it so that loading a file a.lisp containing - ;; DEFGENERIC, then loading a second file b.lisp containing - ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp - ;; tends to leave the generic function in a state consistent with - ;; the most-recently-loaded state of a.lisp and b.lisp.) - (initial-methods +;;; The class PCL-CLASS is an implementation-specific common +;;; superclass of all specified subclasses of the class CLASS. +(defclass pcl-class (class) + ((class-precedence-list + :reader class-precedence-list) + ;; KLUDGE: see note in CPL-OR-NIL + (cpl-available-p + :reader cpl-available-p + :initform nil) + (can-precede-list :initform () - :accessor generic-function-initial-methods)) - (:metaclass funcallable-standard-class)) - -(defclass standard-generic-function (generic-function) - ((name - :initform nil - :initarg :name - :accessor generic-function-name) - (methods + :reader class-can-precede-list) + (incompatible-superclass-list :initform () - :accessor generic-function-methods - :type list) - (method-class - :initarg :method-class - :accessor generic-function-method-class) - (method-combination - :initarg :method-combination - :accessor generic-function-method-combination) - (declarations - ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies - ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning - ;; might be appropriate). - :initarg :declarations - :initarg :declare + :accessor class-incompatible-superclass-list) + (wrapper + :initform nil + :reader class-wrapper) + (prototype + :initform nil + :reader class-prototype))) + +(defclass slot-class (pcl-class) + ((direct-slots :initform () - :accessor generic-function-declarations) - (arg-info - :initform (make-arg-info) - :reader gf-arg-info) - (dfun-state + :accessor class-direct-slots) + (slots :initform () - :accessor gf-dfun-state)) - (:metaclass funcallable-standard-class) - (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) + :accessor class-slots))) -(defclass method-combination (standard-object) - ((documentation - :reader method-combination-documentation +;;; The class STD-CLASS is an implementation-specific common +;;; superclass of the classes STANDARD-CLASS and +;;; FUNCALLABLE-STANDARD-CLASS. +(defclass std-class (slot-class) + ()) + +(defclass standard-class (std-class) + ()) + +(defclass funcallable-standard-class (std-class) + ()) + +(defclass forward-referenced-class (pcl-class) ()) + +(defclass built-in-class (pcl-class) ()) + +(defclass condition-class (slot-class) ()) + +(defclass structure-class (slot-class) + ((defstruct-form + :initform () + :accessor class-defstruct-form) + (defstruct-constructor + :initform nil + :accessor class-defstruct-constructor) + (from-defclass-p :initform nil - :initarg :documentation))) + :initarg :from-defclass-p))) -(defclass standard-method-combination (definition-source-mixin - method-combination) - ((type - :reader method-combination-type - :initarg :type) - (options - :reader method-combination-options - :initarg :options))) +(defclass definition-source-mixin (standard-object) + ((source :initform *load-pathname* :reader definition-source + :initarg :definition-source))) -(defclass long-method-combination (standard-method-combination) - ((function - :initarg :function - :reader long-method-combination-function) - (args-lambda-list - :initarg :args-lambda-list - :reader long-method-combination-args-lambda-list))) +(defclass plist-mixin (standard-object) + ((plist :initform () :accessor object-plist))) + +(defclass dependent-update-mixin (plist-mixin) ()) (defparameter *early-class-predicates* '((specializer specializerp) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ef7c7c2..783cb88 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -818,7 +818,7 @@ (update-initargs class (compute-default-initargs class)) (update-ctors 'finalize-inheritance :class class)) (unless finalizep - (dolist (sub (class-direct-subclasses class)) + (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))) (define-condition cpl-protocol-violation (reference-condition error) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 3c3ae3e..7b33665 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -434,7 +434,7 @@ ((scforfsc-slot :initarg :scforfsc-slot :accessor scforfsc-slot))) (defvar *standard-class-for-fsc* (make-instance 'standard-class-for-fsc :scforfsc-slot 1)) -(defclass fsc-with-standard-class-superclass +(defclass fsc-with-standard-class-superclass (standard-class-for-fsc funcallable-standard-object) ((fsc-slot :initarg :fsc-slot :accessor fsc-slot)) (:metaclass funcallable-standard-class)) diff --git a/tests/mop.pure.lisp b/tests/mop.pure.lisp index 5cb1167..f7a5e33 100644 --- a/tests/mop.pure.lisp +++ b/tests/mop.pure.lisp @@ -23,3 +23,10 @@ (assert (find (find-class 'standard-object) (sb-mop:class-direct-superclasses (find-class 'sb-mop:funcallable-standard-object)))) + +(dolist (name '(sb-mop:generic-function + sb-mop:method sb-mop:method-combination + sb-mop:slot-definition sb-mop:specializer)) + (assert (find (find-class 'sb-mop:metaobject) + (sb-mop:class-direct-superclasses (find-class name)))) + (assert (subtypep name 'sb-mop:metaobject))) diff --git a/version.lisp-expr b/version.lisp-expr index 7bd2bb9..67c9914 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.4.56" +"0.9.4.57" -- 1.7.10.4