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.

diff --git a/NEWS b/NEWS
index 25c86ad..7d57df6 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))))
+
 \f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 178383f..3c1144c 100644 (file)
--- 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"