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

Establish free-id=? equivalences in intdefs with local bindings in scope

Browse Source 
fixes #2594
This commit is contained in:
Alexis King 2019-04-06 13:29:02 -05:00
parent 38d612dba6
commit 72ab50a993
3 changed files with 96 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2388,6 +2388,33 @@
(and (exn:fail:syntax? exn) ; the error is from `#%plain-module-begin`
(regexp-match? #rx"not currently transforming a module" (exn-message exn)))))
;; ----------------------------------------
;; Make sure `syntax-local-bind-syntaxes` binds installs `free-identifier=?`
;; equivalences in a context in which previous definitions in the context are bound
(module syntax-local-bind-syntaxes-free-id-context racket/base
(require (for-syntax racket/base))
(provide result)
(define-syntax (letrec-syntax/intdef stx)
(syntax-case stx ()
[(_ ([x rhs] ...) e)
(let ()
(define intdef (syntax-local-make-definition-context))
(for ([x (in-list (syntax->list #'(x ...)))]
[rhs (in-list (syntax->list #'(rhs ...)))])
(syntax-local-bind-syntaxes (list x) rhs intdef))
(local-expand #'e 'expression '() intdef))]))
(begin-for-syntax
(struct indirect-rename-transformer (target-holder)
#:property prop:rename-transformer
(lambda (self) (syntax-local-value (indirect-rename-transformer-target-holder self)))))
(define result
(letrec-syntax/intdef ([holder #'add1]
[add1-indirect (indirect-rename-transformer #'holder)])
(add1-indirect 10))))
(test 11 dynamic-require ''syntax-local-bind-syntaxes-free-id-context 'result)
;; ----------------------------------------
(report-errs)

24
racket/src/expander/expand/definition-context.rkt
View File

@ -89,21 +89,22 @@
(add-local-binding! intdef-id phase counter
#:frame-id (internal-definition-context-frame-id intdef)
#:local-sym local-sym)))
(define local-ctx
(and s
(let ()
(define tmp-env (for/fold ([env (expand-context-env ctx)]) ([sym (in-list syms)]
[intdef-id (in-list intdef-ids)])
(env-extend env sym (local-variable intdef-id))))
(make-local-expand-context (struct*-copy expand-context ctx
[env tmp-env])
#:context 'expression
#:intdefs all-intdefs))))
(define vals
(cond
[s
(define input-s (flip-introduction-scopes (add-intdef-scopes s all-intdefs) ctx))
(define tmp-env (for/fold ([env (expand-context-env ctx)]) ([sym (in-list syms)]
[intdef-id (in-list intdef-ids)])
(env-extend env sym (local-variable intdef-id))))
(log-expand ctx 'enter-bind)
(define vals
(eval-for-syntaxes-binding 'syntax-local-bind-syntaxes
input-s ids
(make-local-expand-context (struct*-copy expand-context ctx
[env tmp-env])
#:context 'expression
#:intdefs all-intdefs)))
(define vals (eval-for-syntaxes-binding 'syntax-local-bind-syntaxes input-s ids local-ctx))
(log-expand ctx 'exit-bind)
vals]
[else
@ -112,7 +113,8 @@
(set-box! env-mixins (append (for/list ([intdef-id (in-list intdef-ids)]
[sym (in-list syms)]
[val (in-list vals)])
(maybe-install-free=id-in-context! val intdef-id phase ctx)
(when local-ctx
(maybe-install-free=id-in-context! val intdef-id phase local-ctx))
(env-mixin intdef-id sym val (make-weak-hasheq)))
(unbox env-mixins)))
(log-expand ctx 'exit-local-bind))

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

@ -44686,20 +44686,9 @@ static const char *startup_source =
" for-loop_0)"
" null"
" lst_0))))))"
"(let-values(((vals_0)"
"(let-values(((local-ctx_0)"
"(if s_0"
"(let-values()"
"(let-values(((input-s_0)"
"(flip-introduction-scopes"
"(let-values(((s59_0) s_0)"
"((all-intdefs60_0)"
" all-intdefs_0))"
"(add-intdef-scopes24.1"
" unsafe-undefined"
" #f"
" s59_0"
" all-intdefs60_0))"
" ctx_0)))"
"(let-values(((tmp-env_0)"
"(let-values(((lst_0) syms_0)"
"((lst_1)"
@ -44759,42 +44748,22 @@ static const char *startup_source =
" env_1)))"
" env_0)))))"
" for-loop_0)"
"(expand-context-env"
" ctx_0)"
"(expand-context-env ctx_0)"
" lst_0"
" lst_1)))))"
"(let-values((()"
"(begin"
"(let-values(((obs_0)"
"(expand-context-observer"
" ctx_0)))"
"(if obs_0"
"(let-values()"
"(let-values()"
"(call-expand-observe"
" obs_0"
" 'enter-bind)))"
"(void)))"
"(values))))"
"(let-values(((vals_0)"
"(eval-for-syntaxes-binding"
" 'syntax-local-bind-syntaxes"
" input-s_0"
" ids_0"
"(let-values(((temp61_0)"
"(let-values(((v_0)"
" ctx_0))"
"(let-values(((temp59_0)"
"(let-values(((v_0) ctx_0))"
"(let-values(((the-struct_0)"
" v_0))"
"(if(expand-context/outer?"
" the-struct_0)"
"(let-values(((env64_0)"
"(let-values(((env62_0)"
" tmp-env_0)"
"((inner65_0)"
"((inner63_0)"
"(root-expand-context/outer-inner"
" v_0)))"
"(expand-context/outer1.1"
" inner65_0"
" inner63_0"
"(root-expand-context/outer-post-expansion"
" the-struct_0)"
"(root-expand-context/outer-use-site-scopes"
@ -44803,7 +44772,7 @@ static const char *startup_source =
" the-struct_0)"
"(expand-context/outer-context"
" the-struct_0)"
" env64_0"
" env62_0"
"(expand-context/outer-scopes"
" the-struct_0)"
"(expand-context/outer-def-ctx-scopes"
@ -44824,21 +44793,54 @@ static const char *startup_source =
" the-struct_0)))"
"(raise-argument-error"
" 'struct-copy"
" \"expand-context/outer?\""
" \"expand-context/outer?\""
" the-struct_0)))))"
"((temp62_0)"
" 'expression)"
"((all-intdefs63_0)"
"((temp60_0) 'expression)"
"((all-intdefs61_0)"
" all-intdefs_0))"
"(make-local-expand-context42.1"
" temp62_0"
" all-intdefs63_0"
" temp60_0"
" all-intdefs61_0"
" #t"
" unsafe-undefined"
" #f"
" #f"
" #f"
" temp61_0)))))"
" temp59_0))))"
" #f)))"
"(let-values(((vals_0)"
"(if s_0"
"(let-values()"
"(let-values(((input-s_0)"
"(flip-introduction-scopes"
"(let-values(((s64_0) s_0)"
"((all-intdefs65_0)"
" all-intdefs_0))"
"(add-intdef-scopes24.1"
" unsafe-undefined"
" #f"
" s64_0"
" all-intdefs65_0))"
" ctx_0)))"
"(let-values((()"
"(begin"
"(let-values(((obs_0)"
"(expand-context-observer"
" ctx_0)))"
"(if obs_0"
"(let-values()"
"(let-values()"
"(call-expand-observe"
" obs_0"
" 'enter-bind)))"
"(void)))"
"(values))))"
"(let-values(((vals_0)"
"(eval-for-syntaxes-binding"
" 'syntax-local-bind-syntaxes"
" input-s_0"
" ids_0"
" local-ctx_0)))"
"(begin"
"(let-values(((obs_0)"
"(expand-context-observer"
@ -44850,7 +44852,7 @@ static const char *startup_source =
" obs_0"
" 'exit-bind)))"
"(void)))"
" vals_0))))))"
" vals_0)))))"
"(let-values()"
"(reverse$1"
"(let-values(((lst_0) intdef-ids_0))"
@ -44883,7 +44885,8 @@ static const char *startup_source =
" fold-var_1))))"
"(values"
" fold-var_2)))))"
"(if(not #f)"
"(if(not"
" #f)"
"(for-loop_0"
" fold-var_1"
" rest_0)"
@ -44954,11 +44957,14 @@ static const char *startup_source =
"(cons"
"(let-values()"
"(begin"
"(if local-ctx_0"
"(let-values()"
"(maybe-install-free=id-in-context!"
" val_0"
" intdef-id_0"
" phase_0"
" ctx_0)"
" local-ctx_0))"
"(void))"
"(env-mixin2.1"
" intdef-id_0"
" sym_0"
@ -44986,7 +44992,7 @@ static const char *startup_source =
"(let-values()"
"(let-values()"
"(call-expand-observe obs_0 'exit-local-bind)))"
"(void))))))))))))))))))))))))))))"
"(void)))))))))))))))))))))))))))))"
"(case-lambda"
"((ids_0 s_0 intdef_0)(begin 'syntax-local-bind-syntaxes(syntax-local-bind-syntaxes11_0 ids_0 s_0 intdef_0 '())))"
"((ids_0 s_0 intdef_0 extra-intdefs7_0)(syntax-local-bind-syntaxes11_0 ids_0 s_0 intdef_0 extra-intdefs7_0)))))"