From 09702467ab16baab34dc209606d9d07af38eaedd Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 22 Aug 2006 13:23:41 +0000 Subject: [PATCH] 0.9.15.45: Make ENSURE-CLASS and ENSURE-GENERIC-FUNCTION do what AMOP says regarding the :METACLASS and :GENERIC-FUNCTION-CLASS default arguments. I don't like it, but that's what it says, and as Bruno points out on sbcl-devel, no default is right in all circumstances. ... we didn't call ENSURE-CLASS ourselves except as part of DEFCLASS' expansion; we did call ENSURE-GENERIC-FUNCTION, so arrange to call it only when necessary and only with the right :generic-function-class argument. ... while we're at it, fix a bug in ENSURE-CLASS, which got the metaclass wrong if the argument was provided more than once. ... document one or two more small MOP deviations in the manual. --- doc/manual/beyond-ansi.texinfo | 25 ++++++++++++++++ src/pcl/boot.lisp | 13 ++++++--- src/pcl/braid.lisp | 4 +-- src/pcl/defclass.lisp | 2 +- src/pcl/generic-functions.lisp | 2 ++ src/pcl/methods.lisp | 48 +++++++++--------------------- src/pcl/std-class.lisp | 63 +++++++++++++++++----------------------- tests/mop.impure.lisp | 7 +++++ version.lisp-expr | 2 +- 9 files changed, 88 insertions(+), 78 deletions(-) diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 93929ec..bbddfd5 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -118,6 +118,13 @@ The following definition is acceptable: @end lisp and leads to a class whose instances are funcallable and have one slot. +@tindex funcallable-standard-object +@tindex sb-mop:funcallable-standard-object +Note that this requirement also applies to the class +@code{sb-mop:funcallable-standard-object}, which has metaclass +@code{sb-mop:funcallable-standard-class} rather than +@code{standard-class} as AMOP specifies. + @item the requirement that ``No portable class @math{C_p} may inherit, by virtue of being a direct or indirect subclass of a specified class, any @@ -156,6 +163,24 @@ for @code{slot-value-using-class} and @code{slot-boundp-using-class}. Note that application code may specialize on the @code{new-value} argument of slot accessors. +@item +@findex defclass +@findex ensure-class +@findex ensure-class-using-class +@findex sb-mop:ensure-class +@findex sb-mop:ensure-class-using-class +@findex find-class +@findex class-name +the class named by the @code{name} argument to @code{ensure-class}, if +any, is only redefined if it is the proper name of that class; +otherwise, a new class is created. + +This is consistent with the description of @code{ensure-class} in AMOP +as the functional version of @code{defclass}, which has this behaviour; +however, it is not consistent with the weaker requirement in AMOP, which +states that any class found by @code{find-class}, no matter what its +@code{class-name}, is redefined. + @end itemize @node Support For Unix diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index be9bfbd..6d60aee 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2014,11 +2014,12 @@ bootstrapping. fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function gf-class-p) + (generic-function-class 'standard-generic-function) &allow-other-keys) (real-ensure-gf-internal generic-function-class all-keys environment) - (unless (or (null gf-class-p) - (eq (class-of existing) generic-function-class)) + ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS, + ;; which is what makes the next line work + (unless (eq (class-of existing) generic-function-class) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) @@ -2200,7 +2201,11 @@ bootstrapping. specializers arglist &rest initargs) - (let* ((gf (ensure-generic-function generic-function-name)) + (let* (;; we don't need to deal with the :generic-function-class + ;; argument here because the default, + ;; STANDARD-GENERIC-FUNCTION, is right for all early generic + ;; functions. (See REAL-ADD-NAMED-METHOD) + (gf (ensure-generic-function generic-function-name)) (existing (dolist (m (early-gf-methods gf)) (when (and (equal (early-method-specializers m) specializers) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 00b4adc..7419297 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -425,8 +425,7 @@ (list class-name) (list class-name) "automatically generated boundp method"))) - (let ((gf (ensure-generic-function accessor-name - :lambda-list arglist))) + (let ((gf (ensure-generic-function accessor-name :lambda-list arglist))) (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test 'equal) @@ -589,6 +588,7 @@ (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) (pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) +;;; FIXME: only needed during bootstrap (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object))) (mlist (if (eq *boot-state* 'complete) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 045d847..85d0fc3 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -87,7 +87,7 @@ ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07 (eval defclass-form) (let* ((include (or (and direct-superclasses - (fix-super (car direct-superclasses))) + (find-class (car direct-superclasses) nil)) (and (not (eq name 'structure-object)) *the-class-structure-object*))) (defstruct-form (make-structure-class-defstruct-form diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index af9bc26..516ed6f 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -450,6 +450,8 @@ ;;;; &KEY arguments +;;; FIXME: make the declared &KEY arguments here agree with those that +;;; AMOP specifies. (defgeneric allocate-instance (class &rest initargs)) (defgeneric ensure-class-using-class (class diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index f488ae3..c395c7b 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -209,36 +209,14 @@ (initarg-error :method-combination "not supplied" "a method combination object"))))) - -#|| -(defmethod reinitialize-instance ((generic-function standard-generic-function) - &rest initargs - &key name - lambda-list - argument-precedence-order - declarations - documentation - method-class - method-combination) - (declare (ignore documentation declarations argument-precedence-order - lambda-list name method-class method-combination)) - (macrolet ((add-initarg (check name slot-name) - `(unless ,check - (push (slot-value generic-function ,slot-name) initargs) - (push ,name initargs)))) -; (add-initarg name :name 'name) -; (add-initarg lambda-list :lambda-list 'lambda-list) -; (add-initarg argument-precedence-order -; :argument-precedence-order -; 'argument-precedence-order) -; (add-initarg declarations :declarations 'declarations) -; (add-initarg documentation :documentation '%documentation) -; (add-initarg method-class :method-class 'method-class) -; (add-initarg method-combination :method-combination '%method-combination) - (apply #'call-next-method generic-function initargs))) -||# -;;; These two are scheduled for demolition. +(defun find-generic-function (name &optional (errorp t)) + (let ((fun (and (fboundp name) (fdefinition name)))) + (cond + ((and fun (typep fun 'generic-function)) fun) + (errorp (error "No generic function named ~S." name)) + (t nil)))) + (defun real-add-named-method (generic-function-name qualifiers specializers @@ -248,11 +226,13 @@ (typep (fdefinition generic-function-name) 'generic-function)) (style-warn "implicitly creating new generic function ~S" generic-function-name)) - ;; XXX What about changing the class of the generic function if - ;; there is one? Whose job is that, anyway? Do we need something - ;; kind of like CLASS-FOR-REDEFINITION? - (let* ((generic-function - (ensure-generic-function generic-function-name)) + (let* ((existing-gf (find-generic-function generic-function-name nil)) + (generic-function + (if existing-gf + (ensure-generic-function + generic-function-name + :generic-function-class (class-of existing-gf)) + (ensure-generic-function generic-function-name))) (specs (parse-specializers specializers)) (proto (method-prototype-for-gf generic-function-name)) (new (apply #'make-instance (class-of proto) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 8d9dde3..652b1bd 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -309,7 +309,7 @@ (defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) - (ensure-class-values class args) + (frob-ensure-class-args args) (setf class (apply #'make-instance meta :name name initargs)) (without-package-locks (setf (find-class name) class)) @@ -318,7 +318,7 @@ (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) (multiple-value-bind (meta initargs) - (ensure-class-values class args) + (frob-ensure-class-args args) (unless (eq (class-of class) meta) (apply #'change-class class meta initargs)) (apply #'reinitialize-instance class initargs) @@ -327,34 +327,29 @@ (set-class-type-translation class name) class)) -(defun fix-super (s) - (cond ((classp s) s) - ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) - (t - (or (find-class s nil) - (ensure-class s :metaclass 'forward-referenced-class))))) - -(defun ensure-class-values (class initargs) +(defun frob-ensure-class-args (args) (let (metaclass metaclassp reversed-plist) - (doplist (key val) initargs - (cond ((eq key :metaclass) - (setf metaclass val - metaclassp key)) - (t - (when (eq key :direct-superclasses) - (setf val (mapcar #'fix-super val))) - (setf reversed-plist (list* val key reversed-plist))))) - (values (cond (metaclassp - (if (classp metaclass) - metaclass - (find-class metaclass))) - ((or (null class) (forward-referenced-class-p class)) - *the-class-standard-class*) - (t - (class-of class))) - (nreverse reversed-plist)))) - + (flet ((frob-superclass (s) + (cond + ((classp s) s) + ((legal-class-name-p s) + (or (find-class s nil) + (ensure-class s :metaclass 'forward-referenced-class))) + (t (error "Not a class or a legal class name: ~S." s))))) + (doplist (key val) args + (cond ((eq key :metaclass) + (unless metaclassp + (setf metaclass val metaclassp key))) + (t + (when (eq key :direct-superclasses) + (setf val (mapcar #'frob-superclass val))) + (setf reversed-plist (list* val key reversed-plist))))) + (values (cond (metaclassp + (if (classp metaclass) + metaclass + (find-class metaclass))) + (t *the-class-standard-class*)) + (nreverse reversed-plist))))) (defmethod shared-initialize :after ((class std-class) slot-names &key @@ -703,17 +698,13 @@ (defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) (let ((gf (cond ((eq add/remove 'add) - (if (fboundp gfspec) - (without-package-locks - (ensure-generic-function gfspec)) + (or (find-generic-function gfspec nil) (ensure-generic-function gfspec :lambda-list (case r/w (r '(object)) (w '(new-value object)))))) - ((generic-function-p (and (fboundp gfspec) - (fdefinition gfspec))) - (without-package-locks - (ensure-generic-function gfspec)))))) + (t + (find-generic-function gfspec nil))))) (when gf (case r/w (r (if (eq add/remove 'add) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index d1b4172..765d222 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -513,4 +513,11 @@ (assert (subtypep class2 class1)) (assert (typep (make-instance class2) class1))) +;;; ensure-class got its treatment of :metaclass wrong. +(ensure-class 'better-be-standard-class :direct-superclasses '(standard-object) + :metaclass 'standard-class + :metaclass 'funcallable-standard-class) +(assert (eq (class-of (find-class 'better-be-standard-class)) + (find-class 'standard-class))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 0d6302a..6a171ab 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.15.44" +"0.9.15.45" -- 1.7.10.4