expander: add 'protected property to protected references

As documented and as implemented by the old expander.

pkgs/racket-test-core/tests/racket/stx.rktl

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

racket/src/expander/expand/binding-for-transformer.rkt

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

racket/src/expander/expand/env.rkt

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

racket/src/expander/expand/expr.rkt

@@ -627,9 +627,9 @@
                                     #:immediate? #t))
      (when (eq? binding 'ambiguous)
        (raise-ambiguous-error id ctx))
-     (define-values (t primitive? insp) (if binding
+     (define-values (t primitive? insp protected?) (if binding
-                                            (lookup binding ctx s)
+                                                       (lookup binding ctx s)
-                                            (values #f #f #f)))
+                                                       (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)

racket/src/expander/expand/main.rkt

@@ -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
+     (define-values (t primitive? insp-of-t protected?)
-                                                     #:in (and alternate-id s)
+       (lookup binding ctx id
-                                                     #:out-of-context-as-variable? (expand-context-in-local-expand? ctx)))
+               #:in (and alternate-id s)
-     (dispatch t insp-of-t s id ctx binding primitive?)])))
+               #: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
+     (define-values (t primitive? insp-of-t protected?)
-                                                     #:in (and alternate-id (car (syntax-e/no-taint s)))
+       (lookup binding ctx id
-                                                     #:out-of-context-as-variable? (expand-context-in-local-expand? ctx)))
+               #: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)
+       (define protected-result-s (if protected?
-       result-s])]))
+                                      (syntax-property result-s 'protected #t)
+                                      result-s))
+       (log-expand ctx 'return protected-result-s)
+       protected-result-s])]))
 
 ;; ----------------------------------------
 

racket/src/expander/expand/protect.rkt

@@ -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)))
+  (cond
-    (define access (or (module-access m) (module-compute-access! m)))
+    [(and m (not (module-no-protected? m)))
-    (define a (hash-ref (hash-ref access (module-binding-phase b) #hasheq())
+     (define access (or (module-access m) (module-compute-access! m)))
-                        (module-binding-sym b)
+     (define a (hash-ref (hash-ref access (module-binding-phase b) #hasheq())
-                        'unexported))
+                         (module-binding-sym b)
-    (when (or (eq? a 'unexported) ; not provided => implicitly protected
+                         'unexported))
-              (eq? a 'protected))
+     (cond
-      (unless (or (inspector-superior? (or (syntax-inspector id) (current-code-inspector))
+       [(or (eq? a 'unexported) ; not provided => implicitly protected
-                                       (namespace-inspector (module-instance-namespace mi)))
+            (eq? a 'protected))
-                  (and (module-binding-extra-inspector b)
+        (unless (or (inspector-superior? (or (syntax-inspector id) (current-code-inspector))
-                       (inspector-superior? (module-binding-extra-inspector b)
+                                         (namespace-inspector (module-instance-namespace mi)))
-                                            (namespace-inspector (module-instance-namespace mi)))))
+                    (and (module-binding-extra-inspector b)
-        ;; In the error message, use the original expression `in-s` or
+                         (inspector-superior? (module-binding-extra-inspector b)
-        ;; the symbol protected or defined in the target module ---
+                                              (namespace-inspector (module-instance-namespace mi)))))
-        ;; but only if that name is different from `id`, which we'll
+          ;; In the error message, use the original expression `in-s` or
-        ;; certainly include in the error
+          ;; the symbol protected or defined in the target module ---
-        (define complain-id (let ([c-id (or in-s (module-binding-sym b))])
+          ;; but only if that name is different from `id`, which we'll
-                              (and (not (eq? (if (syntax? c-id) (syntax-content c-id) c-id)
+          ;; certainly include in the error
-                                             (syntax-content id)))
+          (define complain-id (let ([c-id (or in-s (module-binding-sym b))])
-                                   c-id)))
+                                (and (not (eq? (if (syntax? c-id) (syntax-content c-id) c-id)
-        (raise-syntax-error #f
+                                               (syntax-content id)))
-                            (format "access disallowed by code inspector to ~a ~a\n  from module: ~a"
+                                     c-id)))
-                                    a
+          (raise-syntax-error #f
-                                    what
+                              (format "access disallowed by code inspector to ~a ~a\n  from module: ~a"
-                                    (module-path-index-resolve (namespace-mpi (module-instance-namespace mi))))
+                                      a
-                            complain-id id null)))))
+                                      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

racket/src/expander/expand/syntax-local.rkt

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

racket/src/expander/namespace/api.rkt

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