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

expander: adjust bindings in module->namespace

Browse Source 
Make the module path index for bindings in a `module->namespace` be a
"self" MPI (with #f for path and base), instead of the MPI associated
with bindings as view from the outside of the module instance. That
makes interactive evalaution in the namespace more closely approximate
expansion within the original module.

Example use: ASL detects a "self" MPI to determine when it should
allow assignment to module-defined variables in the REPL.
This commit is contained in:
Matthew Flatt 2018-02-28 09:32:08 -07:00
parent a6e585a72e
commit 25b0c23db7
16 changed files with 14279 additions and 13745 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -2318,6 +2318,19 @@ case of module-leve bindings; it doesn't cover local bindings.
(module use-module-begin-and-unique-context-check 'module-begin-and-unique-context-check
(#%expression (check-unique-context)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that a namespace can modify a module's mutable variables
(module uses-a-namespace-to-mutate-x racket/base
(provide done)
(define x 8)
(define (inc!) (set! x (add1 x)))
(eval '(set! x 0)
(variable-reference->namespace (#%variable-reference)))
(define done x))
(test 0 dynamic-require ''uses-a-namespace-to-mutate-x 'done)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

15
pkgs/racket-test-core/tests/racket/namespac.rktl
View File

@ -431,4 +431,19 @@
;; ----------------------------------------
(module check-module-path-index-inside-and-outside racket/base
(provide get)
(define me 5)
(define (get)
(define-values (path1 base1) (module-path-index-split (car (identifier-binding #'me))))
(define-values (path2 base2)
(eval '(module-path-index-split (car (identifier-binding #'me)))
(variable-reference->namespace (#%variable-reference))))
(list (list path1 base1) (list path2 base2))))
(test '(('check-module-path-index-inside-and-outside #f) (#f #f))
(dynamic-require ''check-module-path-index-inside-and-outside 'get))
;; ----------------------------------------
(report-errs)

4
racket/src/expander/compile/context.rkt
View File

@ -6,7 +6,7 @@
(struct compile-context (namespace ; compile-time namespace
phase ; phase (top level) or phase level (within a module)
self ; if non-#f module path index, compiling the body of a module
self ; to detect bindings within the same namespace
module-self ; if non-#f, same as `self` and compiling the body of a module
full-module-name ; set to a symbol or symbol list if `self` is non-#f
lazy-syntax-literals? ; #t (for modules) => deserialize and shift syntax on demand
@ -15,7 +15,7 @@
(define (make-compile-context #:namespace [namespace (current-namespace)]
#:phase [phase (namespace-phase namespace)]
#:self [self (namespace-mpi namespace)]
#:self [self (namespace-self-mpi namespace)]
#:module-self [module-self #f]
#:full-module-name [full-module-name #f]
#:lazy-syntax-literals? [lazy-syntax-literals? (and module-self #t)])

21
racket/src/expander/eval/direct.rkt
View File

@ -19,30 +19,30 @@
(define not-available (gensym 'not-available))
(define (get-not-available) not-available)
(define (can-direct-eval? p ns)
(define (can-direct-eval? p ns self-mpi)
(cond
[(parsed-app? p)
(and (can-direct-eval? (parsed-app-rator p) ns)
(and (can-direct-eval? (parsed-app-rator p) ns self-mpi)
(for/and ([r (in-list (parsed-app-rands p))])
(can-direct-eval? r ns)))]
[(parsed-id? p) (not (eq? (get-id-value p ns) not-available))]
(can-direct-eval? r ns self-mpi)))]
[(parsed-id? p) (not (eq? (get-id-value p ns self-mpi) not-available))]
[(parsed-quote? p) #t]
[(parsed-quote-syntax? p) #t]
[else #f]))
(define (direct-eval p ns)
(define (direct-eval p ns self-mpi)
(cond
[(parsed-app? p)
(apply (direct-eval (parsed-app-rator p) ns)
(apply (direct-eval (parsed-app-rator p) ns self-mpi)
(for/list ([r (in-list (parsed-app-rands p))])
(direct-eval r ns)))]
[(parsed-id? p) (get-id-value p ns)]
(direct-eval r ns self-mpi)))]
[(parsed-id? p) (get-id-value p ns self-mpi)]
[(parsed-quote? p) (parsed-quote-datum p)]
[(parsed-quote-syntax? p) (parsed-quote-syntax-datum p)]
[else #f]))
;; Return `not-available` if the value is not readily available.
(define (get-id-value p ns)
(define (get-id-value p ns self-mpi)
(define b (parsed-id-binding p))
(cond
[(parsed-primitive-id? p)
@ -51,8 +51,7 @@
get-not-available)]
[(or (parsed-top-id? p)
(not b)
(eq? (namespace-mpi ns)
(module-binding-module b)))
(eq? self-mpi (module-binding-module b)))
(namespace-get-variable
ns
(if b (module-binding-phase b) (namespace-phase ns))

14
racket/src/expander/eval/module.rkt
View File

@ -278,16 +278,20 @@
(cond
[(eq? get-encoded-root-expand-ctx 'empty)
;; A `#:empty-namespace` declaration requested a namespace with no initial bindings
(namespace-set-root-expand-ctx! ns (delay (make-root-expand-context)))]
(namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context
(make-root-expand-context self))))]
[(procedure? get-encoded-root-expand-ctx)
;; Root expand context has been preserved; deserialize it on demand
(namespace-set-root-expand-ctx! ns (delay (root-expand-context-decode-for-module
(get-encoded-root-expand-ctx))))]
(namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context
(root-expand-context-decode-for-module
(get-encoded-root-expand-ctx)
self))))]
[else
;; Root expand context has not been preserved, because it can be reconstructed
;; from module metadata; do that on demand
(namespace-set-root-expand-ctx! ns (delay (create-root-expand-context-from-module
ns phase-shift original-self self)))]))
(namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context
(create-root-expand-context-from-module
ns phase-shift original-self self))))]))
;; ----------------------------------------

29
racket/src/expander/eval/root-context.rkt
View File

@ -9,9 +9,12 @@
"../syntax/module-binding.rkt"
"../common/module-path.rkt"
"../common/phase.rkt"
"../common/struct-star.rkt"
"../namespace/namespace.rkt"
"../host/linklet.rkt")
(provide make-create-root-expand-context-from-module)
(provide make-create-root-expand-context-from-module
shift-to-inside-root-context)
;; Reconstructs a `root-expand-context` for a module based on its
;; metadata, specifically its requires and the exports of its
@ -22,7 +25,7 @@
;; contain information that is inconsistent with this reconstruction.
(define (make-create-root-expand-context-from-module requires evaled-ld-h)
(lambda (ns phase-shift original-self self)
(define root-ctx (make-root-expand-context))
(define root-ctx (make-root-expand-context #:self-mpi (namespace-mpi ns)))
(define s (add-scopes empty-syntax (root-expand-context-module-scopes root-ctx)))
;; Add bindings for `require`s
@ -49,3 +52,25 @@
(add-defined-sym! defined-syms phase sym id)))
root-ctx))
;; ----------------------------------------
;; Shift `all-scopes-stx` so that the module path index reported for
;; bindings within the module are relative to a "self" MPI (with #f
;; for the path and base) instead of the MPI that is suitable for
;; viewing bindings from outside the module. This shift makes
;; interactive evaluation better approximate the original expansion of
;; the module, but it means that that the MPI on syntax objects within
;; the module is different from the MPI on syntax objects created
;; interactively (i.e., the interactive ones look more like bindings
;; before the module has been fully compiled and instantiated).
(define (shift-to-inside-root-context root-context)
(define outside-mpi (root-expand-context-self-mpi root-context))
(define inside-mpi (make-self-module-path-index (module-path-index-resolved outside-mpi)))
(struct*-copy root-expand-context root-context
[self-mpi inside-mpi]
[all-scopes-stx
(syntax-module-path-index-shift
(root-expand-context-all-scopes-stx root-context)
outside-mpi
inside-mpi)]))

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

@ -72,7 +72,8 @@
#:for-serializable? [for-serializable? #f]
#:observer [observer #f])
(define root-ctx (namespace-get-root-expand-ctx ns))
(expand-context (root-expand-context-module-scopes root-ctx)
(expand-context (root-expand-context-self-mpi root-ctx)
(root-expand-context-module-scopes root-ctx)
(root-expand-context-post-expansion-scope root-ctx)
(root-expand-context-top-level-bind-scope root-ctx)
(root-expand-context-all-scopes-stx root-ctx)
@ -113,6 +114,7 @@
(define (copy-root-expand-context ctx root-ctx)
(struct*-copy expand-context ctx
[self-mpi #:parent root-expand-context (root-expand-context-self-mpi root-ctx)]
[module-scopes #:parent root-expand-context (root-expand-context-module-scopes root-ctx)]
[post-expansion-scope #:parent root-expand-context (root-expand-context-post-expansion-scope root-ctx)]
[top-level-bind-scope #:parent root-expand-context (root-expand-context-top-level-bind-scope root-ctx)]

3
racket/src/expander/expand/cross-phase.rkt
View File

@ -86,7 +86,8 @@
(define normal-b (parsed-id-binding id))
(when (or (not normal-b)
(parsed-top-id? id)
(eq? (module-binding-module normal-b) self-mpi))
(and (not (symbol? normal-b))
(eq? (module-binding-module normal-b) self-mpi)))
(disallow e))
(check-no-disallowed-expr (parsed-set!-rhs e))]
[(parsed-with-continuation-mark? e)

2
racket/src/expander/expand/def-id.rkt
View File

@ -87,7 +87,7 @@
(define (select-defined-syms-and-bind!/ctx tl-ids ctx)
(select-defined-syms-and-bind! tl-ids (root-expand-context-defined-syms ctx)
(namespace-mpi (expand-context-namespace ctx))
(root-expand-context-self-mpi ctx)
(expand-context-phase ctx)
(root-expand-context-all-scopes-stx ctx)
#:frame-id (root-expand-context-frame-id ctx)

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

@ -573,7 +573,7 @@
(raise-ambiguous-error id ctx)]
[(and b
(module-binding? b)
(eq? (module-binding-module b) (namespace-mpi (expand-context-namespace ctx))))
(eq? (module-binding-module b) (root-expand-context-self-mpi ctx)))
;; Allow `#%top` in a module or top-level where it refers to the same
;; thing that the identifier by itself would refer to; in that case
;; `#%top` can be stripped within a module
@ -638,7 +638,7 @@
(expand-context-allow-unbound? ctx))))
(when (and (module-binding? binding)
(not (eq? (module-binding-module binding)
(namespace-mpi (expand-context-namespace ctx)))))
(root-expand-context-self-mpi ctx))))
(raise-syntax-error #f "cannot mutate module-required identifier" s id))
(log-expand ctx 'next)
(register-variable-referenced-if-local! binding)

4
racket/src/expander/expand/main.rkt
View File

@ -629,7 +629,7 @@
;; ensuring that the number of returned values matches the number of
;; target identifiers; return the values
(define (eval-for-bindings ids p phase ns ctx)
(define compiled (if (can-direct-eval? p ns)
(define compiled (if (can-direct-eval? p ns (root-expand-context-self-mpi ctx))
#f
(compile-single p (make-compile-context
#:namespace ns
@ -641,7 +641,7 @@
[eval-jit-enabled #f])
(if compiled
(eval-single-top compiled ns)
(direct-eval p ns))))
(direct-eval p ns (root-expand-context-self-mpi ctx)))))
list))
(unless (= (length vals) (length ids))
(error "wrong number of results (" (length vals) "vs." (length ids) ")"

1
racket/src/expander/expand/module.rkt
View File

@ -135,6 +135,7 @@
initial-require-s))
(define root-ctx (make-root-expand-context
#:self-mpi self
#:initial-scopes (if keep-enclosing-scope-at-phase
(root-expand-context-module-scopes init-ctx)
null)

16
racket/src/expander/expand/root-expand-context.rkt
View File

@ -18,7 +18,8 @@
;; generated by `module->namespace` --- or preserved across different
;; expansions at the top level
(struct* root-expand-context
(module-scopes ; list of scopes for enclosing module or top level; includes next two fields
(self-mpi ; MPI for the enclosing module during compilation
module-scopes ; list of scopes for enclosing module or top level; includes next two fields
* post-expansion-scope ; #f or scope to add to every expansion; often module's inside edge
top-level-bind-scope ; #f or a scope to constrain expansion bindings; see "expand-bind-top.rkt"
all-scopes-stx ; scopes like the initial import, which correspond to original forms
@ -29,14 +30,16 @@
lift-key ; identifies (via `syntax-local-lift-context`) a target for lifts
)) ; after adding a field, update `copy-module-context` in "context.rkt"
(define (make-root-expand-context #:initial-scopes [initial-scopes null]
(define (make-root-expand-context #:self-mpi self-mpi
#:initial-scopes [initial-scopes null]
#:outside-scope [outside-scope top-level-common-scope]
#:post-expansion-scope [post-expansion-scope (new-multi-scope 'top-level)]
#:all-scopes-stx [all-scopes-stx #f])
(define module-scopes (list* post-expansion-scope
outside-scope
initial-scopes))
(root-expand-context module-scopes
(root-expand-context self-mpi
module-scopes
post-expansion-scope
(new-scope 'module) ; top-level-bind-scope
(or all-scopes-stx
@ -62,8 +65,8 @@
(root-expand-context-frame-id ctx)
(unbox (root-expand-context-counter ctx)))))
;; Encode information in a syntax object that can be serialized and deserialized
(define (root-expand-context-decode-for-module vec-s)
;; Decode the value produced by `root-expand-context-encode-for-module`
(define (root-expand-context-decode-for-module vec-s self)
(define vec (and (syntax? vec-s) (syntax-e vec-s)))
(unless (and (vector? vec)
(= (vector-length vec) 7)
@ -77,7 +80,8 @@
(error 'root-expand-context-decode-for-module
"bad encoding: ~s"
vec-s))
(root-expand-context (extract-scope-list (vector-ref vec 0)) ; module-scopes
(root-expand-context self
(extract-scope-list (vector-ref vec 0)) ; module-scopes
(extract-scope (vector-ref vec 1)) ; post-expansion-scope
(new-scope 'module) ; top-level-bind-scope
(vector-ref vec 2) ; all-scopes-stx

3
racket/src/expander/namespace/api-module.rkt
View File

@ -87,7 +87,8 @@
"module name" name))
(unless (namespace-get-root-expand-ctx m-ns)
;; Instantiating the module didn't install a context, so make one now
(namespace-set-root-expand-ctx! m-ns (make-root-expand-context)))
(namespace-set-root-expand-ctx! m-ns (make-root-expand-context
#:self-mpi (namespace-mpi m-ns))))
;; Ensure that the module is available
(namespace-module-make-available! ns (namespace-mpi m-ns) phase)
m-ns)

7
racket/src/expander/namespace/namespace.rkt
View File

@ -19,6 +19,7 @@
namespace-root-namespace
namespace-get-root-expand-ctx
namespace-set-root-expand-ctx!
namespace-self-mpi
namespace->namespace-at-phase
namespace->module
namespace-mpi
@ -85,7 +86,8 @@
(new-namespace))
(define (new-namespace [share-from-ns #f]
#:root-expand-ctx [root-expand-ctx (make-root-expand-context)]
#:root-expand-ctx [root-expand-ctx (make-root-expand-context
#:self-mpi top-level-module-path-index)]
#:register? [register? #t])
(define phase (if share-from-ns
(namespace-phase share-from-ns)
@ -134,6 +136,9 @@
(define (namespace-set-root-expand-ctx! ns root-ctx)
(set-box! (namespace-root-expand-ctx ns) root-ctx))
(define (namespace-self-mpi ns)
(root-expand-context-self-mpi (namespace-get-root-expand-ctx ns)))
(define (namespace->module ns name)
(or (small-hash-ref (namespace-submodule-declarations ns) name #f)
(hash-ref (module-registry-declarations (namespace-module-registry ns)) name #f)))

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

File diff suppressed because it is too large Load Diff