X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=d9567597662769352c255bafb1ab65e9aeeeefdf;hb=644995852be20e0dcb64cdcbadfe1b98834a4c9c;hp=8cd94face4954b81fa5749366d0d5fb149e7a4d9;hpb=a33185e14640963e7f74d32aa1be81690e788c0e;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 8cd94fa..d956759 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -288,20 +288,29 @@
     (add-method generic-function new)
     new))
 
+(define-condition find-method-length-mismatch
+    (reference-condition simple-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :function find-method))))
+
 (defun real-get-method (generic-function qualifiers specializers
 			&optional (errorp t) 
 			always-check-specializers)
   (let ((lspec (length specializers))
 	(methods (generic-function-methods generic-function)))
     (when (or methods always-check-specializers)
-      (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function)))))
+      (let ((nreq (length (arg-info-metatypes (gf-arg-info
+					       generic-function)))))
 	;; Since we internally bypass FIND-METHOD by using GET-METHOD
 	;; instead we need to to this here or users may get hit by a
 	;; failed AVER instead of a sensible error message.
 	(when (/= lspec nreq)
-	  (error "~@<The generic function ~S takes ~D required argument~:P; ~
-                 was asked to find a method with specializers ~S~@:>"
-		 generic-function nreq specializers))))
+	  (error 
+	   'find-method-length-mismatch
+	   :format-control
+	   "~@<The generic function ~S takes ~D required argument~:P; ~
+            was asked to find a method with specializers ~S~@:>"
+	   :format-arguments (list generic-function nreq specializers)))))
     (let ((hit 
 	   (dolist (method methods)
 	     (let ((mspecializers (method-specializers method)))
@@ -397,11 +406,14 @@
 (defun make-discriminating-function-arglist (number-required-arguments restp)
   (nconc (let ((args nil))
            (dotimes (i number-required-arguments)
-             (push (intern (format nil "Discriminating Function Arg ~D" i))
+             (push (format-symbol *package* ;; ! is this right?
+				  "Discriminating Function Arg ~D"
+				  i)
                    args))
            (nreverse args))
 	 (when restp
-	       `(&rest ,(intern "Discriminating Function &rest Arg")))))
+	       `(&rest ,(format-symbol *package* 
+				       "Discriminating Function &rest Arg")))))
 
 (defmethod generic-function-argument-precedence-order
     ((gf standard-generic-function))
@@ -641,9 +653,10 @@
 
 
 (defun error-need-at-least-n-args (function n)
-  (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
-	 function
-	 n))
+  (error 'simple-program-error
+	 :format-control "~@<The function ~2I~_~S ~I~_requires ~
+                          at least ~W argument~:P.~:>"
+	 :format-arguments (list function n)))
 
 (defun types-from-args (generic-function arguments &optional type-modifier)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
@@ -701,7 +714,8 @@
   (loop (when (atom x) (return (eq x y)))
 	(when (atom y) (return nil))
 	(unless (eq (car x) (car y)) (return nil))
-	(setq x (cdr x)  y (cdr y))))
+	(setq x (cdr x)
+	      y (cdr y))))
 
 (defvar *std-cam-methods* nil)