Steel Bank Common Lisp

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