[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp,1.69,1.70

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

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

Modified Files:
	boot.lisp 
Log Message:
0.8alpha.0.39:
	A couple more CLOS fixes:
	... make &OPTIONAL argument count checking less lax in methods
		(caught by pfdietz' MAKE-LOAD-FORM.ERROR.2)
	... make :ARGUMENT-PRECEDENCE-ORDER and :METHOD-COMBINATION 
		DEFGENERIC options do sanity checking on their arguments
		(:A-P-O caught by pfdietz' suite; :M-C 
		checking defensively installed :-)


Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -d -r1.69 -r1.70
--- boot.lisp	3 May 2003 18:29:07 -0000	1.69
+++ boot.lisp	19 May 2003 16:25:10 -0000	1.70
@@ -190,11 +190,32 @@
                                          is not allowed inside DEFGENERIC."
 			:format-arguments (list (cadr option))))
 	       (push (cadr option) (initarg :declarations)))
-	      ((:argument-precedence-order :method-combination)
-	       (if (initarg car-option)
-		   (duplicate-option car-option)
-		   (setf (initarg car-option)
-			 `',(cdr option))))
+	      (:method-combination
+	       (when (initarg car-option)
+		 (duplicate-option car-option))
+	       (unless (symbolp (cadr option))
+		 (error 'simple-program-error
+			:format-control "METHOD-COMBINATION name not a ~
+                                         symbol: ~S"
+			:format-arguments (list (cadr option))))
+	       (setf (initarg car-option)
+		     `',(cdr option)))
+	      (:argument-precedence-order
+	       (let* ((required (parse-lambda-list lambda-list))
+		      (supplied (cdr option)))
+		 (unless (= (length required) (length supplied))
+		   (error 'simple-program-error
+			  :format-control "argument count discrepancy in ~
+                                           :ARGUMENT-PRECEDENCE-ORDER clause."
+			  :format-arguments nil))
+		 (when (set-difference required supplied)
+		   (error 'simple-program-error
+			  :format-control "unequal sets for ~
+                                           :ARGUMENT-PRECEDENCE-ORDER clause: ~
+                                           ~S and ~S"
+			  :format-arguments (list required supplied)))
+		 (setf (initarg car-option)
+		       `',(cdr option))))
 	      ((:documentation :generic-function-class :method-class)
 	       (unless (proper-list-of-length-p option 2)
 		 (error "bad list length for ~S" option))
@@ -1173,8 +1194,14 @@
 		   (aux `(,var))))))
       (let ((bindings (mapcan #'process-var lambda-list)))
 	`(let* ((,args-tail ,args)
-		,@bindings)
-	   (declare (ignorable ,args-tail))
+		,@bindings
+		(.dummy0.
+		 ,@(when (eq state 'optional)
+		     `((unless (null ,args-tail)
+			 (error 'simple-program-error
+				:format-control "surplus arguments: ~S"
+				:format-arguments (list ,args-tail)))))))
+	   (declare (ignorable ,args-tail .dummy0.))
 	   ,@body)))))
 
 (defun get-key-arg-tail (keyword list)