[Sbcl-commits] CVS: sbcl/src/pcl defcombin.lisp,1.16,1.17 std-class.lisp,1.34,1.35

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv31455/src/pcl

Modified Files:
	defcombin.lisp std-class.lisp 
Log Message:
0.7.9.58:
	Some more error-checking at DEFCLASS
	... duplicate :METACLASS, :DEFAULT-INITARGS options
	... :READER and :INITARG options to slots must be symbols
	Fix up error messages
	... add some spaces to previous commit
	... CLASS is not what you think it is in ENSURE-CLASS-VALUES


Index: defcombin.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defcombin.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- defcombin.lisp	19 Nov 2002 16:00:21 -0000	1.16
+++ defcombin.lisp	19 Nov 2002 19:02:15 -0000	1.17
@@ -385,8 +385,8 @@
     ;; name of a &WHOLE parameter, if any.
     (when (member '&whole (rest args-lambda-list))
       (error 'simple-program-error
-	     :format-control "~@<The value of the :ARGUMENTS option of~
-                DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may~
+	     :format-control "~@<The value of the :ARGUMENTS option of ~
+                DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
                 only appear first in the lambda list.~:>"
 	     :format-arguments (list args-lambda-list)))
     (loop with state = 'required
@@ -472,4 +472,4 @@
 			 (t list))))
 	    (return (nconc (frob required nr nreq)
 			   (frob optional no nopt)
-			   values)))))
\ No newline at end of file
+			   values)))))

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- std-class.lisp	14 Nov 2002 11:31:52 -0000	1.34
+++ std-class.lisp	19 Nov 2002 19:02:15 -0000	1.35
@@ -382,34 +382,66 @@
     ;; 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 
+    (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
+	((endp direct-slots) nil)
+      (destructuring-bind (slot &rest more) direct-slots
+	(let ((slot-name (getf slot :name)))
+	  (when (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 codebase that are required to be
+	    ;; of type PROGRAM-ERROR.
+	    (error 'simple-program-error
+		   :format-control "~@<There is more than one direct slot ~
+                                   with name ~S.~:>"
+		   :format-arguments (list slot-name)))
+	  (do ((stuff slot (cddr stuff)))
+	      ((endp stuff) nil)
+	    (destructuring-bind (option value &rest more) stuff
+	      (cond
+		((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))))
+		      (not (eq unsupplied
+			       (getf more option unsupplied))))
+		 (error 'simple-program-error
+			:format-control "~@<Duplicate slot option ~S for ~
+                                        slot named ~S.~:>"
+			:format-arguments (list option slot-name)))
+		((and (eq option :readers)
+		      (notevery #'symbolp value))
+		 (error 'simple-program-error
+			:format-control "~@<Slot reader names for slot ~
+                                        named ~S must be symbols.~:>"
+			:format-arguments (list slot-name)))
+		((and (eq option :initargs)
+		      (notevery #'symbolp value))
+		 (error 'simple-program-error
+			:format-control "~@<Slot initarg names for slot ~
+                                        named ~S must be symbols.~:>"
+			:format-arguments (list 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-control "~@<Duplicate initialization argument ~
+                                    name ~S in :DEFAULT-INITARGS.~:>"
 		    :format-arguments (list name class)))
-    (loop (unless (remf initargs :metaclass) (return)))
+    (let ((metaclass 0)
+	  (default-initargs 0))
+      (do ((args initargs (cddr args)))
+	  ((endp args) nil)
+	(case (car args)
+	  (:metaclass
+	   (when (> (incf metaclass) 1)
+	     (error 'simple-program-error
+		    :format-control "~@<More than one :METACLASS ~
+                                    option specified.~:>")))
+	  (:direct-default-initargs
+	   (when (> (incf default-initargs) 1)
+	     (error 'simple-program-error
+		    :format-control "~@<More than one :DEFAULT-INITARGS ~
+                                    option specified.~:>"))))))
+    (remf initargs :metaclass)
     (loop (unless (remf initargs :direct-superclasses) (return)))
     (loop (unless (remf initargs :direct-slots) (return)))
     (values meta