X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=56d07591d5af9f8f0f72bd9edd62a34382f67af4;hb=1aefe68236aaf048ce602e7725ad26d130be1fd5;hp=f91b20f4929bc84ea7dd535b4d40fdc7da79b596;hpb=6c129930bd75f25a66aa0cbf0e5bc8091401d5ce;p=sbcl.git

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index f91b20f..56d0759 100644
--- a/src/pcl/defcombin.lisp
+++ b/src/pcl/defcombin.lisp
@@ -74,7 +74,7 @@
      ',type ',operator ',identity-with-one-arg ',documentation)))
 
 (defun load-short-defcombin (type operator ioa doc)
-  (let* ((truename *load-truename*)
+  (let* ((pathname *load-pathname*)
 	 (specializers
 	   (list (find-class 'generic-function)
 		 (intern-eql-specializer type)
@@ -95,10 +95,11 @@
 			   (short-combine-methods
 			    type options operator ioa new-method doc))
 			 args))
-	    :definition-source `((define-method-combination ,type) ,truename)))
+	    :definition-source `((define-method-combination ,type) ,pathname)))
     (when old-method
       (remove-method #'find-method-combination old-method))
-    (add-method #'find-method-combination new-method)))
+    (add-method #'find-method-combination new-method)
+    type))
 
 (defun short-combine-methods (type options operator ioa method doc)
   (cond ((null options) (setq options '(:most-specific-first)))
@@ -215,10 +216,11 @@
 					   :documentation doc))
 			  args))
 	     :definition-source `((define-method-combination ,type)
-			      ,*load-truename*))))
+				  ,*load-pathname*))))
     (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)))
+    (add-method #'find-method-combination new-method)
+    type))
 
 (defmethod compute-effective-method ((generic-function generic-function)
 				     (combin long-method-combination)
@@ -231,10 +233,10 @@
 
 (defun make-long-method-combination-function
        (type ll method-group-specifiers args-option gf-var body)
-  ;;(declare (values documentation function))
   (declare (ignore type))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations body)
+  (multiple-value-bind (real-body declarations documentation)
+      ;; (Note that PARSE-BODY ignores its second arg ENVIRONMENT.)
+      (parse-body body nil)
 
     (let ((wrapped-body
 	    (wrap-method-group-specifier-bindings method-group-specifiers
@@ -274,14 +276,15 @@
 	    (push name names)
 	    (push specializer-cache specializer-caches)
 	    (push `((or ,@tests)
-		      (if  (equal ,specializer-cache .specializers.)
-			   (return-from .long-method-combination-function.
-			     '(error "More than one method of type ~S ~
+		    (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))
-			   (setq ,specializer-cache .specializers.))
-		      (push .method. ,name))
-		    cond-clauses)
+			           ',name))
+			(setq ,specializer-cache .specializers.))
+		    (push .method. ,name))
+		  cond-clauses)
 	    (when required
 	      (push `(when (null ,name)
 			 (return-from .long-method-combination-function.
@@ -304,7 +307,7 @@
       (dolist (.method. .applicable-methods.)
 	(let ((.qualifiers. (method-qualifiers .method.))
 	      (.specializers. (method-specializers .method.)))
-	  (progn .qualifiers. .specializers.)
+	  (declare (ignorable .qualifiers. .specializers.))
 	  (cond ,@(nreverse cond-clauses))))
       ,@(nreverse required-checks)
       ,@(nreverse order-cleanups)