From 503ad9d8685b335a69dc667dec4ce48f1a03af98 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 4 Mar 2011 08:16:48 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ src/pcl/boot.lisp | 8 ++++++-- src/pcl/ctor.lisp | 8 +++++--- src/pcl/defs.lisp | 8 +++++++- tests/ctor.impure.lisp | 28 ++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 49 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index 25c86ad..7d57df6 100644 --- a/NEWS +++ b/NEWS @@ -26,6 +26,8 @@ changes relative to sbcl-1.0.46: * 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) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 3c9fe4f..17de4a4 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -706,7 +706,7 @@ bootstrapping. (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 @@ bootstrapping. %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 @@ bootstrapping. ;; 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) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index e360052..4237d1c 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -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)))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index a59dafe..2085f9e 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -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 diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index fed7e9b..f40e27b 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -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 diff --git a/version.lisp-expr b/version.lisp-expr index 178383f..3c1144c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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" -- 1.7.10.4