X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=40a922a15d482c21d5c0953159b83adae2135883;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=2fc6eba1561be2f1837626a4a2b09512d7ca34a7;hpb=3d3ac32d4402ff3df488e69de7f05ca240cc67aa;p=sbcl.git

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 2fc6eba..40a922a 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -52,9 +52,9 @@
 (defmethod default-initargs ((class slot-class)
 			     supplied-initargs
 			     class-default-initargs)
-  (loop for (key fn) in class-default-initargs
+  (loop for (key nil fun) in class-default-initargs
         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
-	  append (list key (funcall fn)) into default-initargs
+	  append (list key (funcall fun)) into default-initargs
         finally
 	  (return (append supplied-initargs default-initargs))))
 
@@ -123,8 +123,8 @@
 		       (let ((initfn (slot-definition-initfunction slotd)))
 			 (when initfn
 			   (funcall initfn)))))
-	       (unless (or (slot-boundp-using-class class instance slotd)
-			   (null (slot-definition-initfunction slotd)))
+	       (unless (or (null (slot-definition-initfunction slotd))
+			   (slot-boundp-using-class class instance slotd))
 		 (setf (slot-value-using-class class instance slotd)
 		       (funcall (slot-definition-initfunction slotd)))))))
     (let* ((class (class-of instance))
@@ -132,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.
@@ -174,12 +178,13 @@
 	(setq legal (append keys legal))))
     (values legal nil)))
 
-(define-condition initarg-error (program-error)
+(define-condition initarg-error (reference-condition program-error)
   ((class :reader initarg-error-class :initarg :class)
    (initargs :reader initarg-error-initargs :initarg :initargs))
+  (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
   (:report (lambda (condition stream)
-	     (format stream "~@<Invalid initialization argument~P:~2I~_~
-                             ~<~{~S~^, ~}~@:>~I~_in call for class ~S.~:>"
+	     (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)))))