X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=060f4a0cd0b907bd5839f41752bec352bd09c7c4;hb=76874d05d623e0001cfcf23d2c74f78295ba6cee;hp=8b034ce60dfbfa96269adf5ad182a1dce05c5026;hpb=3b2fe8ed844834cfc975d63695fd2cb1b828f375;p=sbcl.git

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index 8b034ce..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)
@@ -256,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)
@@ -296,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
@@ -314,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))))
@@ -407,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))