From e72f954e850c0ae66be820b9f65241dcef77bdce Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 7 Oct 2019 15:18:46 -0600
Subject: [PATCH] cs: fix procedure names in startup code

Commit 7d725ab48b0 interferred with the way that procedure names are
recorded for the code that is built into the Racket executable.
---
 pkgs/racket-test-core/tests/racket/name.rktl |  2 +
 racket/src/cs/convert.rkt                    | 79 +++++++++++---------
 2 files changed, 45 insertions(+), 36 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/name.rktl b/pkgs/racket-test-core/tests/racket/name.rktl
index 5ffa22b954..17216e0ac0 100644
--- a/pkgs/racket-test-core/tests/racket/name.rktl
+++ b/pkgs/racket-test-core/tests/racket/name.rktl
@@ -13,6 +13,8 @@
 (test #f object-name 'hello)
 (test #f object-name "hi")
 
+(test 'eval object-name eval)
+
 (define (src-name? s)
   (and (symbol? s)
        (regexp-match ":[0-9]+.[0-9]+$" (symbol->string s))
diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt
index 4cb0c3051b..d9bc82676e 100644
--- a/racket/src/cs/convert.rkt
+++ b/racket/src/cs/convert.rkt
@@ -99,6 +99,45 @@
 (unless for-cify?
   (lift l))
 
+;; Startup code as an S-expression uses the pattern
+;;   (lambda <formals> (begin '<id> <expr>))
+;; or
+;;   (case-lambda [<formals> (begin '<id> <expr>)] <clause> ...)
+;; to record a name for a function. Detect that pattern and
+;; convert back to an 'inferred-name property. We rely on the fact
+;; that the names `lambda`, `case-lambda`, and `quote` are
+;; never shadowed, so we don't have to parse expression forms
+;; in general.
+(define (recognize-inferred-names e)
+  (cond
+    [(not (pair? e)) e]
+    [else
+     (define (begin-name e)
+       (and (pair? e)
+            (eq? (car e) 'begin)
+            (pair? (cdr e))
+            (pair? (cddr e))
+            (pair? (cadr e))
+            (eq? 'quote (caadr e))
+            (cadadr e)))
+     (case (car e)
+       [(quote) e]
+       [(lambda)
+        (define new-e (map recognize-inferred-names e))
+        (define name (begin-name (caddr e)))
+        (if name
+            (wrap-property-set new-e 'inferred-name name)
+            new-e)]
+       [(case-lambda)
+        (define new-e (map recognize-inferred-names e))
+        (define name (and (pair? (cdr e))
+                          (begin-name (cadadr e))))
+        (if name
+            (wrap-property-set new-e 'inferred-name name)
+            new-e)]
+       [else (cons (recognize-inferred-names (car e))
+                   (recognize-inferred-names (cdr e)))])]))
+
 (define prim-knowns
   (let ([knowns (hasheq)])
     (define-syntax-rule (define-primitive-table id [prim known] ...)
@@ -142,7 +181,7 @@
           (begin
             (printf "Serializable...\n")
             (time (convert-for-serialize l for-cify?)))
-          (values l null)))
+          (values (recognize-inferred-names l) null)))
     (printf "Schemify...\n")
     (define body
       (time
@@ -219,15 +258,7 @@
 
 ;; ----------------------------------------
 
-;; Startup code as an S-expression uses the pattern
-;;   (lambda <formals> (begin '<id> <expr>))
-;; or
-;;   (case-lambda [<formals> (begin '<id> <expr>)] <clause> ...)
-;; to record a name for a function. Detect that pattern and
-;; create a `#%name` form. We rely on the fact
-;; that the names `lambda`, `case-lambda`, and `quote` are
-;; never shadowed, so we don't have to parse expression forms
-;; in general.
+;; Convert 'inferred-name properties to `#%name` forms
 (define (rename-functions e)
   (cond
     [(wrap? e)
@@ -238,32 +269,8 @@
        [else
         (rename-functions (unwrap e))])]
     [(not (pair? e)) e]
-    [else
-     (define (begin-name e)
-       (and (pair? e)
-            (eq? (car e) 'begin)
-            (pair? (cdr e))
-            (pair? (cddr e))
-            (pair? (cadr e))
-            (eq? 'quote (caadr e))
-            (cadadr e)))
-     (case (car e)
-       [(quote) e]
-       [(lambda)
-        (define new-e (map rename-functions e))
-        (define name (begin-name (caddr e)))
-        (if name
-            `(#%name ,name ,new-e)
-            new-e)]
-       [(case-lambda)
-        (define new-e (map rename-functions e))
-        (define name (and (pair? (cdr e))
-                          (begin-name (cadadr e))))
-        (if name
-            `(#%name ,name ,new-e)
-            new-e)]
-       [else (cons (rename-functions (car e))
-                   (rename-functions (cdr e)))])]))
+    [else (cons (rename-functions (car e))
+                (rename-functions (cdr e)))]))
 
 ;; ----------------------------------------