0.8.18.4:

	Pass defaulted initargs, not just present initargs, to methods
	on SHARED-INITIALIZE and INITIALIZE-INSTANCE in ctor.lisp
	... test, both for constant and variable initforms;
	... I wish I could remember who reported this bug where.

diff --git a/NEWS b/NEWS
index 601d7bd..4922f52 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,10 @@ changes in sbcl-0.8.19 relative to sbcl-0.8.18:
   * enhancement: saving cores with foreign code loaded is now
     supported on ppc/Darwin in addition to the previously supported
     platforms.
+  * bug fix: invalid :DEFAULT-INITARGS are detected in compiled calls
+    to MAKE-INSTANCE.
+  * bug fix: defaulted initargs are passed to INITIALIZE-INSTANCE and
+    SHARED-INITIALIZE methods from compiled calls to MAKE-INSTANCE.
 
 changes in sbcl-0.8.18 relative to sbcl-0.8.17:
   * new feature: reloading changed shared object files with

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9e09462..e783253 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -421,25 +421,28 @@
        (standard-sort-methods si-methods)
       (declare (ignore si-primary))
       (aver (and (null ii-around) (null si-around)))
-      (let ((initargs (ctor-initargs ctor))
-           (slot-inits (slot-init-forms ctor (or ii-before si-before))))
+      (let ((initargs (ctor-initargs ctor)))
+        (multiple-value-bind (bindings vars defaulting-initargs body)
+           (slot-init-forms ctor (or ii-before si-before))
        (values
-        `(let (,@(when (or ii-before ii-after)
-                  `((.ii-args.
-                     (list .instance. ,@(quote-plist-keys initargs)))))
-               ,@(when (or si-before si-after)
-                  `((.si-args.
-                     (list .instance. t ,@(quote-plist-keys initargs))))))
+         `(let ,bindings
+           (declare (ignorable ,@vars))
+           (let (,@(when (or ii-before ii-after)
+                     `((.ii-args.
+                        (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs))))
+                 ,@(when (or si-before si-after)
+                    `((.si-args.
+                        (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs)))))
            ,@(loop for method in ii-before
                    collect `(invoke-method ,method .ii-args.))
            ,@(loop for method in si-before
                    collect `(invoke-method ,method .si-args.))
-           ,slot-inits
+           ,@body
            ,@(loop for method in si-after
                    collect `(invoke-method ,method .si-args.))
            ,@(loop for method in ii-after
-                   collect `(invoke-method ,method .ii-args.)))
-        (or ii-before si-before))))))
+                   collect `(invoke-method ,method .ii-args.))))
+        (or ii-before si-before)))))))
 
 ;;; Return four values from APPLICABLE-METHODS: around methods, before
 ;;; methods, the applicable primary method, and applicable after
@@ -475,6 +478,7 @@
                      :initial-element nil))
         (class-inits ())
         (default-inits ())
+         (defaulting-initargs ())
         (default-initargs (class-default-initargs class))
         (initarg-locations
          (compute-initarg-locations
@@ -524,6 +528,13 @@
            unless (member key initkeys :test #'eq) do
            (let* ((type (if (constantp initform) 'constant 'var))
                   (init (if (eq type 'var) initfn initform)))
+              (ecase type
+                (constant
+                 (push key defaulting-initargs)
+                 (push initform defaulting-initargs))
+                (var
+                 (push key defaulting-initargs)
+                 (push (default-init-var-name i) defaulting-initargs)))
              (when (eq type 'var)
                (let ((init-var (default-init-var-name i)))
                  (setq init init-var)
@@ -587,10 +598,14 @@
                  collect var into vars
                  collect `(,var (funcall ,initfn)) into bindings
                  finally (return (values vars bindings)))
-         `(let ,bindings
+          ;; FIXME: adjust comment above!
+          (values bindings vars (nreverse defaulting-initargs)
+                  `(,@(delete nil instance-init-forms)
+                    ,@class-init-forms)))))))
+#|       `(let ,bindings
             (declare (ignorable ,@vars))
             ,@(delete nil instance-init-forms)
-            ,@class-init-forms))))))
+            ,@class-init-forms))))))|#
 
 ;;; Return an alist of lists (KEY LOCATION ...) telling, for each
 ;;; key in INITKEYS, which locations the initarg initializes.

diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp
index e6a4f8b..5b42736 100644 (file)
--- a/tests/clos.impure-cload.lisp
+++ b/tests/clos.impure-cload.lisp
@@ -129,6 +129,25 @@
     (ignore-errors (make-instance 'invalid-default-initargs :foo 1))
   (assert (null result))
   (assert (typep condition 'program-error)))
+;;; :DEFAULT-INITARGS not passed to INITIALIZE-INSTANCE or
+;;; SHARED-INITIALIZE :BEFORE methods.
+(defclass default-initargs-with-method ()
+  ((foo :initarg :valid-initarg))
+  (:default-initargs :valid-initarg 2))
+(defmethod shared-initialize :before ((thing default-initargs-with-method)
+                                     slot-names &key valid-initarg)
+  (assert (= valid-initarg 2)))
+(make-instance 'default-initargs-with-method)
+;;; and a test with a non-constant initarg
+(defvar *d-i-w-m-2* 0)
+(defclass default-initargs-with-method2 ()
+  ((foo :initarg :valid-initarg))
+  (:default-initargs :valid-initarg (incf *d-i-w-m-2*)))
+(defmethod shared-initialize :before ((thing default-initargs-with-method2)
+                                     slot-names &key valid-initarg)
+  (assert (= valid-initarg 1)))
+(make-instance 'default-initargs-with-method2)
+(assert (= *d-i-w-m-2* 1))
 \f
 ;;; from Axel Schairer on cmucl-imp 2004-08-05
 (defclass class-with-symbol-initarg ()

diff --git a/version.lisp-expr b/version.lisp-expr
index 3a0b01e..60b0206 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".)
-"0.8.18.3"
+"0.8.18.4"