better ctor fallback-generators

The logic surrounding default-initargs in the presence of "hairy"
methods on make-instance and friends was not quite right, leading
to evaluation of the wrong things at the wrong times.  Patch by
Jan Moringen with extra test cases (lp#1179858).

diff --git a/NEWS b/NEWS
index 6c1f71e..dcf1994 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -20,7 +20,11 @@ changes relative to sbcl-1.1.11:
     (thanks to Stephan Frank, lp#1206191)
   * bug fix: sb-safepoint can now reliably handle signal interruptions of
     foreign code. (lp#1133018)
-  
+  * bug fix: the compiler-macro for MAKE-INSTANCE when emitting "fallback"
+    constructors no longer fails to merge actual and default initargs
+    (thanks to Jan Moringen, lp#1179858)
+  * bug fix: the compiler-macro for MAKE-INSTANCE when emitting "fallback"
+    constructors handles non-KEYWORD initialization arguments more correctly.
   
 changes in sbcl-1.1.11 relative to sbcl-1.1.10:
   * enhancement: support building the manual under texinfo version 5.

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 872447b..31fc178 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -604,7 +604,7 @@
   (declare (ignore ii-methods si-methods))
   (let ((class (ctor-class ctor))
         (lambda-list (make-ctor-parameter-list ctor))
-        (initargs (quote-plist-keys (ctor-initargs ctor))))
+        (initargs (ctor-initargs ctor)))
     (if use-make-instance
         `(lambda ,lambda-list
            (declare #.*optimize-speed*)
@@ -612,13 +612,13 @@
            ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
            ;; compilation of the constructor, hence avoiding the
            ;; possibility of endless recursion.
-           (make-instance ,class ,@initargs))
+           (make-instance ,class ,@(quote-plist-keys initargs)))
         (let ((defaults (class-default-initargs class)))
           (when defaults
             (setf initargs (ctor-default-initargs initargs defaults)))
           `(lambda ,lambda-list
              (declare #.*optimize-speed*)
-             (fast-make-instance ,class ,@initargs))))))
+             (fast-make-instance ,class ,@(quote-plist-keys initargs)))))))
 
 ;;; Not as good as the real optimizing generator, but faster than going
 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 11c6323..0838bd6 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2032,4 +2032,38 @@
   (assert (eql (slot-value (make-1099708c-list-1) 'slot-1099708c-list)
                (slot-value (make-1099708c-list-2) 'slot-1099708c-list))))
 
+;;; bug-1179858
+
+;;; Define a class and force the "fallback" constructor generator to be
+;;; used by having a HAIRY-AROUND-OR-NONSTANDARD-PRIMARY-METHOD-P on
+;;; SHARED-INITIALIZE.
+(defclass bug-1179858 ()
+  ((foo :initarg :foo :reader bug-1179858-foo))
+  (:default-initargs :foo (error "Should not be evaluated")))
+(defmethod shared-initialize :around ((instance bug-1179858) (slot-names t) &key)
+  (call-next-method))
+
+(with-test (:name (make-instance :fallback-generator-initarg-handling
+                   :bug-1179858))
+  ;; Now compile a lambda containing MAKE-INSTANCE to exercise the
+  ;; fallback constructor generator. Call the resulting compiled
+  ;; function to trigger the bug.
+  (funcall (compile nil '(lambda () (make-instance 'bug-1179858 :foo t)))))
+
+;;; Other brokenness, found while investigating: fallback-generator
+;;; handling of non-keyword initialization arguments
+(defclass bug-1179858b ()
+  ((foo :initarg foo :reader bug-1179858b-foo))
+  (:default-initargs foo 14))
+(defmethod shared-initialize :around ((instance bug-1179858b) (slot-names t) &key)
+  (call-next-method))
+
+(with-test (:name (make-instance :fallback-generator-non-keyword-initarg
+                   :bug-1179858))
+  (flet ((foo= (n i) (= (bug-1179858b-foo i) n)))
+    (assert
+     (foo= 14 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b))))))
+    (assert
+     (foo= 15 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b 'foo 15))))))))
+
 ;;;; success