X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=4b68b67f71a3cfe74c933c6bb6daa18050486cfc;hb=cd99f20d910298cbf5c2000e3dc3595fb0c8418b;hp=0b12c514e180c43f0d787f4edec106b5c6f4304c;hpb=a57db6f5ee029a4c9817ae239d7bbefd3fb8374e;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 0b12c51..4b68b67 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -288,38 +288,58 @@
     (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))
-  (let* ((lspec (length specializers))
-	 (hit 
-	  (dolist (method (generic-function-methods generic-function))
-	    (let ((mspecializers (method-specializers method)))
-	      (aver (= lspec (length mspecializers)))
-	      (when (and (equal qualifiers (method-qualifiers method))
-			 (every #'same-specializer-p specializers
-				(method-specializers method)))
-		(return method))))))
-    (cond (hit hit)
-	  ((null errorp) nil)
-	  (t
-	   (error "~@<There is no method on ~S with ~
-                   ~:[no qualifiers~;~:*qualifiers ~S~] ~
-                   and specializers ~S.~@:>"
-		  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)))))
+	;; 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 
+	   '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)))
+	       (aver (= lspec (length mspecializers)))
+	       (when (and (equal qualifiers (method-qualifiers method))
+			  (every #'same-specializer-p specializers
+				 (method-specializers method)))
+		 (return method))))))
+      (cond (hit hit)
+	    ((null errorp) nil)
+	    (t
+	     (error "~@<There is no method on ~S with ~
+                    ~:[no qualifiers~;~:*qualifiers ~S~] ~
+                    and specializers ~S.~@:>"
+		    generic-function qualifiers specializers))))))
 
 (defmethod find-method ((generic-function standard-generic-function)
 			qualifiers specializers &optional (errorp t))
-  (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function)))))
-    ;; ANSI: "The specializers argument contains the parameter
-    ;; specializers for the method. It must correspond in length to
-    ;; the number of required arguments of the generic function, or an
-    ;; error is signaled."
-    (when (/= (length specializers) nreq)
-      (error "~@<The generic function ~S takes ~D required argument~:P; ~
-              was asked to find a method with specializers ~S~@:>"
-	     generic-function nreq specializers))
-    (real-get-method generic-function qualifiers
-		     (parse-specializers specializers) errorp)))
+  ;; ANSI about FIND-METHOD: "The specializers argument contains the
+  ;; parameter specializers for the method. It must correspond in
+  ;; length to the number of required arguments of the generic
+  ;; function, or an error is signaled."
+  ;;
+  ;; This error checking is done by REAL-GET-METHOD.
+  (real-get-method generic-function 
+		   qualifiers
+		   (parse-specializers specializers) 
+		   errorp 
+		   t))
 
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
@@ -386,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))
@@ -665,9 +688,10 @@
   (let ((types (mapcar #'class-eq-type classes)))
     (multiple-value-bind (methods all-applicable-and-sorted-p)
 	(compute-applicable-methods-using-types gf types)
-      (function-funcall (get-secondary-dispatch-function1
-			 gf methods types nil t all-applicable-and-sorted-p)
-			nil (mapcar #'class-wrapper classes)))))
+      (let ((generator (get-secondary-dispatch-function1
+			gf methods types nil t all-applicable-and-sorted-p)))
+	(make-callable gf methods generator
+		       nil (mapcar #'class-wrapper classes))))))
 
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types
@@ -689,7 +713,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)