From 619ee68faffc3990c5108611762ef54bf8cbbd1e Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 30 Dec 2002 00:42:27 +0000 Subject: [PATCH] 0.7.10.36: Clean up regressions, easy new bugs, etc. ... fix one or two embarrassing bugs in ctor MAKE-INSTANCE optimization patch: * REINITIALIZE-INSTANCE now checks arguments again * defining methods on MAKE-INSTANCE (or its siblings) now invalidates the optimized methods for subclasses too ... trivial ADJUST-ARRAY patch --- BUGS | 16 +--------- src/compiler/fndb.lisp | 2 +- src/pcl/ctor.lisp | 55 ++++++++++++++++++++++++++------- src/pcl/init.lisp | 55 ++++++++++++++++++++------------- tests/clocc-ansi-test-known-bugs.lisp | 1 - tests/clos.impure.lisp | 41 ++++++++++++++++++++++-- version.lisp-expr | 2 +- 7 files changed, 117 insertions(+), 55 deletions(-) diff --git a/BUGS b/BUGS index d023a79..225f4eb 100644 --- a/BUGS +++ b/BUGS @@ -1206,21 +1206,7 @@ WORKAROUND: (see usage of CONTINUATION-ASSERTED-TYPE in USE-RESULT-CONSTRAINTS) 234: - clocc-ansi-test :EXCEPSIT-LEGACY-1277 fails in sbcl-0.7.10.33 - - In sbcl-0.7.10.33 (but not ca. 0.7.10.29), - (defclass foo54 () ()) - (reinitialize-instance (make-instance 'foo54) :dummy 0) - does not signal an error. ANSI's definition of REINITIALIZE-INSTANCE - says - The system-supplied primary method for REINITIALIZE-INSTANCE signals - an error if an initarg is supplied that is not declared as valid. - and defines what that means in - 7.1.2 Declaring the Validity of Initialization Arguments - In effect, even though the signature shown for the REINITIALIZE-INSTANCE - gf in its ANSI definition page is &ALLOW-OTHER-KEYS, and that might - make it look as though anything goes, the gf+methods ensemble is required - to have more complicated &KEY-checking behavior than that. + (fixed in sbcl-0.7.10.36) DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 4852080..b624399 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -822,7 +822,7 @@ (defknown adjust-array (array (or index list) &key (:element-type type-specifier) - (:initial-element t) (:initial-contents list) + (:initial-element t) (:initial-contents t) (:fill-pointer t) (:displaced-to (or array null)) (:displaced-index-offset index)) array (unsafe)) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index dde1c3f..16f457b 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -287,8 +287,8 @@ (or (and (not (structure-class-p class)) (null (cdr make-instance-methods)) (null (cdr allocate-instance-methods)) - (check-initargs-1 class (plist-keys (ctor-initargs ctor)) - (append ii-methods si-methods) nil nil) + (null (check-initargs-1 class (plist-keys (ctor-initargs ctor)) + (append ii-methods si-methods) nil nil)) (not (around-or-nonstandard-primary-method-p ii-methods *the-system-ii-method*)) (not (around-or-nonstandard-primary-method-p @@ -556,30 +556,38 @@ ;;; ******************************* (defun update-ctors (reason &key class name generic-function method) - (flet ((reset-class-ctors (class) - (loop for ctor in (plist-value class 'ctors) do - (install-initial-constructor ctor)))) + (labels ((reset (class &optional ri-cache-p (ctorsp t)) + (when ctorsp + (dolist (ctor (plist-value class 'ctors)) + (install-initial-constructor ctor))) + (when ri-cache-p + (setf (plist-value class 'ri-initargs) ())) + (dolist (subclass (class-direct-subclasses class)) + (reset subclass ri-cache-p ctorsp)))) (ecase reason ;; ;; CLASS must have been specified. (finalize-inheritance - (reset-class-ctors class)) + (reset class t)) ;; ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* when (eq (ctor-class-name ctor) name) do (when (ctor-class ctor) - (reset-class-ctors (ctor-class ctor))) + (reset (ctor-class ctor))) (loop-finish))) ;; ;; GENERIC-FUNCTION and METHOD must have been specified. ((add-method remove-method) - (case (generic-function-name generic-function) - ((make-instance allocate-instance initialize-instance - shared-initialize) - (let ((type (first (method-specializers method)))) - (reset-class-ctors (type-class type))))))))) + (flet ((class-of-1st-method-param (method) + (type-class (first (method-specializers method))))) + (case (generic-function-name generic-function) + ((make-instance allocate-instance + initialize-instance shared-initialize) + (reset (class-of-1st-method-param method) t t)) + ((reinitialize-instance) + (reset (class-of-1st-method-param method) t nil)))))))) (defun precompile-ctors () (dolist (ctor *all-ctors*) @@ -588,4 +596,27 @@ (when (and class (class-finalized-p class)) (install-optimized-constructor ctor)))))) +(defun check-ri-initargs (instance initargs) + (let* ((class (class-of instance)) + (keys (plist-keys initargs)) + (cached (assoc keys (plist-value class 'ri-initargs) + :test #'equal)) + (invalid-keys + (if (consp cached) + (cdr cached) + (let ((invalid + ;; FIXME: give CHECK-INITARGS-1 and friends a + ;; more mnemonic name and (possibly) a nicer, + ;; more orthogonal interface. + (check-initargs-1 + class initargs + (list (list* 'reinitialize-instance instance initargs) + (list* 'shared-initialize instance nil initargs)) + t nil))) + (setf (plist-value class 'ri-initargs) + (acons keys invalid cached)) + invalid)))) + (when invalid-keys + (error 'initarg-error :class class :initargs invalid-keys)))) + ;;; end of ctor.lisp diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 1a31762..5fe2982 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -62,6 +62,9 @@ (apply #'shared-initialize instance t initargs)) (defmethod reinitialize-instance ((instance slot-object) &rest initargs) + ;; the ctor machinery allows us to track when memoization of + ;; validity of initargs should be cleared. + (check-ri-initargs instance initargs) (apply #'shared-initialize instance nil initargs) instance) @@ -171,29 +174,37 @@ (setq legal (append keys legal)))) (values legal nil))) +(define-condition initarg-error (program-error) + ((class :reader initarg-error-class :initarg :class) + (initargs :reader initarg-error-initargs :initarg :initargs)) + (:report (lambda (condition stream) + (format stream "~@~I~_in call for class ~S.~:>" + (length (initarg-error-initargs condition)) + (list (initarg-error-initargs condition)) + (initarg-error-class condition))))) + (defun check-initargs-2-plist (initargs class legal &optional (error-p t)) - (unless (getf initargs :allow-other-keys) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (doplist (key val) initargs - (unless (memq key legal) - (if error-p - (error 'simple-program-error - :format-control "Invalid initialization argument ~S for class ~S" - :format-arguments (list key (class-name class))) - (return-from check-initargs-2-plist nil))))) - t) + (let ((invalid-keys ())) + (unless (getf initargs :allow-other-keys) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (doplist (key val) initargs + (unless (memq key legal) + (push key invalid-keys))) + (when (and invalid-keys error-p) + (error 'initarg-error :class class :initargs invalid-keys))) + invalid-keys)) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) - (unless (memq :allow-other-keys initkeys) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (dolist (key initkeys) - (unless (memq key legal) - (if error-p - (error 'simple-program-error - :format-control "Invalid initialization argument ~S for class ~S" - :format-arguments (list key (class-name class))) - (return-from check-initargs-2-list nil))))) - t) + (let ((invalid-keys ())) + (unless (memq :allow-other-keys initkeys) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (dolist (key initkeys) + (unless (memq key legal) + (push key invalid-keys))) + (when (and invalid-keys error-p) + (error 'initarg-error :class class :initargs invalid-keys))) + invalid-keys)) diff --git a/tests/clocc-ansi-test-known-bugs.lisp b/tests/clocc-ansi-test-known-bugs.lisp index 3dfe47d..ad6aa37 100644 --- a/tests/clocc-ansi-test-known-bugs.lisp +++ b/tests/clocc-ansi-test-known-bugs.lisp @@ -137,7 +137,6 @@ :EXCEPSIT-LEGACY-1201 :EXCEPSIT-LEGACY-1269 :EXCEPSIT-LEGACY-1273 - :EXCEPSIT-LEGACY-1277 :EXCEPSIT-LEGACY-1327 :EXCEPSIT-LEGACY-1357 :EXCEPSIT-LEGACY-1369 diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 9041c40..41b2049 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -11,9 +11,11 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(defpackage "FOO" - (:use "CL")) -(in-package "FOO") +(load "assertoid.lisp") + +(defpackage "CLOS-IMPURE" + (:use "CL" "ASSERTOID")) +(in-package "CLOS-IMPURE") ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to ;;; structure types defined earlier in the file. @@ -518,5 +520,38 @@ ;; specified. (assert (char= (char (get-output-stream-string x) 0) #\1))) +;;; REINITIALIZE-INSTANCE, in the ctor optimization, wasn't checking +;;; for invalid initargs where it should: +(defclass class234 () ()) +(defclass subclass234 (class234) ()) +(defvar *bug234* 0) +(defun bug-234 () + (reinitialize-instance (make-instance 'class234) :dummy 0)) +(defun subbug-234 () + (reinitialize-instance (make-instance 'subclass234) :dummy 0)) +(assert (raises-error? (bug-234) program-error)) +(defmethod shared-initialize :after ((i class234) slots &key dummy) + (incf *bug234*)) +(assert (typep (subbug-234) 'subclass234)) +(assert (= *bug234* + ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE + 2)) + +;;; also, some combinations of MAKE-INSTANCE and subclassing missed +;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29): +(defclass class234-b1 () ()) +(defclass class234-b2 (class234-b1) ()) +(defvar *bug234-b* 0) +(defun bug234-b () + (make-instance 'class234-b2)) +(compile 'bug234-b) +(bug234-b) +(assert (= *bug234-b* 0)) +(defmethod initialize-instance :before ((x class234-b1) &rest args) + (declare (ignore args)) + (incf *bug234-b*)) +(bug234-b) +(assert (= *bug234-b* 1)) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 4c8ac87..1d8a468 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10.35" +"0.7.10.36" -- 1.7.10.4