From 3a2659968a661add7a615cd345025b515edd149f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 22 Jun 2018 09:09:56 -0600
Subject: [PATCH] prefer closest binding name for procedures

In some cases, such as

 (define g (let ([f (lambda (x) x)]) f))

the inner name `f` could get replaced by the outer name `g`.
Prefer the inner name so that macros can use a `let` wrapper
to reliably name a procedure.

cherry-picked from mflatt/ChezScheme#letname

original commit: fb75f08cfa9690f94ae2abaa237278b287367d68
---
 LOG          |  2 ++
 mats/misc.ms | 17 +++++++++++++++++
 s/cp0.ss     |  4 +++-
 3 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/LOG b/LOG
index 8830290351..90300b4f7b 100644
--- a/LOG
+++ b/LOG
@@ -833,3 +833,5 @@
     cmacros.ss, base-lang.ss, np-languages.ss, cprep.ss
     thread.c, prim.c, externs.h, foreign.stex, release_notes.stex,
     mats/Mf-t*, foreign.ms, foreign4.c
+- Adjust cp0 to not replace a procedure name from a let wrapper
+    cp0.ss, misc.ms
diff --git a/mats/misc.ms b/mats/misc.ms
index 43b10f8b5b..71a0ffe828 100644
--- a/mats/misc.ms
+++ b/mats/misc.ms
@@ -5026,6 +5026,23 @@
             'other-data))
   )
 
+(mat procedure-name
+  (begin
+    (define (procedure-name f)
+      (((inspect/object f) 'code) 'name))
+    (define should-be-named-f (let ([f (lambda (x) x)]) f))
+    (define should-be-named-g (letrec ([g (lambda (x) x)]) g))
+    (define should-be-named-h (let ([f (let ([h (lambda (x) x)]) h)]) f))
+    (define should-be-named-i (letrec ([f (let ([i (lambda (x) x)]) i)]) f))
+    (define should-be-named-j (let ([f (letrec ([j (lambda (x) x)]) j)]) f))
+    #t)
+  (equal? (procedure-name procedure-name) "procedure-name")
+  (equal? (procedure-name should-be-named-f) "f")
+  (equal? (procedure-name should-be-named-g) "g")
+  (equal? (procedure-name should-be-named-h) "h")
+  (equal? (procedure-name should-be-named-i) "i")
+  (equal? (procedure-name should-be-named-j) "j"))
+
 (mat fasl-immutable
   (begin
     (define immutable-objs (list (vector->immutable-vector '#(1 2 3))
diff --git a/s/cp0.ss b/s/cp0.ss
index f11adff719..3e511ccea9 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -4555,7 +4555,9 @@
          (let-values ([(e args) (lift-let e e*)])
            (cp0-call preinfo e (build-operands args env wd moi) ctxt env sc wd name moi)))]
       [(case-lambda ,preinfo ,cl* ...)
-       (when (symbol? name)
+       (when (and (symbol? name)
+                  ;; Avoid replacing a name from an optimized-away `let` pattern:
+                  (not (preinfo-lambda-name preinfo)))
          (preinfo-lambda-name-set! preinfo
            (let ([x ($symbol-name name)])
              (if (pair? x) (cdr x) x))))