From: Nikodemus S. <nik...@ra...> - 2011-03-04 08:17:29
|
1.0.46.24: fix MAKE-INSTANCE regression from 1.0.45.19 lp#728650 We cannot use an optimized CTOR if there is an :AROUND method potentially supplying initialization arguments via CALL-NEXT-METHOD. So: * Add SIMPLE-NEXT-METHOD-CALL slot to STANDARD-METHOD: initialize it to T iff the method doesn't use CALL-NEXT-METHOD at all, or only as (CALL-NEXT-METHOD). * Allow an optimized CTOR in the presence of INITIALIZE-INSTANCE :AROUND methods iff those methods only contain simple forms of CALL-NEXT-METHOD. Index: NEWS =================================================================== RCS file: /cvsroot/sbcl/sbcl/NEWS,v retrieving revision 1.1888 diff -u -r1.1888 NEWS --- NEWS 2 Mar 2011 09:40:22 -0000 1.1888 +++ NEWS 4 Mar 2011 08:15:57 -0000 @@ -26,6 +26,8 @@ * bug fix: SLOT-BOUNDP information is correct during MAKE-INSTANCE in the presence of (SETF SLOT-VALUE-USING-CLASS) and SLOT-BOUNDP-USING-CLASS methods. (regression from 1.0.45.18) + * bug fix: INITIALIZE-INSTANCE :AROUND methods supplying initargs via + CALL-NEXT-METHOD work correctly. (regression from 1.0.45.19) * bug fix: several foreign functions accepting string also accepted NIL and consequently caused a memory fault at 0 now signal a type-error instead. (lp#721087) Index: version.lisp-expr =================================================================== RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v retrieving revision 1.5208 diff -u -r1.5208 version.lisp-expr --- version.lisp-expr 3 Mar 2011 20:01:37 -0000 1.5208 +++ version.lisp-expr 4 Mar 2011 08:15:57 -0000 @@ -20,4 +20,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".) -"1.0.46.23" +"1.0.46.24" Index: src/pcl/boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.164 diff -u -r1.164 boot.lisp --- src/pcl/boot.lisp 20 Feb 2011 10:27:39 -0000 1.164 +++ src/pcl/boot.lisp 4 Mar 2011 08:15:58 -0000 @@ -706,7 +706,7 @@ (simple-lexical-method-functions (,lambda-list .method-args. .next-methods. :call-next-method-p - ,call-next-method-p + ,(when call-next-method-p t) :next-method-p-p ,next-method-p-p :setq-p ,setq-p :parameters-setqd ,parameters-setqd @@ -723,6 +723,8 @@ %parameter-binding-modified)) ,@walked-lambda-body)))) `(,@(when call-next-method-p `(method-cell ,method-cell)) + ,@(when (member call-next-method-p '(:simple nil)) + '(simple-next-method-call t)) ,@(when plist `(plist ,plist)) ,@(when documentation `(:documentation ,documentation))))))))))) @@ -1463,7 +1465,9 @@ ;; like :LOAD-TOPLEVEL. ((not (listp form)) form) ((eq (car form) 'call-next-method) - (setq call-next-method-p t) + (setq call-next-method-p (if (cdr form) + t + :simple)) form) ((eq (car form) 'next-method-p) (setq next-method-p-p t) Index: src/pcl/ctor.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/ctor.lisp,v retrieving revision 1.47 diff -u -r1.47 ctor.lisp --- src/pcl/ctor.lisp 28 Feb 2011 08:57:19 -0000 1.47 +++ src/pcl/ctor.lisp 4 Mar 2011 08:15:59 -0000 @@ -545,7 +545,7 @@ '(:instance :class))) (class-slots class)) (not maybe-invalid-initargs) - (not (nonstandard-primary-method-p + (not (hairy-around-or-nonstandard-primary-method-p ii-methods *the-system-ii-method*)) (not (around-or-nonstandard-primary-method-p si-methods *the-system-si-method*))) @@ -569,14 +569,16 @@ when (null qualifiers) do (setq primary-checked-p t))) -(defun nonstandard-primary-method-p +(defun hairy-around-or-nonstandard-primary-method-p (methods &optional standard-method) (loop with primary-checked-p = nil for method in methods as qualifiers = (if (consp method) (early-method-qualifiers method) (safe-method-qualifiers method)) - when (or (and (null qualifiers) + when (or (and (eq :around (car qualifiers)) + (not (simple-next-method-call-p method))) + (and (null qualifiers) (not primary-checked-p) (not (null standard-method)) (not (eq standard-method method)))) Index: src/pcl/defs.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v retrieving revision 1.73 diff -u -r1.73 defs.lisp --- src/pcl/defs.lisp 20 Feb 2011 11:48:51 -0000 1.73 +++ src/pcl/defs.lisp 4 Mar 2011 08:15:59 -0000 @@ -377,7 +377,13 @@ :reader method-specializers) (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list) (%function :initform nil :initarg :function :reader method-function) - (%documentation :initform nil :initarg :documentation))) + (%documentation :initform nil :initarg :documentation) + ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or + ;; just a plain (CALL-NEXT-METHOD). + (simple-next-method-call + :initform nil + :initarg simple-next-method-call + :reader simple-next-method-call-p))) (defclass accessor-method (standard-method) ((slot-name :initform nil :initarg :slot-name Index: tests/ctor.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/ctor.impure.lisp,v retrieving revision 1.10 diff -u -r1.10 ctor.impure.lisp --- tests/ctor.impure.lisp 28 Feb 2011 08:57:19 -0000 1.10 +++ tests/ctor.impure.lisp 4 Mar 2011 08:15:59 -0000 @@ -273,5 +273,33 @@ (assert (equal "b" (sneaky-b i))) (assert (equal "c" (sneaky-c i))))))) +(defclass bug-728650-base () + ((value + :initarg :value + :initform nil))) + +(defmethod initialize-instance :after ((instance bug-728650-base) &key) + (with-slots (value) instance + (unless value + (error "Impossible! Value slot not initialized in ~S" instance)))) + +(defclass bug-728650-child-1 (bug-728650-base) + ()) + +(defmethod initialize-instance :around ((instance bug-728650-child-1) &rest initargs &key) + (apply #'call-next-method instance :value 'provided-by-child-1 initargs)) + +(defclass bug-728650-child-2 (bug-728650-base) + ()) + +(defmethod initialize-instance :around ((instance bug-728650-child-2) &rest initargs &key) + (let ((foo (make-instance 'bug-728650-child-1))) + (apply #'call-next-method instance :value foo initargs))) + +(with-test (:name :bug-728650) + (let ((child1 (slot-value (make-instance 'bug-728650-child-2) 'value))) + (assert (typep child1 'bug-728650-child-1)) + (assert (eq 'provided-by-child-1 (slot-value child1 'value))))) + ;;;; success |