0.8.13.30:

	Fix bug in ctor optimization reported by Axel Schairer
	cmucl-help 2004-08-05:
	... quote the key initargs if we're going to call a :before
		or :after initialization method;
	... write a test case based on his example.

diff --git a/NEWS b/NEWS
index 7edd1d8..b4f79ae 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,9 @@ changes in sbcl-0.8.14 relative to sbcl-0.8.13:
   * bug fix: improve the detection and resolution of MOP metacycles
     (where effective method computation depends on the generic function
     having its effective method computed).  (reported by Bruno Haible)
+  * bug fix: pass the right initargs to :BEFORE or :AFTER methods on
+    SHARED-INITIALIZE or INITIALIZE-INSTANCE in optimized
+    MAKE-INSTANCE constructors.  (reported by Axel Schairer for cmucl)
   * optimization: in taking the GCD of bignums, reduce the two bignums
     to approximately the same size (using Euclid's algorithm) before
     applying the more sophisticated binary GCD.  (thanks to Juho

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 07d6069..6ef5386 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -62,6 +62,14 @@
 ;;; Utilities  *******
 ;;; ******************
 
+(defun quote-plist-keys (plist)
+  (loop for (key . more) on plist by #'cddr
+       if (null more) do
+         (error "Not a property list: ~S" plist)
+       else
+         collect `(quote ,key)
+         and collect (car more)))
+
 (defun plist-keys (plist &key test)
   (loop for (key . more) on plist by #'cddr
        if (null more) do
@@ -406,9 +414,11 @@
            (slot-inits (slot-init-forms ctor (or ii-before si-before))))
        (values
         `(let (,@(when (or ii-before ii-after)
-                  `((.ii-args. (list .instance. ,@initargs))))
+                  `((.ii-args.
+                     (list .instance. ,@(quote-plist-keys initargs)))))
                ,@(when (or si-before si-after)
-                  `((.si-args. (list .instance. t ,@initargs)))))
+                  `((.si-args.
+                     (list .instance. t ,@(quote-plist-keys initargs))))))
            ,@(loop for method in ii-before
                    collect `(invoke-method ,method .ii-args.))
            ,@(loop for method in si-before

diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp
index 46f83e6..26dd594 100644 (file)
--- a/tests/clos.impure-cload.lisp
+++ b/tests/clos.impure-cload.lisp
@@ -119,5 +119,21 @@
            (declare (ignore x)) (setq y 'foo)))
   (style-warning (c) (error c)))
 \f
+;;; from Axel Schairer on cmucl-imp 2004-08-05
+(defclass class-with-symbol-initarg ()
+  ((slot :initarg slot)))
+(defmethod initialize-instance :after
+    ((x class-with-symbol-initarg) &rest initargs &key &allow-other-keys)
+  (unless (or (null initargs)
+             (eql (getf initargs 'slot)
+                  (slot-value x 'slot)))
+    (error "bad bad bad")))
+(defun make-thing (arg)
+  (make-instance 'class-with-symbol-initarg 'slot arg))
+(defun make-other-thing (slot arg)
+  (make-instance 'class-with-symbol-initarg slot arg))
+(assert (eql (slot-value (make-thing 1) 'slot) 1))
+(assert (eql (slot-value (make-other-thing 'slot 2) 'slot) 2))
+\f
 ;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 7df5dda..9de054a 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,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".)
-"0.8.13.29"
+"0.8.13.30"