Merge pull request #324 from mflatt/letname

prefer nearest binding name for procedures
original commit: d02fd343e3860b1e18bb481abe21e489dd2f17fc
This commit is contained in:
R. Kent Dybvig 2018-07-09 10:43:17 -07:00 committed by GitHub
commit 82257f1cbe
3 changed files with 22 additions and 1 deletions

2
LOG
View File

@ -965,3 +965,5 @@
- allow s_ee_get_clipboard to use the pastebuffer on macOS even when X11 is not
available.
expeditor.c
- Adjust cp0 to not replace a procedure name from a let wrapper
cp0.ss, misc.ms

View File

@ -4948,6 +4948,23 @@
(procedure-arity-mask 17))
)
(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))

View File

@ -4538,7 +4538,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))))