From 37c91698748243a73aa686b36bfc89a1afbf0256 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Aug 2018 06:27:05 -0600 Subject: [PATCH] expander: fix body scope for `letrec-syntax` An extra scope is needed to separate the bindings of a `letrec` from the `letrec` body, in case a macro moves right-hand-side expressions to the body. Michael Ballantyne and William Hatch reported this problem and its solution in December 2016, but I forgot to add the repair. Relevant to #2237 --- pkgs/racket-test-core/tests/racket/macro.rktl | 33 +++++++++- racket/src/expander/expand/expr.rkt | 11 +++- racket/src/racket/src/startup.inc | 65 +++++++++++++------ 3 files changed, 86 insertions(+), 23 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 6756a38fae..8a013e54fd 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -2307,7 +2307,38 @@ (if ok? #''ok #''oops))])) (test 'ok values (m 1))) - + +;; ---------------------------------------- + +(test 'ok 'scope-for-letrec + (let ([x 'ok]) + (letrec-syntax ([foo (lambda (stx) + #'x)]) + (define x 2) + (foo)))) + + +(test 1 'scope-for-letrec + (let () + (define-syntaxes (stash restore) + (let ([stash #f]) + (values + ;; stash + (lambda (stx) + (syntax-case stx () + [(_ arg) + (begin (set! stash (syntax-local-introduce #'arg)) + #'arg)])) + ;; restore + (lambda (stx) + (syntax-local-introduce stash))))) + + (define x 1) + + (letrec-values ([(foo) (stash x)]) + (define x 2) + (restore)))) + ;; ---------------------------------------- (report-errs) diff --git a/racket/src/expander/expand/expr.rkt b/racket/src/expander/expand/expr.rkt index 1b49d12999..1fc8391464 100644 --- a/racket/src/expander/expand/expr.rkt +++ b/racket/src/expander/expand/expr.rkt @@ -171,6 +171,7 @@ '(let-values ([(id:val ...) val-rhs] ...) body ...+)) (define sc (new-scope 'local)) + (define body-sc (and rec? (new-scope 'letrec-body))) (define phase (expand-context-phase ctx)) (define frame-id (and syntaxes? (make-reference-record))) ; accumulates info on referenced variables @@ -205,7 +206,10 @@ (add-local-binding! id phase counter #:frame-id frame-id #:in s)))) ;; Add new scope to body: (define bodys (for/list ([body (in-list (if syntaxes? (stx-m 'body) (val-m 'body)))]) - (add-scope body sc))) + (define new-body (add-scope body sc)) + (if rec? + (add-scope new-body body-sc) + new-body))) (log-expand... ctx (lambda (obs) (log-let-renames obs renames-log-tag val-idss val-rhss bodys trans-idss (and syntaxes? (stx-m 'trans-rhs)) sc))) @@ -241,7 +245,10 @@ (define orig-rrs (expand-context-reference-records expr-ctx)) (define rec-ctx (struct*-copy expand-context expr-ctx [env rec-env] - [scopes (cons sc (expand-context-scopes ctx))] + [scopes (let ([scopes (cons sc (expand-context-scopes ctx))]) + (if rec? + (cons body-sc scopes) + scopes))] [reference-records (if split-by-reference? (cons frame-id orig-rrs) orig-rrs)] diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index ca1da33b6f..3f0b0dfcb5 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -65093,6 +65093,7 @@ static const char *startup_source = "(values #t let-values127_0 id:val128_0 val-rhs129_0 body130_0)))" "(values #f #f #f #f #f)))))" "(let-values(((sc_0)(new-scope 'local)))" +"(let-values(((body-sc_0)(if rec?_0(new-scope 'letrec-body) #f)))" "(let-values(((phase_0)(expand-context-phase ctx_0)))" "(let-values(((frame-id_0)(if syntaxes?_0(make-reference-record) #f)))" "(let-values(((trans-idss_0)" @@ -65108,7 +65109,8 @@ static const char *startup_source = " 'for-loop" "(if(pair? lst_1)" "(let-values(((ids_0)(unsafe-car lst_1))" -"((rest_0)(unsafe-cdr lst_1)))" +"((rest_0)" +"(unsafe-cdr lst_1)))" "(let-values(((fold-var_1)" "(let-values(((fold-var_1)" " fold-var_0))" @@ -65163,7 +65165,8 @@ static const char *startup_source = " null" " lst_2)))))" " fold-var_1))))" -"(values fold-var_2)))))" +"(values" +" fold-var_2)))))" "(if(not #f)" "(for-loop_0 fold-var_1 rest_0)" " fold-var_1)))" @@ -65183,7 +65186,8 @@ static const char *startup_source = "(begin" " 'for-loop" "(if(pair? lst_1)" -"(let-values(((ids_0)(unsafe-car lst_1))" +"(let-values(((ids_0)" +"(unsafe-car lst_1))" "((rest_0)" "(unsafe-cdr lst_1)))" "(let-values(((fold-var_1)" @@ -65255,7 +65259,8 @@ static const char *startup_source = "(let-values(((lst_0)" "(if syntaxes?_0 val-rhs105_0 val-rhs129_0)))" "(begin" -"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" "(void)" "(let-values()(check-list lst_0)))" "((letrec-values(((for-loop_0)" @@ -65281,7 +65286,9 @@ static const char *startup_source = "(values" " fold-var_2)))))" "(if(not #f)" -"(for-loop_0 fold-var_1 rest_0)" +"(for-loop_0" +" fold-var_1" +" rest_0)" " fold-var_1)))" " fold-var_0)))))" " for-loop_0)" @@ -65360,7 +65367,7 @@ static const char *startup_source = "(let-values()" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0))" "(let-values()" " flat-s_0))))))" @@ -65374,7 +65381,7 @@ static const char *startup_source = " _165_0))" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0))))))" "(values" " _161_0" @@ -65382,7 +65389,7 @@ static const char *startup_source = " _163_0))" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0))))))" "(values" " _157_0" @@ -65391,7 +65398,7 @@ static const char *startup_source = " _160_0))" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0)))))" "(values" " #t" @@ -65448,7 +65455,7 @@ static const char *startup_source = "(let-values()" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0))" "(let-values()" " flat-s_0))))))" @@ -65462,7 +65469,7 @@ static const char *startup_source = " _173_0))" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0))))))" "(values" " _169_0" @@ -65470,9 +65477,13 @@ static const char *startup_source = " _171_0))" "(raise-syntax-error$1" " #f" -" \"bad syntax\"" +" \"bad syntax\"" " orig-s_0)))))" -"(values #t _166_0 clause167_0 _168_0))))))" +"(values" +" #t" +" _166_0" +" clause167_0" +" _168_0))))))" " clause167_0)))))" "(let-values((()" "(begin" @@ -65708,9 +65719,15 @@ static const char *startup_source = "(let-values()" "(cons" "(let-values()" +"(let-values(((new-body_0)" "(add-scope" " body_0" -" sc_0))" +" sc_0)))" +"(if rec?_0" +"(add-scope" +" new-body_0" +" body-sc_0)" +" new-body_0)))" " fold-var_1))))" "(values" " fold-var_2)))))" @@ -65871,7 +65888,8 @@ static const char *startup_source = " lst_3)" "(begin" " 'for-loop" -"(if(if(pair? lst_2)" +"(if(if(pair?" +" lst_2)" "(pair? lst_3)" " #f)" "(let-values(((keys_0)" @@ -66123,7 +66141,8 @@ static const char *startup_source = " lst_0" " lst_1" " lst_2)))))" -"(let-values(((expr-ctx_0)(as-expression-context ctx_0)))" +"(let-values(((expr-ctx_0)" +"(as-expression-context ctx_0)))" "(let-values(((orig-rrs_0)" "(expand-context-reference-records" " expr-ctx_0)))" @@ -66135,10 +66154,16 @@ static const char *startup_source = "(let-values(((env184_0)" " rec-env_0)" "((scopes185_0)" +"(let-values(((scopes_0)" "(cons" " sc_0" "(expand-context-scopes" -" ctx_0)))" +" ctx_0))))" +"(if rec?_0" +"(cons" +" body-sc_0" +" scopes_0)" +" scopes_0)))" "((reference-records186_0)" "(if split-by-reference?_0" "(cons" @@ -66183,7 +66208,7 @@ static const char *startup_source = " the-struct_0)))" "(raise-argument-error" " 'struct-copy" -" \"expand-context/outer?\"" +" \"expand-context/outer?\"" " the-struct_0))))))" "(let-values(((letrec-values-id_0)" "(if(not" @@ -66381,7 +66406,7 @@ static const char *startup_source = " the-struct_0)))" "(raise-argument-error" " 'struct-copy" -" \"expand-context/outer?\"" +" \"expand-context/outer?\"" " the-struct_0))))))" "(let-values(((bodys192_0)" " bodys_0)" @@ -66621,7 +66646,7 @@ static const char *startup_source = " result-s_0" "(attach-disappeared-transformer-bindings" " result-s_0" -" trans-idss_0))))))))))))))))))))))))))))))))))))))))))" +" trans-idss_0)))))))))))))))))))))))))))))))))))))))))))" "(define-values" "(log-let-renames)" "(lambda(obs_0 renames-log-tag_0 val-idss_0 val-rhss_0 bodys_0 trans-idss_0 trans-rhss_0 sc_0)"