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
This commit is contained in:
parent
3d1cb4684a
commit
3a2659968a
2
LOG
2
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
|
||||
|
|
17
mats/misc.ms
17
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))
|
||||
|
|
4
s/cp0.ss
4
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))))
|
||||
|
|
Loading…
Reference in New Issue
Block a user