tweak NAME-CONTEXT

  On platforms without UNWIND-TO-FRAME-AND-CALL vops we introduce an extra
  block, which then shows up there in the function names for eg. lambdas
  defined at the toplevel in high debug code. Fix that.

  CATCH also introduces a block. Filter those out too.

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index a5e4cfb..7d05f20 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -480,7 +480,17 @@ Return VALUE without evaluating it."
   ;; Name of the outermost non-NIL BLOCK, or the source namestring
   ;; of the source file.
   (let ((context
-          (or (car (find-if #'car (lexenv-blocks *lexenv*) :from-end t))
+          (or (car (find-if (lambda (b)
+                              (let ((name (pop b)))
+                                (and name
+                                     ;; KLUDGE: High debug adds this block on
+                                     ;; some platforms.
+                                     #!-unwind-to-frame-and-call-vop
+                                     (neq 'return-value-tag name)
+                                     ;; KLUDGE: CATCH produces blocks whose
+                                     ;; cleanup is :CATCH.
+                                     (neq :catch (cleanup-kind (entry-cleanup (pop b)))))))
+                            (lexenv-blocks *lexenv*) :from-end t))
               *source-namestring*
               (let ((p (or *compile-file-truename* *load-truename*)))
                 (when p (namestring p))))))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3e48e39..083a79e 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4069,3 +4069,13 @@
                                            :initial-element 0)
                              1)
                     #(0 1 0 0)))))
+
+(with-test (:name :catch-interferes-with-debug-names)
+  (let ((fun (funcall
+              (compile nil
+                       `(lambda ()
+                          (catch 'out
+                              (flet ((foo ()
+                                       (throw 'out (lambda () t))))
+                                (foo))))))))
+    (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))