diff --git a/LOG b/LOG index 3fe7ea217c..e43e0d425a 100644 --- a/LOG +++ b/LOG @@ -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 diff --git a/mats/misc.ms b/mats/misc.ms index 20250b3332..9825c0abb4 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -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)) diff --git a/s/cp0.ss b/s/cp0.ss index 9c3a761288..fc599722b4 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -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))))