From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Thu, 5 Aug 2004 16:47:23 +0000 (+0000)
Subject: 0.8.13.30:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=efea157110a4db2595f154234641b6768185c307;p=sbcl.git

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
--- 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
--- 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
--- 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)))
 
+;;; 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))
+
 ;;; success
 (sb-ext:quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 7df5dda..9de054a 100644
--- 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"