global reference compilers

fixes #55

private/runtime/compile.rkt

@@ -3,6 +3,7 @@
 (provide #%host-expression
          with-reference-compilers
          (for-syntax setup-default-reference-compilers!
+                     add-global-reference-compiler!
                      binding-as-rkt
                      make-suspension
 
@@ -136,7 +137,13 @@
       (for/fold ([env (current-reference-compilers)])
                 ([pair assocs])
         (free-id-table-set env (first pair) (second pair))))
-   (current-reference-compilers new-reference-compilers)))
+   (current-reference-compilers new-reference-compilers))
+  #;(identifier? reference-compiler? -> void?)
+  ; globally associates binding class with reference compiler.
+  ; NOTE: this should never be called in the dynamic extent of a with-reference-compilers,
+  ; or generally within a parameterization of current-reference-compilers, since it mutates the parameter.
+  (define (add-global-reference-compiler! bclass compiler)
+    (current-reference-compilers (free-id-table-set (current-reference-compilers) bclass compiler))))
 
 (define-syntax with-reference-compilers
   (let ([who 'with-reference-compilers])

private/syntax/interface.rkt

@@ -91,7 +91,8 @@
       [(binding-class
         ~! name:id
         (~var descr (maybe-description #'name))
-        (~var space maybe-binding-space))
+        (~var space maybe-binding-space)
+        (~var reference-compiler maybe-reference-compiler))
        (with-syntax ([sname (format-id #'here "~a-var" #'name)]
                      [sname-pred (format-id #'here "~a-var?" #'name)])
          (values
@@ -105,7 +106,8 @@
                  (#%datum . descr.str)
                  (quote-syntax sname)
                  (quote-syntax sname-pred)
-                 (quote space.stx))))
+                 (quote space.stx)))
+              (~? (add-global-reference-compiler! #'name reference-compiler.compiler)))
           #f
           #f))]
 

private/syntax/syntax-classes.rkt

@@ -7,6 +7,7 @@
 
  maybe-description
  maybe-binding-space
+ maybe-reference-compiler
 
  nested-binding-syntax
  sspec-term
@@ -70,6 +71,10 @@
   (pattern (~optional (~seq #:binding-space stx:id) #:defaults ([stx #'#f]))
     #:attr sym (syntax-e (attribute stx))))
 
+(define-splicing-syntax-class maybe-reference-compiler
+  (pattern (~optional (~seq #:reference-compiler ~! compiler-stx))
+           #:attr compiler (attribute compiler-stx)))
+
 (define current-orig-stx (make-parameter #f))
 
 ;; Used for meta-level errors where there is no good more-specific form
@@ -211,4 +216,4 @@
   (pattern _))
 
 (define-splicing-syntax-class maybe-binding-decl
-  (pattern (~optional (~seq #:binding ~! bspec))))
+  (pattern (~optional (~seq #:binding ~! bspec))))

scribblings/reference/compiling.scrbl

@@ -15,7 +15,7 @@
 
 @title{Compiling languages}
 
-@section{Compiling references to DSL bindings within Racket code}
+@section[#:tag "reference compilers"]{Compiling references to DSL bindings within Racket code}
 
 @margin-note{@secref["compilation" #:doc '(lib "syntax-spec/scribblings/main.scrbl")] in the @secref["Basic_Tutorial__State_Machine_Language"
          #:doc '(lib "syntax-spec/scribblings/main.scrbl")] introduces the use of reference compilers.}
@@ -26,7 +26,7 @@ When a reference appears in the head of a form, such as @racket[x] in @racket[(x
 
 In all cases, the reference identifier in the syntax provided to the reference compiler is a @tech{compiled identifier}.
 
-DSL compilers specify the reference compilers to use by emitting compiled code containing @racket[with-reference-compiler] forms.
+Reference compilers can be specified in the @racket[#:reference-compiler] option of a @racket[binding-class] form. For more local control over reference compilers, your compiler can emit code containing @racket[with-reference-compilers]:
 
 @defform[(with-reference-compilers
              ([binding-class-id reference-compiler-expr] ...)

scribblings/reference/specifying.scrbl

@@ -40,19 +40,26 @@ The following subsections address each kind of declaration allowed within the
 binder, it is an error if the binding class declared for the reference position
 does not match the binding class of the binding position.
 
-@defsubform[(binding-class id maybe-description maybe-binding-space)
+@defsubform[(binding-class id maybe-description maybe-binding-space maybe-reference-compiler)
             #:grammar
             [(maybe-description (code:line #:description string-literal)
                                 (code:line))
              (maybe-binding-space (code:line #:binding-space space-symbol)
-                                  (code:line))]]
+                                  (code:line))
+             (maybe-reference-compiler (code:line #:reference-compiler reference-compiler-expr)
+                                       (code:line))]]
 
 The @racket[#:description] option provides a user-friendly phrase describing the
 kind of binding. This description is used in error messages.
 
 The @racket[#:binding-space] option specifies a @tech/reference{binding space}
 to use for all bindings and references declared with this class.
 
+@margin-note{See @secref["reference compilers"] for more information about reference compilers}
+
+The @racket[#:reference-compiler] option specifies a @tech{reference compiler} for controlling how
+references to variables of this binding class are treated in Racket code.
+
 Operationally, the binding space declaration causes the syntax-spec expander to
 add the binding space scope to bindings and references.
 @;

scribblings/tutorial/basic-tutorial.scrbl

@@ -364,6 +364,7 @@ Now Let's start to write the compiler:
 
 @racketblock[
 (syntax-spec
+  (binding-class event-var #:reference-compiler mutable-reference-compiler)
   ...
   (host-interface/expression
     (machine #:initial initial-state:state-name s:state-spec ...)
@@ -379,35 +380,34 @@ Now Let's start to write the compiler:
           (~optional (on-enter action ...) #:defaults ([(action 1) '()]))
           e ...)
         ...)
-     #'(with-reference-compilers ([event-var mutable-reference-compiler])
-         (let ()
-           (define machine%
-             (class object%
-               (define state #f)
-               (define/public (set-state state%)
-                 (set! state (new state% [machine this])))
-               (define/public (get-state)
-                 (send state get-state))
-
-               (compile-proxy-methods (e ... ...) state)
-
-               (send this set-state initial-state)
-               (super-new)))
-
-           (define state-name
-             (class object%
-               (init-field machine)
-               (define/public (get-state)
-                 'state-name)
-               action ...
-               (compile-event-method e machine) ...
-               (super-new)))
-           ...
-
-           (new machine%)))]))
+     #'(let ()
+         (define machine%
+           (class object%
+             (define state #f)
+             (define/public (set-state state%)
+               (set! state (new state% [machine this])))
+             (define/public (get-state)
+               (send state get-state))
+
+             (compile-proxy-methods (e ... ...) state)
+
+             (send this set-state initial-state)
+             (super-new)))
+
+         (define state-name
+           (class object%
+             (init-field machine)
+             (define/public (get-state)
+               'state-name)
+             action ...
+             (compile-event-method e machine) ...
+             (super-new)))
+         ...
+
+         (new machine%))]))
 ]
 
-We defined a macro, @racket[compile-machine], which expands to something similar to what we wrote by hand above. One thing we have to do with syntax-spec is wrap the generated code in a @racket[with-reference-compilers] form. This allows us to control whether and how DSL identifiers behave in Racket expressions like actions. In our case, we use @racket[mutable-reference-compiler], which allows event arguments to be referenced and mutated. We don't specify a reference compiler for state names, so they cannot be referenced in Racket expressions. Only @racket[goto].
+We defined a macro, @racket[compile-machine], which expands to something similar to what we wrote by hand above. One thing we have to do with syntax-spec is declare a reference compiler in the @racket[binding-class] declaration. This allows us to control whether and how DSL identifiers behave in Racket expressions like actions. In our case, we use @racket[mutable-reference-compiler], which allows event arguments to be referenced and mutated. We don't specify a reference compiler for state names, so they cannot be referenced in Racket expressions. Only @racket[goto].
 
 We have helpers to define the proxy methods in the @racket[machine%] class and transition methods in the state classes:
 

scribblings/tutorial/stlc-tutorial.scrbl

@@ -253,6 +253,7 @@ Let's do it!
 
 @racketblock[#:escape unracket
 (syntax-spec
+  (binding-class typed-var #:reference-compiler typed-var-reference-compiler)
   ...
 
   (nonterminal typed-expr
@@ -286,8 +287,7 @@ Let's do it!
     [(_ e t-stx)
      (define t (syntax->datum #'t-stx))
      (define/syntax-parse e^
-       #'(with-reference-compilers ([typed-var typed-var-reference-compiler])
-           (compile-expr e)))
+       #'(compile-expr e))
      #`(contract #,(type->contract-stx t)
                  e^
                  'stlc 'racket

tests/dsls/simply-typed-lambda-calculus.rkt

@@ -11,70 +11,6 @@
          racket/contract
          (for-syntax (only-in "../../private/ee-lib/main.rkt" compiled-from) racket/sequence racket/match syntax/transformer))
 
-(syntax-spec
-  (binding-class typed-var)
-  (extension-class typed-macro #:binding-space stlc)
-  (nonterminal typed-expr
-    #:allow-extension typed-macro
-    #:binding-space stlc
-
-    x:typed-var
-    n:number
-
-    (#%lambda ([x:typed-var (~datum :) t:type] ...) body:typed-expr)
-    #:binding (scope (bind x) ... body)
-    (#%app fun:typed-expr arg:typed-expr ...)
-
-    (#%let ([x:typed-var e:typed-expr] ...) body:typed-expr)
-    #:binding (scope (bind x) ... body)
-
-    ; type annotation
-    (~> (e (~datum :) t)
-        #'(: e t))
-    (: e:typed-expr t:type)
-
-    (rkt e:racket-expr (~datum :) t:type)
-
-    (block d:typed-definition-or-expr ... e:typed-expr)
-    #:binding (scope (import d) ... e)
-
-    ; rewrite for tagging applications
-    (~> (fun arg ...)
-        #'(#%app fun arg ...)))
-  (nonterminal type
-    (~datum Number)
-    ((~datum ->) arg-type:type ... return-type:type))
-  (nonterminal/exporting typed-definition-or-expr
-    #:allow-extension typed-macro
-    #:binding-space stlc
-    (#%define x:typed-var t:type e:typed-expr)
-    #:binding (export x)
-    (begin defn:typed-definition-or-expr ...+)
-    #:binding [(re-export defn) ...]
-    e:typed-expr)
-  (host-interface/expression
-   (stlc/expr e:typed-expr)
-   (define/syntax-parse t (infer-expr-type #'e))
-   #'(compile-expr/top e t))
-  (host-interface/expression
-   (stlc/infer e:typed-expr)
-   (define t (infer-expr-type #'e))
-   (define t-datum (type->datum t))
-   #`'#,t-datum)
-  (host-interface/definitions
-   (stlc body:typed-definition-or-expr ...+)
-   #:binding [(re-export body) ...]
-   (type-check-defn-or-expr/pass1 #'(begin body ...))
-   (type-check-defn-or-expr/pass2 #'(begin body ...))
-   #'(compile-defn-or-expr/top (begin body ...)))
-  (host-interface/definitions
-   (stlc/module-begin body:typed-definition-or-expr ...+)
-   #:binding [(re-export body) ...]
-   (type-check-defn-or-expr/pass1 #'(begin body ...))
-   (type-check-defn-or-expr/pass2 #'(begin body ...))
-   (define/syntax-parse (name ...) (sequence->list (sequence-map compiled-from (in-symbol-set (definition-names #'(begin body ...))))))
-   #'(begin (provide name ...) (compile-defn-or-expr/top (begin body ...)))))
-
 (begin-for-syntax
   ; a Type is one of
   (struct number-type [] #:prefab)
@@ -205,8 +141,7 @@
     [(_ e t-stx (~optional should-skip-contract?))
      (define t (syntax->datum #'t-stx))
      (define/syntax-parse e^
-       #'(with-reference-compilers ([typed-var typed-var-reference-compiler])
-           (compile-expr e)))
+       #'(compile-expr e))
      (if (attribute should-skip-contract?)
          #'e^
          #`(contract #,(type->contract-stx t)
@@ -274,6 +209,69 @@
     [(_ e)
      #'(compile-expr e)]))
 
+(syntax-spec
+  (binding-class typed-var #:reference-compiler typed-var-reference-compiler)
+  (extension-class typed-macro #:binding-space stlc)
+  (nonterminal typed-expr
+    #:allow-extension typed-macro
+    #:binding-space stlc
+
+    x:typed-var
+    n:number
+
+    (#%lambda ([x:typed-var (~datum :) t:type] ...) body:typed-expr)
+    #:binding (scope (bind x) ... body)
+    (#%app fun:typed-expr arg:typed-expr ...)
+
+    (#%let ([x:typed-var e:typed-expr] ...) body:typed-expr)
+    #:binding (scope (bind x) ... body)
+
+    ; type annotation
+    (~> (e (~datum :) t)
+        #'(: e t))
+    (: e:typed-expr t:type)
+
+    (rkt e:racket-expr (~datum :) t:type)
+
+    (block d:typed-definition-or-expr ... e:typed-expr)
+    #:binding (scope (import d) ... e)
+
+    ; rewrite for tagging applications
+    (~> (fun arg ...)
+        #'(#%app fun arg ...)))
+  (nonterminal type
+    (~datum Number)
+    ((~datum ->) arg-type:type ... return-type:type))
+  (nonterminal/exporting typed-definition-or-expr
+    #:allow-extension typed-macro
+    #:binding-space stlc
+    (#%define x:typed-var t:type e:typed-expr)
+    #:binding (export x)
+    (begin defn:typed-definition-or-expr ...+)
+    #:binding [(re-export defn) ...]
+    e:typed-expr)
+  (host-interface/expression
+   (stlc/expr e:typed-expr)
+   (define/syntax-parse t (infer-expr-type #'e))
+   #'(compile-expr/top e t))
+  (host-interface/expression
+   (stlc/infer e:typed-expr)
+   (define t (infer-expr-type #'e))
+   (define t-datum (type->datum t))
+   #`'#,t-datum)
+  (host-interface/definitions
+   (stlc body:typed-definition-or-expr ...+)
+   #:binding [(re-export body) ...]
+   (type-check-defn-or-expr/pass1 #'(begin body ...))
+   (type-check-defn-or-expr/pass2 #'(begin body ...))
+   #'(compile-defn-or-expr/top (begin body ...)))
+  (host-interface/definitions
+   (stlc/module-begin body:typed-definition-or-expr ...+)
+   #:binding [(re-export body) ...]
+   (type-check-defn-or-expr/pass1 #'(begin body ...))
+   (type-check-defn-or-expr/pass2 #'(begin body ...))
+   (define/syntax-parse (name ...) (sequence->list (sequence-map compiled-from (in-symbol-set (definition-names #'(begin body ...))))))
+   #'(begin (provide name ...) (compile-defn-or-expr/top (begin body ...)))))
 
 (define-syntax define-stlc-syntax
   (syntax-parser