X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fctor.lisp;h=9e09462eeaceeec10346fc6a144a2a83993974e2;hb=7c5138fcbdb302abc563a2060493f2f0304ae902;hp=07d6069e185f983279d3ea8036c6034b83c06a17;hpb=039f48e07f16b55080c423872c3087928e1ff7a1;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 07d6069..9e09462 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -62,6 +62,14 @@
 ;;; Utilities  *******
 ;;; ******************
 
+(defun quote-plist-keys (plist)
+  (loop for (key . more) on plist by #'cddr
+	if (null more) do
+	  (error "Not a property list: ~S" plist)
+	else
+	  collect `(quote ,key)
+	  and collect (car more)))
+
 (defun plist-keys (plist &key test)
   (loop for (key . more) on plist by #'cddr
 	if (null more) do
@@ -82,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   *********
@@ -309,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
@@ -406,9 +425,11 @@
 	    (slot-inits (slot-init-forms ctor (or ii-before si-before))))
 	(values
 	 `(let (,@(when (or ii-before ii-after)
-	           `((.ii-args. (list .instance. ,@initargs))))
+	           `((.ii-args.
+		      (list .instance. ,@(quote-plist-keys initargs)))))
 	        ,@(when (or si-before si-after)
-		   `((.si-args. (list .instance. t ,@initargs)))))
+		   `((.si-args.
+		      (list .instance. t ,@(quote-plist-keys initargs))))))
 	    ,@(loop for method in ii-before
 		    collect `(invoke-method ,method .ii-args.))
 	    ,@(loop for method in si-before