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

expander: fix body scope for letrec-syntax

Browse Source 
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
This commit is contained in:
Matthew Flatt 2018-08-28 06:27:05 -06:00
parent 1d65a89f53
commit 37c9169874
3 changed files with 86 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
pkgs/racket-test-core/tests/racket/macro.rktl
View File

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

11
racket/src/expander/expand/expr.rkt
View File

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

65
racket/src/racket/src/startup.inc
View File

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