X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=ed9995efb18727a2f79f87190b5c16cd03f1a27f;hb=8a55e8e2feb7fd0faaaed6d420beec97dade94e4;hp=0d0d1e207ec78c11b59dc4d63c0eddcfe67eee09;hpb=372989d837526e3100b364153d58181a2a563351;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 0d0d1e2..ed9995e 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -375,6 +375,40 @@
 		  *the-class-standard-class*)
 		 (t
 		  (class-of class)))))
+    ;; KLUDGE: It seemed to me initially that there ought to be a way
+    ;; of collecting all the erroneous problems in one go, rather than
+    ;; this way of solving the problem of signalling the errors that
+    ;; we are required to, which stops at the first bogus input.
+    ;; However, after playing around a little, I couldn't find that
+    ;; way, so I've left it as is, but if someone does come up with a
+    ;; better way... -- CSR, 2002-09-08
+    (loop for (slot . more) on (getf initargs :direct-slots)
+	  for slot-name = (getf slot :name)
+	  if (some (lambda (s) (eq slot-name (getf s :name))) more) 
+	  ;; FIXME: It's quite possible that we ought to define an
+	  ;; SB-INT:PROGRAM-ERROR function to signal these and other
+	  ;; errors throughout the code base that are required to be
+	  ;; of type PROGRAM-ERROR.
+	  do (error 'simple-program-error 
+		    :format-control "More than one direct slot with name ~S."
+		    :format-arguments (list slot-name))
+	  else 
+	  do (loop for (option value . more) on slot by #'cddr
+		   when (and (member option 
+				     '(:allocation :type 
+				       :initform :documentation))
+			     (not (eq unsupplied
+				      (getf more option unsupplied)))) 
+		   do (error 'simple-program-error 
+			     :format-control "Duplicate slot option ~S for slot ~S."
+			     :format-arguments (list option slot-name))))
+    (loop for (initarg . more) on (getf initargs :direct-default-initargs)
+	  for name = (car initarg) 
+	  when (some (lambda (a) (eq (car a) name)) more) 
+	  do (error 'simple-program-error 
+		    :format-control "Duplicate initialization argument ~
+                                     name ~S in :default-initargs of class ~A."
+		    :format-arguments (list name class)))
     (loop (unless (remf initargs :metaclass) (return)))
     (loop (unless (remf initargs :direct-superclasses) (return)))
     (loop (unless (remf initargs :direct-slots) (return)))
@@ -426,7 +460,7 @@
   (setf (plist-value class 'class-slot-cells)
 	(let (collect)
 	  (dolist (dslotd direct-slots)
-	    (when (eq (slot-definition-allocation dslotd) class)
+	    (when (eq :class (slot-definition-allocation dslotd))
 	      (let ((initfunction (slot-definition-initfunction dslotd)))
 		(push (cons (slot-definition-name dslotd)
 			       (if initfunction
@@ -465,13 +499,6 @@
 		  (lambda (dependent)
 		    (apply #'update-dependent class dependent initargs))))
 
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
-				     slot-names &key)
-  (declare (ignore slot-names))
-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
-
 (defmethod shared-initialize :after ((slotd structure-slot-definition)
 				     slot-names
 				     &key (allocation :instance))
@@ -685,8 +712,9 @@
 	(class-slots    ()))
     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
-	(cond ((eq alloc :instance) (push eslotd instance-slots))
-	      ((classp alloc)       (push eslotd class-slots)))))
+	(case alloc
+          (:instance (push eslotd instance-slots))
+          (:class (push eslotd class-slots)))))
 
     ;; If there is a change in the shape of the instances then the
     ;; old class is now obsolete.
@@ -731,7 +759,7 @@
   (let (collect)
     (dolist (eslotd eslotds)
       (push (assoc (slot-definition-name eslotd)
-                   (class-slot-cells (slot-definition-allocation eslotd)))
+                   (class-slot-cells (slot-definition-class eslotd)))
             collect))
     (nreverse collect)))
 
@@ -828,8 +856,9 @@
 	(class-slots    ()))
     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
-	(cond ((eq alloc :instance) (push eslotd instance-slots))
-	      ((classp alloc)       (push eslotd class-slots)))))
+	(case alloc
+          (:instance (push eslotd instance-slots))
+          (:class (push eslotd class-slots)))))
     (let ((nlayout (compute-layout cpl instance-slots)))
       (dolist (eslotd instance-slots)
 	(setf (slot-definition-location eslotd)
@@ -837,7 +866,7 @@
     (dolist (eslotd class-slots)
       (setf (slot-definition-location eslotd)
 	    (assoc (slot-definition-name eslotd)
-		   (class-slot-cells (slot-definition-allocation eslotd)))))
+		   (class-slot-cells (slot-definition-class eslotd)))))
     (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))
 
@@ -970,9 +999,9 @@
   (let ((method (get-method generic-function () (list class) nil)))
     (when method (remove-method generic-function method))))
 
-;;; make-reader-method-function and make-write-method function are NOT part of
-;;; the standard protocol. They are however useful, PCL makes uses makes use
-;;; of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
+;;; part of the standard protocol. They are however useful, PCL makes
+;;; use of them internally and documents them for PCL users.
 ;;;
 ;;; *** This needs work to make type testing by the writer functions which
 ;;; *** do type testing faster. The idea would be to have one constructor
@@ -980,7 +1009,7 @@
 ;;;
 ;;; *** There is a subtle bug here which is going to have to be fixed.
 ;;; *** Namely, the simplistic use of the template has to be fixed. We
-;;; *** have to give the optimize-slot-value method the user might have
+;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
 ;;; *** defined for this metaclass a chance to run.
 
 (defmethod make-reader-method-function ((class slot-class) slot-name)