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

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 2fc6eba..4306079 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -41,22 +41,22 @@
            class initargs
            (append (compute-applicable-methods
                     #'allocate-instance (list class))
-                   (compute-applicable-methods 
+                   (compute-applicable-methods
                     #'initialize-instance (list class-proto))
-                   (compute-applicable-methods 
+                   (compute-applicable-methods
                     #'shared-initialize (list class-proto t)))))))
     (let ((instance (apply #'allocate-instance class initargs)))
       (apply #'initialize-instance instance initargs)
       instance)))
 
 (defmethod default-initargs ((class slot-class)
-			     supplied-initargs
-			     class-default-initargs)
-  (loop for (key fn) in class-default-initargs
+                             supplied-initargs
+                             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))))
+          (return (append supplied-initargs default-initargs))))
 
 (defmethod initialize-instance ((instance slot-object) &rest initargs)
   (apply #'shared-initialize instance t initargs))
@@ -68,36 +68,33 @@
   (apply #'shared-initialize instance nil initargs)
   instance)
 
-(defmethod update-instance-for-different-class ((previous std-object)
-						(current std-object)
-						&rest initargs)
+(defmethod update-instance-for-different-class
+    ((previous standard-object) (current standard-object) &rest initargs)
   ;; First we must compute the newly added slots. The spec defines
   ;; newly added slots as "those local slots for which no slot of
   ;; the same name exists in the previous class."
   (let ((added-slots '())
-	(current-slotds (class-slots (class-of current)))
-	(previous-slot-names (mapcar #'slot-definition-name
-				     (class-slots (class-of previous)))))
+        (current-slotds (class-slots (class-of current)))
+        (previous-slot-names (mapcar #'slot-definition-name
+                                     (class-slots (class-of previous)))))
     (dolist (slotd current-slotds)
       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
-	       (eq (slot-definition-allocation slotd) :instance))
-	  (push (slot-definition-name slotd) added-slots)))
+               (eq (slot-definition-allocation slotd) :instance))
+          (push (slot-definition-name slotd) added-slots)))
     (check-initargs-1
      (class-of current) initargs
      (list (list* 'update-instance-for-different-class previous current initargs)
-	   (list* 'shared-initialize current added-slots initargs)))
+           (list* 'shared-initialize current added-slots initargs)))
     (apply #'shared-initialize current added-slots initargs)))
 
-(defmethod update-instance-for-redefined-class ((instance std-object)
-						added-slots
-						discarded-slots
-						property-list
-						&rest initargs)
+(defmethod update-instance-for-redefined-class
+    ((instance standard-object) added-slots discarded-slots property-list
+     &rest initargs)
   (check-initargs-1
    (class-of instance) initargs
    (list (list* 'update-instance-for-redefined-class
-		instance added-slots discarded-slots property-list initargs)
-	 (list* 'shared-initialize instance added-slots initargs)))
+                instance added-slots discarded-slots property-list initargs)
+         (list* 'shared-initialize instance added-slots initargs)))
   (apply #'shared-initialize instance added-slots initargs))
 
 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
@@ -111,78 +108,83 @@
          (initialize-slot-from-initfunction (class instance slotd)
            ;; CLHS: If a before method stores something in a slot,
            ;; that slot won't be initialized from its :INITFORM, if any.
-	   (if (typep instance 'structure-object)
-	       (when (eq (funcall
-			  ;; not SLOT-VALUE-USING-CLASS, as that
-			  ;; throws an error if the value is the
-			  ;; unbound marker.
-			  (slot-definition-internal-reader-function slotd)
-			  instance)
-			 +slot-unbound+)
-		 (setf (slot-value-using-class class instance slotd)
-		       (let ((initfn (slot-definition-initfunction slotd)))
-			 (when initfn
-			   (funcall initfn)))))
-	       (unless (or (slot-boundp-using-class class instance slotd)
-			   (null (slot-definition-initfunction slotd)))
-		 (setf (slot-value-using-class class instance slotd)
-		       (funcall (slot-definition-initfunction slotd)))))))
+           (if (typep instance 'structure-object)
+               (when (eq (funcall
+                          ;; not SLOT-VALUE-USING-CLASS, as that
+                          ;; throws an error if the value is the
+                          ;; unbound marker.
+                          (slot-definition-internal-reader-function slotd)
+                          instance)
+                         +slot-unbound+)
+                 (setf (slot-value-using-class class instance slotd)
+                       (let ((initfn (slot-definition-initfunction slotd)))
+                         (when initfn
+                           (funcall initfn)))))
+               (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))
            (initfn-slotds
             (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.
 (defun check-initargs-1 (class initargs call-list
-			 &optional (plist-p t) (error-p t))
+                         &optional (plist-p t) (error-p t))
   (multiple-value-bind (legal allow-other-keys)
       (check-initargs-values class call-list)
     (unless allow-other-keys
       (if plist-p
-	  (check-initargs-2-plist initargs class legal error-p)
-	  (check-initargs-2-list initargs class legal error-p)))))
+          (check-initargs-2-plist initargs class legal error-p)
+          (check-initargs-2-list initargs class legal error-p)))))
 
 (defun check-initargs-values (class call-list)
   (let ((methods (mapcan (lambda (call)
-			   (if (consp call)
-			       (copy-list (compute-applicable-methods
-					   (gdefinition (car call))
-					   (cdr call)))
-			       (list call)))
-			 call-list))
-	(legal (apply #'append (mapcar #'slot-definition-initargs
-				       (class-slots class)))))
+                           (if (consp call)
+                               (copy-list (compute-applicable-methods
+                                           (gdefinition (car call))
+                                           (cdr call)))
+                               (list call)))
+                         call-list))
+        (legal (apply #'append (mapcar #'slot-definition-initargs
+                                       (class-slots class)))))
     ;; Add to the set of slot-filling initargs the set of
     ;; initargs that are accepted by the methods. If at
     ;; any point we come across &allow-other-keys, we can
     ;; just quit.
     (dolist (method methods)
       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
-	  (analyze-lambda-list (if (consp method)
-				   (early-method-lambda-list method)
-				   (method-lambda-list method)))
-	(declare (ignore nreq nopt keysp restp))
-	(when allow-other-keys
-	  (return-from check-initargs-values (values nil t)))
-	(setq legal (append keys legal))))
+          (analyze-lambda-list (if (consp method)
+                                   (early-method-lambda-list method)
+                                   (method-lambda-list method)))
+        (declare (ignore nreq nopt keysp restp))
+        (when allow-other-keys
+          (return-from check-initargs-values (values nil t)))
+        (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.~:>"
-		     (length (initarg-error-initargs condition))
-		     (list (initarg-error-initargs condition))
-		     (initarg-error-class condition)))))
+             (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))
   (let ((invalid-keys ()))
@@ -190,12 +192,12 @@
       ;; 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)))
+        (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)))
+        (error 'initarg-error :class class :initargs invalid-keys)))
     invalid-keys))
 
 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
@@ -204,9 +206,9 @@
       ;; 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)))
+        (unless (memq key legal)
+          (push key invalid-keys)))
       (when (and invalid-keys error-p)
-	(error 'initarg-error :class class :initargs invalid-keys)))
+        (error 'initarg-error :class class :initargs invalid-keys)))
     invalid-keys))