racket-body, syntax class expander, syntax interpreter tutorial, multipass tutorial

info.rkt

@@ -11,4 +11,4 @@
 (define build-deps '("racket-doc" "scribble-lib" "drracket" "typed-racket-lib"))
 (define scribblings '(("scribblings/main.scrbl" (multi-page) (experimental) "syntax-spec-dev")))
 (define compile-omit-paths '("design" "demos"))
-(define test-omit-paths '("design" "demos"))
+(define test-omit-paths '("scribblings" "design" "demos"))

main.rkt

@@ -7,6 +7,8 @@
           ...
           ...+
 
+          #%host-expression
+
           mutable-reference-compiler
           immutable-reference-compiler
 
@@ -53,12 +55,14 @@
           free-identifiers
           binding-identifiers
           alpha-equivalent?
+          subst
           get-racket-referenced-identifiers))
 
 (require "private/syntax/interface.rkt"
          "private/runtime/compile.rkt"
          (for-syntax syntax/parse
                      (except-in "private/ee-lib/main.rkt" racket-var)
+                     "private/runtime/compile.rkt"
                      "private/ee-lib/persistent-id-table.rkt"
                      "private/ee-lib/binding.rkt"
                      "private/runtime/binding-operations.rkt"

private/ee-lib/flip-intro-scope.rkt

@@ -16,4 +16,6 @@
 
 (define/who (flip-intro-scope stx)
   (check who syntax? stx)
-  ((make-intro-scope-introducer) stx 'flip))
+  (if (syntax-transforming?)
+      ((make-intro-scope-introducer) stx 'flip)
+      stx))

private/runtime/binding-operations.rkt

@@ -2,7 +2,9 @@
 
 (provide free-identifiers
          binding-identifiers
+         identifier=?
          alpha-equivalent?
+         subst
          get-racket-referenced-identifiers
          (rename-out [identifier=? compiled-identifier=?]))
 
@@ -99,25 +101,22 @@
 ; Syntax, Syntax [#:allow-host? Boolean] -> Boolean
 ; Are the two expressions alpha-equivalent?
 (define (alpha-equivalent? stx-a stx-b #:allow-host? [allow-host? #f])
-  (define bound-reference=? (alpha-equivalent?/bindings stx-a stx-b allow-host?))
+  (define bound-reference=? (syntaxes->bound-reference=? stx-a stx-b allow-host?))
   (and bound-reference=?
        (alpha-equivalent?/references stx-a stx-b bound-reference=? allow-host?)))
 
 ; Syntax Syntax Boolean -> (or/c #f (Identifier Identifier -> Boolean))
-; check that the bindings of both expressions can be alpha-equivalent.
-; returns bound-reference=?, or #f if the binding check fails.
-(define (alpha-equivalent?/bindings stx-a stx-b allow-host?)
+; if the two terms have corresponding binders, build bound-reference=?
+; If they have different numbers of binders, return #f
+; bound-reference=? answers "do these two references refer to corresponding binders?"
+(define (syntaxes->bound-reference=? stx-a stx-b allow-host?)
   (define table-a (make-free-id-table))
   (define table-b (make-free-id-table))
+  ;; associate both binders with the same gensym
   (define (bind! identifier-a identifier-b)
     (define x (gensym))
-    (free-id-table-set! table-a identifier-a x)
-    (free-id-table-set! table-b identifier-b x))
-  (define (bound-reference=? identifier-a identifier-b)
-    (and (dict-has-key? table-a identifier-a)
-         (dict-has-key? table-b identifier-b)
-         (eq? (free-id-table-ref table-a identifier-a)
-              (free-id-table-ref table-b identifier-b))))
+    (free-id-table-set! table-a (compiled-from identifier-a) x)
+    (free-id-table-set! table-b (compiled-from identifier-b) x))
   (define binders-a (binding-identifiers stx-a #:allow-host? allow-host?))
   (define binders-b (binding-identifiers stx-b #:allow-host? allow-host?))
   ; must traverse binders before references
@@ -127,7 +126,16 @@
         [binder-b binders-b])
     (bind! binder-a binder-b))
   (and (= (length binders-a) (length binders-b))
-       bound-reference=?))
+       (substitutions->bound-reference=? table-a table-b)))
+
+;; FreeIdTable FreeIdTable -> (Identifier Identifier -> Boolean)
+;; Do these two references refer to corresponding binders?
+;; table-a and table-b should map corresponding binders to the same, unique value
+(define ((substitutions->bound-reference=? table-a table-b) identifier-a identifier-b)
+  (and (dict-has-key? table-a (compiled-from identifier-a))
+       (dict-has-key? table-b (compiled-from identifier-b))
+       (eq? (free-id-table-ref table-a (compiled-from identifier-a))
+            (free-id-table-ref table-b (compiled-from identifier-b)))))
 
 ; Syntax Syntax (Identifier Identifier -> Boolean) Boolean -> Boolean
 ; check that the references are alpha-equivalent.
@@ -159,6 +167,22 @@
       [(a b) (equal? (syntax->datum #'a)
                      (syntax->datum #'b))])))
 
+;; Syntax Syntax Syntax -> Syntax
+;; Replace all occurrences of target (by alpha equivalence) with replacement in stx.
+;; Leaves host expressions unchanged.
+(define (subst stx target replacement)
+  (let loop ([stx stx])
+    (if (if (compiled-binder? target)
+            (and (compiled-reference? stx) (identifier=? stx target))
+            (alpha-equivalent? stx target))
+        replacement
+        (syntax-parse stx
+          ;; ignore host expressions
+          [((~literal #%host-expression) . _) this-syntax]
+          [(a . b)
+           (quasisyntax/loc this-syntax (#,(loop #'a) . #,(loop #'b)))]
+          [_ stx]))))
+
 (define current-referenced-vars (make-parameter #f))
 
 ; get the racket vars referenced in e of the provided binding classes
@@ -174,9 +198,7 @@
                   'expression
                   '())
 
-    (sequence->list (in-symbol-set (for/fold ([references (immutable-symbol-set)])
-                                             ([x (in-symbol-set (current-referenced-vars))])
-                                     (symbol-set-add references x))))))
+    (sequence->list (in-symbol-set (current-referenced-vars)))))
 
 (define recording-reference-compiler
   (make-variable-like-reference-compiler

private/syntax/interface.rkt

@@ -359,6 +359,9 @@
     ((~literal define-syntaxes) (x:racket-macro ...) e:expr)
     #:binding (export-syntaxes x ... e)
 
+    ((~literal begin) b:racket-body ...)
+    #:binding [(re-export b) ...]
+
     e:racket-expr))
 
 (define-syntax define-dsl-syntax

private/test/syntax-class-expander.rkt

@@ -0,0 +1,238 @@
+#lang racket/base
+
+;; Similar to private/test/simple-bsepc.rkt, but attempting to create an expander that
+;; uses syntax classes for nonterminals.
+;; This was created to research a potential solution for
+;; https://github.com/michaelballantyne/syntax-spec/issues/62
+
+(require
+  (for-syntax
+   racket/base
+   syntax/parse
+   "../ee-lib/main.rkt"
+   "../runtime/binding-spec.rkt")
+
+  "../ee-lib/define.rkt")
+
+#;;; ANF language
+(syntax-spec
+  (binding-class my-var)
+  (nonterminal a-expr
+    e:c-expr
+    (my-let ([x:my-var e:c-expr]) b:a-expr)
+    #:binding (scope (bind x) b)
+    ;; body will expand before binding x
+    (where b:a-expr
+      ([x:my-var e:c-expr]))
+    #:binding (scope (bind x) b))
+  (nonterminal c-expr
+    e:i-expr
+    (my-+ a:i-expr b:i-expr)
+    ;; application
+    (a:i-expr b:i-expr c:i-expr))
+  (nonterminal i-expr
+    n:number
+    x:my-var))
+
+(define-literal-forms anf-lits
+  "mylang forms may only be used in mylang"
+  (my-let my-+ where))
+
+(begin-for-syntax
+  (struct my-var-rep ())
+
+  ;; hash from symbols to binding representations
+  ;; to simulate the real expander environment
+  (define pretend-binding-store (make-hash (list (cons 'bogus #f))))
+
+  (define-syntax-class a-expr
+    #:no-delimit-cut
+    #:literal-sets (anf-lits)
+    (pattern e:c-expr
+             #:attr expanded #'e.expanded)
+    (pattern (my-let ~! ([x:id e:expr]) b:expr)
+             ;; we expand x and b BEFORE e because the binding spec is
+             ;; [(scope (bind x) b) e]
+             ;; expansion order is driven by the binding spec
+             #:with x^:my-var-bind #'x
+             #:with b^:a-expr #'b
+             #:with e^:c-expr #'e
+             #:attr expanded #'(my-let ([x^.expanded e^.expanded]) b^.expanded))
+    (pattern (where ~! b:expr ([x:id e:expr]))
+             ;; we expand x and b BEFORE e because the binding spec is
+             ;; [(scope (bind x) b) e]
+             ;; expansion order is driven by the binding spec
+             #:with x^:my-var-bind #'x
+             #:with b^:a-expr #'b
+             #:with e^:c-expr #'e
+             #:attr expanded #'(where b^.expanded ([x^.expanded e^.expanded]))))
+
+  (define-syntax-class c-expr
+    #:no-delimit-cut
+    #:literal-sets (anf-lits)
+    (pattern e:i-expr
+             #:attr expanded (attribute e.expanded))
+    ;; my-+ should be first, but due to the fake binding store,
+    ;; to get the my-+ shadowing test passing, this needed to be first.
+    ;; in a real implementation with the real binding store, the my-+ pattern would
+    ;; fail because the identifier wouldn't be referencing the literal, right?.
+    ;; you'd need to be painting scopes on syntax as you go, but that could happen in
+    ;; the pattern actions I guess.
+    (pattern (a:expr b:expr c:expr)
+             #:with a^:i-expr #'a
+             #:with b^:i-expr #'b
+             #:with c^:i-expr #'c
+             #:attr expanded #'(#%app a^.expanded b^.expanded c^.expanded))
+    (pattern (my-+ ~! a:expr b:expr)
+             #:with a^:i-expr #'a
+             #:with b^:i-expr #'b
+             #:attr expanded #'(my-+ a^.expanded b^.expanded)))
+
+  (define-syntax-class i-expr
+    #:no-delimit-cut
+    #:literal-sets (anf-lits)
+    (pattern n:number
+             #:attr expanded #'n)
+    (pattern x:my-var-ref
+             #:attr expanded #'x.expanded))
+
+  (define-syntax-class my-var-bind
+    #:no-delimit-cut
+    (pattern (~and x:id
+                   (~do (when (hash-has-key? pretend-binding-store (syntax->datum #'x))
+                          (raise-syntax-error 'my-lang "duplicate binding" #'x))
+                        (hash-set! pretend-binding-store (syntax->datum #'x) (my-var-rep)))
+                   (~undo (error "backtracked over a binding. flaw in language itself")))
+             #:attr expanded #'x))
+
+  (define-syntax-class my-var-ref
+    #:no-delimit-cut
+    (pattern x:id
+             #:fail-unless (hash-has-key? pretend-binding-store (syntax->datum #'x)) "unbound variable"
+             #:fail-unless (my-var-rep? (hash-ref pretend-binding-store (syntax->datum #'x))) "expected a my-var"
+             #:attr expanded #'x)))
+
+(define-syntax (mylang stx)
+  (set! pretend-binding-store (make-hash (list (cons 'bogus #f))))
+  (syntax-parse stx
+    [(_ e:a-expr)
+     #''e.expanded]))
+
+(require rackunit syntax/macro-testing)
+
+(define-syntax-rule (check-success e)
+  (check-equal? (mylang e)
+                'e))
+(define-syntax-rule (check-failure e msg)
+  (check-exn
+   msg
+   (lambda ()
+     (convert-compile-time-error (mylang e)))))
+
+(check-success 1)
+(check-success (my-+ 1 2))
+(check-success (my-let ([x 1]) x))
+(check-failure
+ y
+ #rx"unbound var")
+(check-failure
+ (my-let ([a 1])
+   (my-let ([a 2])
+     3))
+ #rx"duplicate binding")
+(check-failure
+ bogus
+ #rx"expected a my-var")
+(check-failure
+ (my-+ (my-let ([z 1]) z) 2)
+ #rx"expected number or expected identifier")
+;; where.
+;; this test fails if you expand left-to-right
+(check-success
+ (where x
+   ([x 1])))
+;; shadow my-+ in where.
+;; this test fails if you expand left-to-right
+(check-equal? (mylang (where (my-+ 1 2)
+                        ([my-+ 3])))
+              ;; should not treat my-+ as a literal in the where body
+              '(where (#%app my-+ 1 2)
+                 ([my-+ 3])))
+;; can't backtrack over a binding
+(check-failure
+ (my-let ([x y]) x)
+ ;; an unbound var error would be better here
+ #rx"backtracked over a binding")
+;; can't backtrack over a binding
+(check-failure
+ (my-let ([x (my-+ y y)]) x)
+ #rx"backtracked over a binding")
+
+#|
+examples that broke the original eager design:
+(where x
+  ([x 1]))
+this broke bc the reference parsed/expanded before the binding. syntax-parse parses (and thus expands bc of attr eagerness)
+left to right.
+(where (my-+ 1 2)
+  ([my-+ 3]))
+this broke for a similar reason. This shows that even "structural" parsing needs bindings to detect literal shadowing.
+
+problems:
+- if you do everything eager (and do binding class resolution in parsing), then where breaks because the body
+gets parsed before the binding happens
+- if you treat all ids as ids and ignore binding classes during parsing, then the my-+ shadow thing fails
+because it will resolve to the literal instead of the shadowed thing
+- the solution is to do binding-spec-driven expansion order, which requires promises and binding stuff has to happen in the post of the production.
+but then, you'll still get the my-+ shadow problem because parsing needs to be driven by binding classes
+to distinguish between shadowed literals and actual literals.
+
+constraints:
+- to resolve literals vs references to bindings that shadow literals, you need to bind as you parse
+- to do that, you need to delay parsing. parsing and expansion order must be driven by the binding spec.
+- to avoid backtracking over a binding, you need to commit when you bind
+
+you can delay parsing with #:with
+
+current desired semantics:
+full backtracking (even over binding classes), except you commit when you bind a variable.
+TODO does cut in a post commit the way you need it to?
+No, I don't think so. I ended up needing to put ~! in the production structure pattern
+
+example:
+
+(nonterminal my-expr
+  n:number
+  x:a-var
+  x:b-var
+  (let ([x:a-var e:my-expr]) b:my-expr)
+  #:binding (scope (bind x) b)
+  (let ([x:b-var e:my-expr]) b:my-expr)
+  #:binding (scope (bind x) b))
+
+identifiers don't commit to a-var (which I'm pretty sure is the current syntax-spec behavior)
+but (let ([x 1]) x) commits to the a-var let production
+|#
+
+#|
+After solving where and literal shadowing:
+
+The current semantics are full backtracking, with the exception that
+binding sites cause commitment.
+
+limitation: moving sub-parsing into #:with messes up failure progress measurement.
+many parse attempt paths end up with the same LATE progress so error messages suck.
+
+constraints:
+- we need #:post or equivalent to control order of sub-expansion and therefore sub-parsing
+- when most sub-parsing happens in posts, we get failure progress ties (lots of things are just LATE), which cause vague error messages.
+- within a pattern, it looks like each post does not contribute additional progress beyond a single LATE. Not sure about this though.
+
+
+
+
+
+new design:
+- form groups commit on literals
+- trying to backtrack over bindings is an error
+|#