0.7.9.43:

[sbcl.git] / src / pcl / defcombin.lisp

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index 0b2111e..56d0759 100644 (file)
--- 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)
@@ -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)