From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 28 Jun 2009 10:55:52 +0000 (+0000)
Subject: 1.0.29.51: correctly compute default initargs for FAST-MAKE-INSTANCE
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=aa8cdb795d6bb551aaecb6db38d5ef6571c698ed;p=sbcl.git

1.0.29.51: correctly compute default initargs for FAST-MAKE-INSTANCE

* Ooops, can't use DEFAULT-INITARGS, since calling it executes the
  initforms. Define and use CTOR-DEFAULT-INITARGS.

* A better test-case.

* Reported by Leslie P. Polzer.
---

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 403732a..04daadf 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -97,12 +97,22 @@
          (and (symbolp constant)
               (not (null (symbol-package constant)))))))
 
-;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just
-;;; collecting the defaulted initargs for the call.
+;;; Somewhat akin to DEFAULT-INITARGS, but just collecting the defaulted
+;;; initargs for the call.
 (defun ctor-default-initkeys (supplied-initargs class-default-initargs)
   (loop for (key) in class-default-initargs
         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
         collect key))
+
+;;; Like DEFAULT-INITARGS, but return a list that can be spliced into source,
+;;; instead of a list with values already evaluated.
+(defun ctor-default-initargs (supplied-initargs class-default-initargs)
+  (loop for (key form fun) in class-default-initargs
+        when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
+        append (list key (if (constantp form) form `(funcall ,fun)))
+          into default-initargs
+        finally
+          (return (append supplied-initargs default-initargs))))
 
 ;;; *****************
 ;;; CTORS   *********
@@ -565,7 +575,7 @@
            (make-instance ,class ,@initargs))
         (let ((defaults (class-default-initargs class)))
           (when defaults
-            (setf initargs (default-initargs initargs defaults)))
+            (setf initargs (ctor-default-initargs initargs defaults)))
           `(lambda ,lambda-list
              (declare #.*optimize-speed*)
              (fast-make-instance ,class ,@initargs))))))
diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp
index 69daa7a..953314d 100644
--- a/tests/ctor.impure.lisp
+++ b/tests/ctor.impure.lisp
@@ -172,14 +172,16 @@
 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
 (defclass some-class ()
   ((aroundp :initform nil :reader aroundp))
-  (:default-initargs :x :success?))
+  (:default-initargs :x :success1))
+
 (defmethod initialize-instance :around ((some-class some-class) &key (x :fail?))
-  (unless (eq x :success?)
+  (unless (eq x :success1)
     (error "Default initarg lossage"))
   (setf (slot-value some-class 'aroundp) t)
   (when (next-method-p)
     (call-next-method)))
-(with-test (:name (make-instance :ctor-default-initargs))
+
+(with-test (:name (make-instance :ctor-default-initargs-1))
   (assert (aroundp (eval `(make-instance 'some-class))))
   (let ((fun (compile nil `(lambda () (make-instance 'some-class)))))
     (assert (aroundp (funcall fun)))
@@ -187,6 +189,33 @@
     (let ((ctor (find-callee fun :type 'sb-pcl::ctor)))
       (assert (find-callee ctor :name 'sb-pcl::fast-make-instance)))))
 
+;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
+;;; in more interesting cases as well...
+(defparameter *some-counter* 0)
+(let* ((x 'success2))
+  (defclass some-class2 ()
+    ((aroundp :initform nil :reader aroundp))
+    (:default-initargs :x (progn (incf *some-counter*) x))))
+
+(defmethod initialize-instance :around ((some-class some-class2) &key (x :fail2?))
+  (unless (eq x 'success2)
+    (error "Default initarg lossage"))
+  (setf (slot-value some-class 'aroundp) t)
+  (when (next-method-p)
+    (call-next-method)))
+
+(with-test (:name (make-instance :ctor-default-initargs-2))
+  (assert (= 0 *some-counter*))
+  (assert (aroundp (eval `(make-instance 'some-class2))))
+  (assert (= 1 *some-counter*))
+  (let ((fun (compile nil `(lambda () (make-instance 'some-class2)))))
+    (assert (= 1 *some-counter*))
+    (assert (aroundp (funcall fun)))
+    (assert (= 2 *some-counter*))
+    ;; make sure we tested what we think we tested...
+    (let ((ctor (find-callee fun :type 'sb-pcl::ctor)))
+      (assert (find-callee ctor :name 'sb-pcl::fast-make-instance)))))
+
 ;;; No compiler notes, please
 (locally (declare (optimize safety))
   (defclass type-check-thing ()
diff --git a/version.lisp-expr b/version.lisp-expr
index 8643e6a..634a70b 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".)
-"1.0.29.50"
+"1.0.29.51"