From 6c296da561efd25c22e051a1e55080d9689f3ecc Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 9 Sep 2013 12:42:30 +0100 Subject: [PATCH] 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). --- NEWS | 6 +++++- src/pcl/ctor.lisp | 6 +++--- tests/clos.impure.lisp | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 42 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index 6c1f71e..dcf1994 100644 --- 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 --- 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 --- 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 -- 1.7.10.4