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
(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-#:
(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))
(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
;;; *******************************
(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*)
(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
(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)
(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 "~@<Invalid initialization argument~P:~2I~_~
+ ~<~{~S~^, ~}~@:>~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))
:EXCEPSIT-LEGACY-1201
:EXCEPSIT-LEGACY-1269
:EXCEPSIT-LEGACY-1273
- :EXCEPSIT-LEGACY-1277
:EXCEPSIT-LEGACY-1327
:EXCEPSIT-LEGACY-1357
:EXCEPSIT-LEGACY-1369
;;;; 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")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
;;; structure types defined earlier in the file.
;; specified.
(assert (char= (char (get-output-stream-string x) 0) #\1)))
\f
+;;; 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))
+\f
;;;; success
(sb-ext:quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff