0.8.0.46:

[sbcl.git] / src / pcl / init.lisp

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 1a31762..236fc86 100644 (file)
--- 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))
 \f
 ;;; 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))