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

expander: add 'protected property to protected references

Browse Source 
As documented and as implemented by the old expander.
This commit is contained in:
Matthew Flatt 2018-02-28 17:14:06 -07:00
parent 24a4882e5d
commit b4f0499256
9 changed files with 7977 additions and 7934 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -238,6 +238,21 @@
(define-define-stx stx-with-property)
(test 'y syntax-property stx-with-property 'x)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that protected references are annotated with a 'protected property
(module exports-macros-that-expand-to-protected-references racket/base
(provide emtetpr-m1 emtetpr-m2 (protect-out x1))
(define x1 1)
(define x2 2)
(define-syntax-rule (emtetpr-m1) x1)
(define-syntax-rule (emtetpr-m2) x2))
(require 'exports-macros-that-expand-to-protected-references)
(test #t syntax-property (expand #'(emtetpr-m1)) 'protected)
(test #t syntax-property (expand #'(emtetpr-m2)) 'protected)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check immutability

3
racket/src/expander/expand/binding-for-transformer.rkt
View File

@ -25,5 +25,6 @@
[else
;; Use `binding-lookup` to both check for taints and determine whether the
;; binding is a transformer or variable binding
(define-values (val primitive? insp) (binding-lookup b empty-env null ns at-phase id))
(define-values (val primitive? insp protected?)
(binding-lookup b empty-env null ns at-phase id))
(not (variable? val))]))

9
racket/src/expander/expand/env.rkt
View File

@ -107,6 +107,7 @@
;; Returns: `variable` or a compile-time value
;; #f or #t indicating whether the binding is to a primitive
;; #f or (for a transformer) an inspector for the defining module
;; #f or #t for a protected binding
;; A binding provided to `binding-lookup` should be obtained either by
;; passing `#:immediate? #t` to `resolve+shift` or by using `resolve+shift/extra-inspector`,
;; where the latter checks protected access for `free-identifier=?` equivalence
@ -125,9 +126,10 @@
(check-taint id)
(define t (namespace-get-transformer m-ns (module-binding-phase b) (module-binding-sym b)
variable))
(when mi (check-access b mi id in-s (if (variable? t) "variable" "transformer")))
(define protected?
(and mi (check-access b mi id in-s (if (variable? t) "variable" "transformer"))))
(define insp (and mi (module-instance-module mi) (module-inspector (module-instance-module mi))))
(values t primitive? insp)]
(values t primitive? insp protected?)]
[(local-binding? b)
(define t (hash-ref env (local-binding-key b) missing))
(cond
@ -140,10 +142,11 @@
variable
(error "identifier used out of context:" id)))
#f
#f
#f)]
[else
(check-taint id)
(values t #f #f)])]
(values t #f #f #f)])]
[else (error "internal error: unknown binding for lookup:" b)]))
;; Check for taints on a variable reference

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

@ -627,9 +627,9 @@
#:immediate? #t))
(when (eq? binding 'ambiguous)
(raise-ambiguous-error id ctx))
(define-values (t primitive? insp) (if binding
(lookup binding ctx s)
(values #f #f #f)))
(define-values (t primitive? insp protected?) (if binding
(lookup binding ctx s)
(values #f #f #f #f)))
(log-expand ctx 'resolve id)
(cond
[(or (variable? t)
@ -703,12 +703,12 @@
(expand-context-allow-unbound? ctx))
(raise-unbound-syntax-error #f "unbound identifier" s var-id null
(syntax-debug-info-string var-id ctx)))
(define-values (t primitive? insp-of-t)
(define-values (t primitive? insp-of-t protected?)
(if binding
(lookup binding ctx var-id
#:in s
#:out-of-context-as-variable? (expand-context-in-local-expand? ctx))
(values #f #f #f)))
(values #f #f #f #f)))
(when (and t (not (variable? t)))
(raise-syntax-error #f "identifier does not refer to a variable" var-id s))
(if (expand-context-to-parsed? ctx)

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

@ -105,10 +105,11 @@
(expand-implicit '#%top (substitute-alternate-id s alternate-id) ctx s)]
[else
;; Variable or form as identifier macro
(define-values (t primitive? insp-of-t) (lookup binding ctx id
#:in (and alternate-id s)
#:out-of-context-as-variable? (expand-context-in-local-expand? ctx)))
(dispatch t insp-of-t s id ctx binding primitive?)])))
(define-values (t primitive? insp-of-t protected?)
(lookup binding ctx id
#:in (and alternate-id s)
#:out-of-context-as-variable? (expand-context-in-local-expand? ctx)))
(dispatch t insp-of-t s id ctx binding primitive? protected?)])))
;; An "application" form that starts with an identifier
(define (expand-id-application-form s ctx alternate-id)
@ -127,16 +128,17 @@
(expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)]
[else
;; Find out whether it's bound as a variable, syntax, or core form
(define-values (t primitive? insp-of-t) (lookup binding ctx id
#:in (and alternate-id (car (syntax-e/no-taint s)))
#:out-of-context-as-variable? (expand-context-in-local-expand? ctx)))
(define-values (t primitive? insp-of-t protected?)
(lookup binding ctx id
#:in (and alternate-id (car (syntax-e/no-taint s)))
#:out-of-context-as-variable? (expand-context-in-local-expand? ctx)))
(cond
[(variable? t)
;; Not as syntax or core form, so use implicit `#%app`
(expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)]
[else
;; Syntax or core form as "application"
(dispatch t insp-of-t s id ctx binding primitive?)])])))
(dispatch t insp-of-t s id ctx binding primitive? protected?)])])))
;; Handle an implicit: `#%app`, `#%top`, or `#%datum`; this is similar
;; to handling an id-application form, but there are several little
@ -160,7 +162,8 @@
[(eq? b 'ambiguous)
(raise-ambiguous-error id ctx)]
[else
(define-values (t primitive? insp-of-t) (if b (lookup b ctx id) (values #f #f #f)))
(define-values (t primitive? insp-of-t protected?)
(if b (lookup b ctx id) (values #f #f #f #f)))
(cond
[(transformer? t)
(dispatch-transformer t insp-of-t (make-explicit ctx sym s disarmed-s) id ctx b)]
@ -226,14 +229,14 @@
;; other compile-time value (which is an error), or a token
;; indicating that the binding is a run-time variable; note that
;; `s` is not disarmed
(define (dispatch t insp-of-t s id ctx binding primitive?)
(define (dispatch t insp-of-t s id ctx binding primitive? protected?)
(cond
[(core-form? t)
(dispatch-core-form t s ctx)]
[(transformer? t)
(dispatch-transformer t insp-of-t s id ctx binding)]
[(variable? t)
(dispatch-variable t s id ctx binding primitive?)]
(dispatch-variable t s id ctx binding primitive? protected?)]
[else
;; Some other compile-time value:
(raise-syntax-error #f "illegal use of syntax" s)]))
@ -301,7 +304,7 @@
(rename-transformer? t)))])]))
;; Handle the expansion of a variable to itself
(define (dispatch-variable t s id ctx binding primitive?)
(define (dispatch-variable t s id ctx binding primitive? protected?)
(cond
[(expand-context-only-immediate? ctx)
(log-expand* ctx ['exit-check s])
@ -321,8 +324,11 @@
(parsed-primitive-id prop-s binding insp)
(parsed-id prop-s binding insp))]
[else
(log-expand ctx 'return result-s)
result-s])]))
(define protected-result-s (if protected?
(syntax-property result-s 'protected #t)
result-s))
(log-expand ctx 'return protected-result-s)
protected-result-s])]))
;; ----------------------------------------

60
racket/src/expander/expand/protect.rkt
View File

@ -13,35 +13,41 @@
;; Check inspector-based access to a module's definitions; a suitable inspector
;; might be provided by `id`, or the binding might carry an extra inspector
;; (put there via a provide of a rename transformer, where the extra inspector
;; was attached to the identifier in the rename transformer)
;; was attached to the identifier in the rename transformer). Return #t if
;; the binding is protected.
(define (check-access b mi id in-s what)
(define m (module-instance-module mi))
(when (and m (not (module-no-protected? m)))
(define access (or (module-access m) (module-compute-access! m)))
(define a (hash-ref (hash-ref access (module-binding-phase b) #hasheq())
(module-binding-sym b)
'unexported))
(when (or (eq? a 'unexported) ; not provided => implicitly protected
(eq? a 'protected))
(unless (or (inspector-superior? (or (syntax-inspector id) (current-code-inspector))
(namespace-inspector (module-instance-namespace mi)))
(and (module-binding-extra-inspector b)
(inspector-superior? (module-binding-extra-inspector b)
(namespace-inspector (module-instance-namespace mi)))))
;; In the error message, use the original expression `in-s` or
;; the symbol protected or defined in the target module ---
;; but only if that name is different from `id`, which we'll
;; certainly include in the error
(define complain-id (let ([c-id (or in-s (module-binding-sym b))])
(and (not (eq? (if (syntax? c-id) (syntax-content c-id) c-id)
(syntax-content id)))
c-id)))
(raise-syntax-error #f
(format "access disallowed by code inspector to ~a ~a\n from module: ~a"
a
what
(module-path-index-resolve (namespace-mpi (module-instance-namespace mi))))
complain-id id null)))))
(cond
[(and m (not (module-no-protected? m)))
(define access (or (module-access m) (module-compute-access! m)))
(define a (hash-ref (hash-ref access (module-binding-phase b) #hasheq())
(module-binding-sym b)
'unexported))
(cond
[(or (eq? a 'unexported) ; not provided => implicitly protected
(eq? a 'protected))
(unless (or (inspector-superior? (or (syntax-inspector id) (current-code-inspector))
(namespace-inspector (module-instance-namespace mi)))
(and (module-binding-extra-inspector b)
(inspector-superior? (module-binding-extra-inspector b)
(namespace-inspector (module-instance-namespace mi)))))
;; In the error message, use the original expression `in-s` or
;; the symbol protected or defined in the target module ---
;; but only if that name is different from `id`, which we'll
;; certainly include in the error
(define complain-id (let ([c-id (or in-s (module-binding-sym b))])
(and (not (eq? (if (syntax? c-id) (syntax-content c-id) c-id)
(syntax-content id)))
c-id)))
(raise-syntax-error #f
(format "access disallowed by code inspector to ~a ~a\n from module: ~a"
a
what
(module-path-index-resolve (namespace-mpi (module-instance-namespace mi))))
complain-id id null))
#t]
[else #f])]
[else #f]))
;; Like `resolve+shift`, but follow `free-identifier=?` chains to
;; attach an inspector at the last step in the chain to the

3
racket/src/expander/expand/syntax-local.rkt
View File

@ -188,7 +188,8 @@
(failure-thunk)
(error 'syntax-local-value "unbound identifier: ~v" id))]
[else
(define-values (v primitive? insp) (lookup b ctx id #:out-of-context-as-variable? #t))
(define-values (v primitive? insp protected?)
(lookup b ctx id #:out-of-context-as-variable? #t))
(cond
[(or (variable? v) (core-form? v))
(log-expand ctx 'local-value-result #f)

2
racket/src/expander/namespace/api.rkt
View File

@ -180,7 +180,7 @@
(namespace-phase ns)
ns))
(when b (namespace-visit-available-modules! ns))
(define-values (v primitive? extra-inspector)
(define-values (v primitive? extra-inspector protected?)
(if b
(binding-lookup b empty-env null ns (namespace-phase ns) id)
(values variable #f #f)))

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

File diff suppressed because it is too large Load Diff