From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Fri, 31 Dec 2004 08:25:04 +0000 (+0000)
Subject: 0.8.18.3:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7c5138fcbdb302abc563a2060493f2f0304ae902;p=sbcl.git

0.8.18.3:
	Fix for invalid :default-initargs not being caught by ctor
	... disable ctor if any default-initarg keys are invalid
---

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 6ef5386..9e09462 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -90,6 +90,12 @@
 	 (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.
+(defun ctor-default-initkeys (supplied-initargs class-default-initargs)
+  (loop for (key nil) in class-default-initargs
+        when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
+        collect key))
 
 ;;; *****************
 ;;; CTORS   *********
@@ -317,8 +323,13 @@
 		      (member (slot-definition-allocation x)
 			      '(:instance :class)))
 		    (class-slots class))
-	     (null (check-initargs-1 class (plist-keys (ctor-initargs ctor))
-				     (append ii-methods si-methods) nil nil))
+	     (null (check-initargs-1
+                    class
+                    (append
+                     (ctor-default-initkeys
+                      (ctor-initargs ctor) (class-default-initargs class))
+                     (plist-keys (ctor-initargs ctor)))
+                    (append ii-methods si-methods) nil nil))
 	     (not (around-or-nonstandard-primary-method-p
 		   ii-methods *the-system-ii-method*))
 	     (not (around-or-nonstandard-primary-method-p
diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp
index 26dd594..e6a4f8b 100644
--- a/tests/clos.impure-cload.lisp
+++ b/tests/clos.impure-cload.lisp
@@ -119,6 +119,17 @@
 	    (declare (ignore x)) (setq y 'foo)))
   (style-warning (c) (error c)))
 
+;;; ctor optimization bugs:
+;;;
+;;; :DEFAULT-INITARGS not checked for validity
+(defclass invalid-default-initargs ()
+  ((foo :initarg :foo))
+  (:default-initargs :invalid-initarg 2))
+(multiple-value-bind (result condition)
+    (ignore-errors (make-instance 'invalid-default-initargs :foo 1))
+  (assert (null result))
+  (assert (typep condition 'program-error)))
+
 ;;; from Axel Schairer on cmucl-imp 2004-08-05
 (defclass class-with-symbol-initarg ()
   ((slot :initarg slot)))
diff --git a/version.lisp-expr b/version.lisp-expr
index b5b2fdd..3a0b01e 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".)
-"0.8.18.2"
+"0.8.18.3"