1.0.14.7: quote non-keyword :default-initargs keys in SLOT-INIT-FORMS

 * Reported and diagnosed by Matt Marjanovic.

diff --git a/NEWS b/NEWS
index e3a7516..972c084 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,9 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14:
   * bug fix: SORT was not interrupt safe.
   * bug fix: XREF accounts for the last node of each basic-block as
     well.
+  * bug fix: MAKE-INSTANCE optimizations interacted badly with
+    non-keyword :DEFAULT-INITARGS in the presence of :BEFORE/:AFTER
+    methods on SHARED-INITIALIZE. (thanks to Matt Marjanovic)
 
 changes in sbcl-1.0.14 relative to sbcl-1.0.13:
   * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 712c0ef..0bd3973 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -531,16 +531,16 @@
       ;; initargs, that is, their values must be evaluated even
       ;; if not actually used for initializing a slot.
       (loop for (key initform initfn) in default-initargs and i from 0
-            unless (member key initkeys :test #'eq) do
-            (let* ((kind (if (constantp initform) 'constant 'var))
-                   (init (if (eq kind 'var) initfn initform)))
-              (ecase kind
-                (constant
-                 (push key defaulting-initargs)
-                 (push initform defaulting-initargs))
-                (var
-                 (push key defaulting-initargs)
-                 (push (default-init-var-name i) defaulting-initargs)))
+            unless (member key initkeys :test #'eq)
+            do (let* ((kind (if (constantp initform) 'constant 'var))
+                      (init (if (eq kind 'var) initfn initform)))
+                 (ecase kind
+                   (constant
+                    (push (list 'quote key) defaulting-initargs)
+                    (push initform defaulting-initargs))
+                   (var
+                    (push (list 'quote key) defaulting-initargs)
+                    (push (default-init-var-name i) defaulting-initargs)))
               (when (eq kind 'var)
                 (let ((init-var (default-init-var-name i)))
                   (setq init init-var)

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 9dbd83f..174e328 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1607,5 +1607,17 @@
             (declare (bug-402-d x))
             x))))
 
+;;;; non-keyword :default-initargs + :before method on shared initialize
+;;;; interacted badly with CTOR optimizations
+(defclass ctor-default-initarg-problem ()
+  ((slot :initarg slotto))
+  (:default-initargs slotto 123))
+(defmethod shared-initialize :before ((instance ctor-default-initarg-problem) slot-names &rest initargs)
+  (format t "~&Rock on: ~A~%" initargs))
+(defun provoke-ctor-default-initarg-problem ()
+  (make-instance 'ctor-default-initarg-problem))
+(handler-bind ((warning #'error))
+  (assert (= 123 (slot-value (provoke-ctor-default-initarg-problem) 'slot))))
+
 \f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 0cacfe1..1f839d8 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".)
-"1.0.14.6"
+"1.0.14.7"