From bf1eb4351b428abc588c6872109602769594315a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 17 Dec 2019 17:51:23 -0700
Subject: [PATCH] cs: avoid procedure names generated by schemify

Also, escape names that may look like internal encodings.
---
 pkgs/racket-test-core/tests/racket/procs.rktl | 21 ++++++++++++
 racket/src/cs/rumble/object-name.ss           |  4 +++
 racket/src/schemify/infer-name.rkt            | 34 +++++++++++++------
 3 files changed, 49 insertions(+), 10 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/procs.rktl b/pkgs/racket-test-core/tests/racket/procs.rktl
index 9b68df627a..6262f4127c 100644
--- a/pkgs/racket-test-core/tests/racket/procs.rktl
+++ b/pkgs/racket-test-core/tests/racket/procs.rktl
@@ -668,6 +668,27 @@
   (test 'done f 'done)
   (test 'yes values top-level-variable-to-mutate-form-specialized))
 
+
+;; ----------------------------------------
+;; check some strange procedure names
+
+(define-syntax (as-unnamed stx)
+  (syntax-case stx ()
+    [(_ e)
+     (syntax-property #'e 'inferred-name (void))]))
+
+(test #f object-name (eval '(let ([x (as-unnamed (lambda (x) x))])
+                              x)))
+
+(test '|[| object-name (let ([|[| (lambda (x) x)])
+                          |[|))
+(test '|]| object-name (let ([|]| (lambda (x) x)])
+                          |]|))
+
+(eval '(define (return-a-function-that-returns-y)
+         (lambda () y)))
+(test #f object-name (return-a-function-that-returns-y))
+
 ;; ----------------------------------------
 
 (report-errs)
diff --git a/racket/src/cs/rumble/object-name.ss b/racket/src/cs/rumble/object-name.ss
index ed5f73257f..31cd25691a 100644
--- a/racket/src/cs/rumble/object-name.ss
+++ b/racket/src/cs/rumble/object-name.ss
@@ -47,6 +47,10 @@
                (let ([len (string-length name)])
                  (and (fx> len 1)
                       (string->symbol (substring name 1 len))))]
+              [(and (fx> (string-length name) 0)
+                    (char=? #\] (string-ref name 0)))
+               ;; Strip escape character
+               (string->symbol (substring name 1 (string-length name)))]
               [else
                (string->symbol name)])))])]
    [(impersonator? v)
diff --git a/racket/src/schemify/infer-name.rkt b/racket/src/schemify/infer-name.rkt
index 2a59040a6f..14194b5191 100644
--- a/racket/src/schemify/infer-name.rkt
+++ b/racket/src/schemify/infer-name.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
-(require "wrap.rkt")
+(require racket/fixnum
+         "wrap.rkt")
 
 (provide infer-procedure-name)
 
@@ -7,17 +8,32 @@
   (define inferred-name (wrap-property orig-s 'inferred-name))
   (cond
     [(symbol? inferred-name)
-     ;; Let propagation of properties (at the call site of
-     ;; `infer-procedure-name`) take care of it
-     new-s]
+     (define s (symbol->immutable-string inferred-name))
+     (cond
+       [(and (fx> (string-length s) 0)
+             (let ([ch (string-ref s 0)])
+               (or (char=? #\[)
+                   (char=? #\]))))
+        ;; Symbolic name starts with "[" or "]". To avoid confusing
+        ;; it with a path or "no name" encoding, add an extra
+        ;; "]" to be stripped away.
+        (wrap-property-set (reannotate orig-s new-s)
+                          'inferred-name
+                          (string->symbol (string-append-immutable "]" s)))]
+       [else
+        ;; Let propagation of properties (at the call site of
+        ;; `infer-procedure-name`) take care of it
+        new-s])]
     [else
      (define-values (src line col pos span) (wrap-source orig-s))
      (define (add-property str)
        (wrap-property-set (reannotate orig-s new-s)
                           'inferred-name
                           ;; Hack: starting with "[" means
-                          ;; "derived from path"
-                          (string->symbol (string-append "[" str))))
+                          ;; "derived from path". This distinction
+                          ;; is used when printing function names
+                          ;; in a stack trace.
+                          (string->symbol (string-append-immutable "[" str))))
      (cond
        [(and (or (path? src) (string? src)) line col)
         (add-property
@@ -31,14 +47,13 @@
          (string-append (source->string src)
                         "::"
                         (number->string pos)))]
-       [(void? inferred-name)
+       [else ; includes `(void? inferred-name)`
         ;; We can't provide a source name, but explicity
         ;; suppress any other inferred name:
         (wrap-property-set (reannotate orig-s new-s)
                            'inferred-name
                            ;; Hack: "[" means "no name"
-                           '|[|)]
-       [else new-s])]))
+                           '|[|)])]))
 
 (define (source->string src)
   (define str (if (string? src) src (path->string src)))
@@ -50,4 +65,3 @@
     (when (char=? #\\ (string-ref short-str i))
       (string-set! short-str i #\/)))
   short-str)
-