X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=236fc867fd8a6c0ba19094edceae2d004fb10134;hb=22aec7852f4861e5dab28cc0d619c24b62590dad;hp=1a317628c190a42552953085ad262efa22b52af0;hpb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;p=sbcl.git

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 1a31762..236fc86 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -62,6 +62,9 @@
   (apply #'shared-initialize instance t initargs))
 
 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
+  ;; the ctor machinery allows us to track when memoization of
+  ;; validity of initargs should be cleared.
+  (check-ri-initargs instance initargs)
   (apply #'shared-initialize instance nil initargs)
   instance)
 
@@ -129,11 +132,15 @@
             (loop for slotd in (class-slots class)
                   unless (initialize-slot-from-initarg class instance slotd)
                     collect slotd)))
-      (loop for slotd in initfn-slotds
-            when (and (not (eq :class (slot-definition-allocation slotd)))
-                      (or (eq t slot-names)
-                          (memq (slot-definition-name slotd) slot-names))) do
-              (initialize-slot-from-initfunction class instance slotd)))
+      (dolist (slotd initfn-slotds)
+	(if (eq (slot-definition-allocation slotd) :class)
+	    (when (or (eq t slot-names)
+		      (memq (slot-definition-name slotd) slot-names))
+	      (unless (slot-boundp-using-class class instance slotd)
+		(initialize-slot-from-initfunction class instance slotd)))
+	    (when (or (eq t slot-names)
+		      (memq (slot-definition-name slotd) slot-names))
+	      (initialize-slot-from-initfunction class instance slotd)))))
     instance))
 
 ;;; If initargs are valid return nil, otherwise signal an error.
@@ -171,29 +178,39 @@
 	(setq legal (append keys legal))))
     (values legal nil)))
 
+(define-condition initarg-error (program-error)
+  ((class :reader initarg-error-class :initarg :class)
+   (initargs :reader initarg-error-initargs :initarg :initargs))
+  (:report (lambda (condition stream)
+	     (format stream "~@<Invalid initialization argument~P:~2I~_~
+                             ~<~{~S~^, ~}~@:>~I~_in call for class ~S.~:>"
+		     (length (initarg-error-initargs condition))
+		     (list (initarg-error-initargs condition))
+		     (initarg-error-class condition)))))
+
 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
-  (unless (getf initargs :allow-other-keys)
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (doplist (key val) initargs
-      (unless (memq key legal)
-	(if error-p
-	    (error 'simple-program-error
-		   :format-control "Invalid initialization argument ~S for class ~S"
-		   :format-arguments (list key (class-name class)))
-	    (return-from check-initargs-2-plist nil)))))
-  t)
+  (let ((invalid-keys ()))
+    (unless (getf initargs :allow-other-keys)
+      ;; Now check the supplied-initarg-names and the default initargs
+      ;; against the total set that we know are legal.
+      (doplist (key val) initargs
+	(unless (or (memq key legal)
+		    ;; :ALLOW-OTHER-KEYS NIL gets here
+		    (eq key :allow-other-keys))
+	  (push key invalid-keys)))
+      (when (and invalid-keys error-p)
+	(error 'initarg-error :class class :initargs invalid-keys)))
+    invalid-keys))
 
 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
-  (unless (memq :allow-other-keys initkeys)
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (dolist (key initkeys)
-      (unless (memq key legal)
-	(if error-p
-	    (error 'simple-program-error
-		   :format-control "Invalid initialization argument ~S for class ~S"
-		   :format-arguments (list key (class-name class)))
-	    (return-from check-initargs-2-list nil)))))
-  t)
+  (let ((invalid-keys ()))
+    (unless (memq :allow-other-keys initkeys)
+      ;; Now check the supplied-initarg-names and the default initargs
+      ;; against the total set that we know are legal.
+      (dolist (key initkeys)
+	(unless (memq key legal)
+	  (push key invalid-keys)))
+      (when (and invalid-keys error-p)
+	(error 'initarg-error :class class :initargs invalid-keys)))
+    invalid-keys))