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

expander: handle strange local-expand under begin-for-syntax

Browse Source 
Avoids internal errors (including unsafe behavior) in an example like

```
  #lang racket

  (begin-for-syntax
    (local-expand
     #'(#%plain-module-begin
        (begin-for-syntax
          (define x 42)))
     'module-begin
     '()))

  (begin-for-syntax
    (println x))
```

This example is weird, because it creates an `x` binding that doesn't
survive to the full expansion. Before the repair, the disappearing
binding created trouble for the expanded-to-linklet pass.

The example is weird for a second reason, which is that it uses uses
`local-expand` in a place where it will be triggered by visiting the
module. It turns out that raising a syntax error at that time (from
`#%plain-module-begin`) did not work correctly due to lazy
instantiation of the expansion context.

Closes #2458
This commit is contained in:
Matthew Flatt 2019-02-25 15:25:22 -07:00
parent 84837f4330
commit f80c71e642
4 changed files with 75 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2337,6 +2337,57 @@
(define x 2)
(restore))))
;; ----------------------------------------
;; Make sure somethign reasonable happens when a `for-syntax` `define`
;; is seen via `local-expand` but is not preserved in the expansion
(module module-compiles-but-does-not-visit racket/base
(require (for-syntax racket/base))
(begin-for-syntax
(when (eq? (syntax-local-context) 'module)
(local-expand
#'(#%plain-module-begin
(begin-for-syntax
(define x 42)))
'module-begin
'())))
(begin-for-syntax
;; Weird: can be 42 at compile time, but since the for-syntax
;; `define` did not survive in the fully expanded form, it
;; turns into a reference to an undefined variable.
x))
(err/rt-test (begin
(eval '(require 'module-compiles-but-does-not-visit))
;; triggers visit:
(eval #t))
exn:fail:contract:variable?)
;; ----------------------------------------
;; Make sure a reasonable exceptoion happens when `local-expand`
;; is misused under `begin-for-syntax`
(module module-also-compiles-but-does-not-visit racket/base
(require (for-syntax racket/base))
(begin-for-syntax
(local-expand
#'(#%plain-module-begin
(begin-for-syntax
(define x 42)))
'module-begin
'())))
(err/rt-test (begin
(eval '(require 'module-also-compiles-but-does-not-visit))
;; triggers visit:
(eval #t))
(lambda (exn)
(and (exn:fail:syntax? exn) ; the error is from `#%plain-module-begin`
(regexp-match? #rx"not currently transforming a module" (exn-message exn)))))
;; ----------------------------------------
(report-errs)

17
racket/src/expander/compile/expr.rkt
View File

@ -204,15 +204,20 @@
(error "internal error: cannot assign to a primitive:" (module-binding-sym b)))
;; Expect each primitive to be bound:
(module-binding-sym b)]
[(eq? mpi (compile-context-module-self cctx))
;; Direct reference to a variable defined in the same module:
(define header (compile-context-header cctx))
(hash-ref (header-binding-sym-to-define-sym header)
(module-binding-sym b))]
[(and (eq? mpi (compile-context-module-self cctx))
;; Direct reference to a variable defined in the same module:
(hash-ref (header-binding-sym-to-define-sym (compile-context-header cctx))
(module-binding-sym b)
;; If this `#f` is used as the result, then the identifier must be a
;; reference to a binding that was introduced through `local-expand`,
;; but didn't survive to a definition in the full expansion; treat it
;; as an undefined export.
#f))
=> (lambda (sym) sym)]
[else
;; Reference to a variable defined in another module or in an
;; environment (such as the top level) other than a module
;; context; register as a linklet import
;; context; register as a linklet import or export
(register-required-variable-use! (compile-context-header cctx)
(if (inside-module-context? mpi (compile-context-self cctx))
(compile-context-self cctx)

2
racket/src/expander/expand/context.rkt
View File

@ -215,7 +215,7 @@
;; Register a callback for `raise-syntax-error`
(set-current-previously-unbound!
(lambda ()
(define ctx (current-expand-context))
(define ctx (force (current-expand-context)))
(define phase-to-ids (and ctx (expand-context-need-eventually-defined ctx)))
(and phase-to-ids
(hash-ref phase-to-ids (expand-context-phase ctx) null))))

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

@ -17988,7 +17988,7 @@ static const char *startup_source =
"(lambda()"
"(set-current-previously-unbound!"
"(lambda()"
"(let-values(((ctx_0)(current-expand-context)))"
"(let-values(((ctx_0)(force(current-expand-context))))"
"(let-values(((phase-to-ids_0)(if ctx_0(expand-context-need-eventually-defined ctx_0) #f)))"
"(if phase-to-ids_0(hash-ref phase-to-ids_0(expand-context-phase ctx_0) null) #f))))))"
" print-values)"
@ -30943,12 +30943,16 @@ static const char *startup_source =
"(module-binding-sym b_0)))"
"(void))"
"(module-binding-sym b_0)))"
"(let-values(((c1_0)"
"(if(eq? mpi_0(compile-context-module-self cctx_0))"
"(let-values()"
"(let-values(((header_0)(compile-context-header cctx_0)))"
"(hash-ref"
"(header-binding-sym-to-define-sym header_0)"
"(module-binding-sym b_0))))"
"(header-binding-sym-to-define-sym"
"(compile-context-header cctx_0))"
"(module-binding-sym b_0)"
" #f)"
" #f)))"
"(if c1_0"
"((lambda(sym_0) sym_0) c1_0)"
"(let-values()"
"(let-values(((temp46_0)(compile-context-header cctx_0))"
"((temp47_0)"
@ -30964,7 +30968,8 @@ static const char *startup_source =
"(module-binding-extra-inspector b_0)))"
"(if or-part_0"
" or-part_0"
"(let-values(((or-part_1)(parsed-id-inspector p_0)))"
"(let-values(((or-part_1)"
"(parsed-id-inspector p_0)))"
"(if or-part_1"
" or-part_1"
"(if(parsed-s p_0)"
@ -30976,7 +30981,7 @@ static const char *startup_source =
" temp47_0"
" temp48_0"
" temp49_0"
" temp50_0)))))))"
" temp50_0))))))))"
"(let-values()"
" (error \"not a reference to a module or local binding:\" b_0 (parsed-s p_0)))))))"
"(correlate~(parsed-s p_0)(if set-to?_0(list 'set! sym_0 rhs_0) sym_0)))))))))))))"