suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: avoid procedure names generated by schemify

Browse Source 
Also, escape names that may look like internal encodings.
This commit is contained in:
Matthew Flatt 2019-12-17 17:51:23 -07:00
parent 27eb177b9d
commit bf1eb4351b
3 changed files with 49 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -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)

4
racket/src/cs/rumble/object-name.ss
View File

@ -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)

34
racket/src/schemify/infer-name.rkt
View File

@ -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)