X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fcombin.lisp;h=8128f53478e3b64bd0a6125c465300b0b694542a;hb=ebf551c18ccd32e6fa9349cd5edb5b2a51e92ac2;hp=be7a9a8130e30a9d81e59af2aacd5aec03ccf811;hpb=6e9a41e3ec4205f3a6e02ba50ff36f4159a3dfd9;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index be7a9a8..8128f53 100644
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -229,18 +229,19 @@
              ;; Otherwise the METHOD-COMBINATION slot is not bound.
              (let ((combin (generic-function-method-combination gf)))
                (and (long-method-combination-p combin)
-                    (long-method-combination-args-lambda-list combin))))))
+                    (long-method-combination-args-lambda-list combin)))))
+          (name `(emf ,(generic-function-name gf))))
       (cond
         (error-p
-         `(lambda (.pv. .next-method-call. &rest .args.)
-           (declare (ignore .pv. .next-method-call.))
-           (declare (ignorable .args.))
-           (flet ((%no-primary-method (gf args)
-                    (call-no-primary-method gf args))
-                  (%invalid-qualifiers (gf combin method)
-                    (invalid-qualifiers gf combin method)))
-             (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
-             ,effective-method)))
+         `(named-lambda ,name (.pv. .next-method-call. &rest .args.)
+            (declare (ignore .pv. .next-method-call.))
+            (declare (ignorable .args.))
+            (flet ((%no-primary-method (gf args)
+                     (call-no-primary-method gf args))
+                   (%invalid-qualifiers (gf combin method)
+                     (invalid-qualifiers gf combin method)))
+              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
+              ,effective-method)))
         (mc-args-p
          (let* ((required (make-dfun-required-args nreq))
                 (gf-args (if applyp
@@ -250,17 +251,17 @@
                                       (the (and unsigned-byte fixnum)
                                         .dfun-more-count.)))
                              `(list ,@required))))
-           `(lambda ,ll
-             (declare (ignore .pv. .next-method-call.))
-             (let ((.gf-args. ,gf-args))
-               (declare (ignorable .gf-args.))
-               ,@check-applicable-keywords
-               ,effective-method))))
+           `(named-lambda ,name ,ll
+              (declare (ignore .pv. .next-method-call.))
+              (let ((.gf-args. ,gf-args))
+                (declare (ignorable .gf-args.))
+                ,@check-applicable-keywords
+                ,effective-method))))
         (t
-         `(lambda ,ll
-           (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
-           ,@check-applicable-keywords
-           ,effective-method))))))
+         `(named-lambda ,name ,ll
+            (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
+            ,@check-applicable-keywords
+            ,effective-method))))))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))