X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=060f4a0cd0b907bd5839f41752bec352bd09c7c4;hb=77d1a39f28fe8d240cf441a9a54a80d4bc98ea52;hp=7652ec877e3ff5fcf0bdfd920fbbfe0be9f0cae9;hpb=69550d1ce4a94faec95a651f3f0c1e884966a496;p=sbcl.git

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index 7652ec8..060f4a0 100644
--- a/src/pcl/defcombin.lisp
+++ b/src/pcl/defcombin.lisp
@@ -25,10 +25,13 @@
 
 (defmacro define-method-combination (&whole form &rest args)
   (declare (ignore args))
-  (if (and (cddr form)
-	   (listp (caddr form)))
-      (expand-long-defcombin form)
-      (expand-short-defcombin form)))
+  `(progn
+     (with-single-package-locked-error
+	 (:symbol ',(second form) "defining ~A as a method combination"))
+     ,(if (and (cddr form)
+	       (listp (caddr form)))
+	  (expand-long-defcombin form)
+	  (expand-short-defcombin form))))
 
 ;;;; standard method combination
 
@@ -99,6 +102,7 @@
     (when old-method
       (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)
+    (setf (random-documentation type 'method-combination) doc)
     type))
 
 (defun short-combine-methods (type options operator ioa method doc)
@@ -128,27 +132,20 @@
 	(order (car (method-combination-options combin)))
 	(around ())
 	(primary ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (method-qualifiers m)))
-	(flet ((lose (method why)
-		 (invalid-method-error
-		   method
-		   "The method ~S ~A.~%~
-		    The method combination type ~S was defined with the~%~
-		    short form of DEFINE-METHOD-COMBINATION and so requires~%~
-		    all methods have either the single qualifier ~S or the~%~
-		    single qualifier :AROUND."
-		   method why type type)))
-	  (cond ((null qualifiers)
-		 (lose m "has no qualifiers"))
-		((cdr qualifiers)
-		 (lose m "has more than one qualifier"))
+    (flet ((invalid (gf combin m)
+	     (if *in-precompute-effective-methods-p*
+		 (return-from compute-effective-method
+		   `(%invalid-qualifiers ',gf ',combin ',m))
+		 (invalid-qualifiers gf combin m))))
+      (dolist (m applicable-methods)
+	(let ((qualifiers (method-qualifiers m)))
+	  (cond ((null qualifiers) (invalid generic-function combin m))
+		((cdr qualifiers) (invalid generic-function combin m))
 		((eq (car qualifiers) :around)
 		 (push m around))
 		((eq (car qualifiers) type)
 		 (push m primary))
-		(t
-		 (lose m "has an illegal qualifier"))))))
+		(t (invalid generic-function combin m))))))
     (setq around (nreverse around))
     (ecase order
       (:most-specific-last) ; nothing to be done, already in correct order
@@ -192,6 +189,26 @@
 	    (t
 	     `(call-method ,(car around)
 			   (,@(cdr around) (make-method ,main-method))))))))
+
+(defmethod invalid-qualifiers ((gf generic-function)
+			       (combin short-method-combination)
+			       method)
+  (let ((qualifiers (method-qualifiers method))
+	(type (method-combination-type combin)))
+    (let ((why (cond
+		 ((null qualifiers) "has no qualifiers")
+		 ((cdr qualifiers) "has too many qualifiers")
+		 (t (aver (and (neq (car qualifiers) type)
+			       (neq (car qualifiers) :around)))
+		    "has an invalid qualifier"))))
+      (invalid-method-error
+       method
+       "The method ~S on ~S ~A.~%~
+	The method combination type ~S was defined with the~%~
+	short form of DEFINE-METHOD-COMBINATION and so requires~%~
+	all methods have either the single qualifier ~S or the~%~
+	single qualifier :AROUND."
+       method gf why type type))))
 
 ;;;; long method combinations
 
@@ -243,6 +260,7 @@
     (setf (gethash type *long-method-combination-functions*) function)
     (when old-method (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)
+    (setf (random-documentation type 'method-combination) doc)
     type))
 
 (defmethod compute-effective-method ((generic-function generic-function)
@@ -283,6 +301,12 @@
 
 ;; parse-method-group-specifiers parse the method-group-specifiers
 
+(define-condition long-method-combination-error 
+    (reference-condition simple-error)
+  ()
+  (:default-initargs 
+      :references (list '(:ansi-cl :macro define-method-combination))))
+
 (defun wrap-method-group-specifier-bindings
        (method-group-specifiers declarations real-body)
   (let (names
@@ -301,16 +325,19 @@
 		    (if (and (equal ,specializer-cache .specializers.)
 			     (not (null .specializers.)))
 			(return-from .long-method-combination-function.
-			  '(error "More than one method of type ~S ~
-				      with the same specializers."
-			           ',name))
+			  '(error 'long-method-combination-error
+			    :format-control "More than one method of type ~S ~
+				             with the same specializers."
+			    :format-arguments (list ',name)))
 			(setq ,specializer-cache .specializers.))
 		    (push .method. ,name))
 		  cond-clauses)
 	    (when required
 	      (push `(when (null ,name)
 			 (return-from .long-method-combination-function.
-			   '(error "No ~S methods." ',name)))
+			   '(error 'long-method-combination-error
+			     :format-control "No ~S methods." 
+			     :format-arguments (list ',name))))
 		      required-checks))
 	    (loop (unless (and (constantp order)
 			       (neq order (setq order (eval order))))
@@ -394,12 +421,21 @@
 ;;;
 ;;; At compute-effective-method time, the symbols in the :arguments
 ;;; option are bound to the symbols in the intercept lambda list.
+;;;
+;;; FIXME: in here we have not one but two mini-copies of a weird
+;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST.
 (defun deal-with-args-option (wrapped-body args-lambda-list)
   (let ((intercept-rebindings
 	 (let (rebindings)
 	   (dolist (arg args-lambda-list (nreverse rebindings))
 	     (unless (member arg lambda-list-keywords)
-	       (push `(,arg ',arg) rebindings)))))
+	       (typecase arg
+		 (symbol (push `(,arg ',arg) rebindings))
+		 (cons
+		  (unless (symbolp (car arg))
+		    (error "invalid lambda-list specifier: ~S." arg))
+		  (push `(,(car arg) ',(car arg)) rebindings))
+		 (t (error "invalid lambda-list-specifier: ~S." arg)))))))
 	(nreq 0)
 	(nopt 0)
 	(whole nil))
@@ -496,3 +532,4 @@
 	    (return (nconc (frob required nr nreq)
 			   (frob optional no nopt)
 			   values)))))
+