Merge pull request #49 from quasarbright/main

various fixes

private/syntax/compile/binding-spec.rkt

@@ -188,24 +188,8 @@
       (elaborate-pvar (attribute v-transformer)
                       (? stxclass-rep?)
                       "syntax class"))]
-    [(nest v:nonref-id spec:bspec-term)
-     (nest-one
-      this-syntax
-      (elaborate-pvar (attribute v)
-                      (s* nonterm-rep [variant-info (s* nesting-nonterm-info)])
-                      "nesting nonterminal")
-      (elaborate-bspec (attribute spec)))]
-    [(nest ~! v:nonref-id (~and (~literal ...) ooo) ...+ spec:bspec-term)
-     (define depth (length (attribute ooo)))
-     (when (> depth 1)
-       (wrong-syntax/orig this-syntax "nest cannot contain more than one ellipsis"))
-     (nest
-      this-syntax
-      depth
-      (elaborate-pvar (attribute v)
-                      (s* nonterm-rep [variant-info (s* nesting-nonterm-info)])
-                      "nesting nonterminal")
-      (elaborate-bspec (attribute spec)))]
+    [(nest ~! v:nonref-id rest ...+)
+     (elaborate-nest #'(nest v rest ...))]
     [(host ~! v:nonref-id)
      (suspend
       this-syntax
@@ -225,12 +209,37 @@
     [(spec (~and ooo (~literal ...)) ... . specs)
      ; however many ellipses follow the pattern, wrap the elaborated spec with
      ; the ellipses struct that many times.
-     (cons (for/fold ([spec (elaborate-bspec (attribute spec))])
+     (cons (for/fold ([spec-elaborated (elaborate-bspec (attribute spec))])
                      ([ooo (attribute ooo)])
-             (ellipsis ooo spec))
+             (ellipsis (attribute spec) spec-elaborated))
            (elaborate-group (attribute specs)))]
     [() '()]))
 
+; helps convert (nest x y ... z e) stx
+; into an elaborated representation like
+; (next-one x (nest y (nest-one z e)))
+(define elaborate-nest
+  (syntax-parser
+    [(_ spec) (elaborate-bspec #'spec)]
+    [(_ v:nonref-id (~and (~literal ...) ooo) ...+ rest ...+)
+     (define depth (length (attribute ooo)))
+     (when (> depth 1)
+       (wrong-syntax/syntax-spec this-syntax "nest cannot contain more than one ellipsis"))
+     (nest
+      this-syntax
+      depth
+      (elaborate-pvar (attribute v)
+                      (s* nonterm-rep [variant-info (s* nesting-nonterm-info)])
+                      "nesting nonterminal")
+      (elaborate-nest #'(nest rest ...)))]
+    [(_  v:nonref-id rest ...+)
+     (nest-one
+      this-syntax
+      (elaborate-pvar (attribute v)
+                      (s* nonterm-rep [variant-info (s* nesting-nonterm-info)])
+                      "nesting nonterminal")
+      (elaborate-nest #'(nest rest ...)))]))
+
 ;; Elaborator helpers
 
 #;(identifier? -> BSpec)
@@ -262,15 +271,15 @@
   (define binding (lookup v pvar-rep?))
   (when (not binding)
     (if (identifier? (current-syntax-context))
-        (wrong-syntax/orig v "binding spec expected a reference to a pattern variable")
+        (wrong-syntax/syntax-spec v "binding spec expected a reference to a pattern variable")
         (wrong-syntax v "expected a reference to a pattern variable")))
   (pvar-rep-var-info binding))
 
 (define (lookup-pvar-depth v)
   (define binding (lookup v pvar-rep?))
   (when (not binding)
     (if (identifier? (current-syntax-context))
-        (wrong-syntax/orig v "binding spec expected a reference to a pattern variable")
+        (wrong-syntax/syntax-spec v "binding spec expected a reference to a pattern variable")
         (wrong-syntax v "expected a reference to a pattern variable")))
   (pvar-rep-depth binding))
 
@@ -279,7 +288,7 @@
   (define maybe-dup (check-duplicates pvars free-identifier=?))
 
   (when maybe-dup
-    (wrong-syntax/orig maybe-dup "each pattern variable must occur in the binding spec at most once")))
+    (wrong-syntax/syntax-spec maybe-dup "each pattern variable must occur in the binding spec at most once")))
 
 (define (check-ellipsis-depth! bspec)
   (let loop ([bspec bspec] [depth 0])
@@ -319,9 +328,9 @@
   (define ss-depth (lookup-pvar-depth v))
   (cond
     [(< ss-depth bs-depth)
-     (wrong-syntax/orig v "too many ellipses for pattern variable in binding spec")]
+     (wrong-syntax/syntax-spec v "too many ellipses for pattern variable in binding spec")]
     [(< bs-depth ss-depth)
-     (wrong-syntax/orig v "missing ellipses with pattern variable in binding spec")]))
+     (wrong-syntax/syntax-spec v "missing ellipses with pattern variable in binding spec")]))
 
 ; makes sure you don't mix categories like refs+subexps and binds in the same ellipsis
 (define (check-ellipsis-homogeneity! bspec)
@@ -335,7 +344,7 @@
         (define export (find-export spec))
         (define representatives (filter values (list ref+subexp bind import export)))
         (when (< 1 (length representatives))
-            (wrong-syntax/orig stx "cannot mix different binding spec categories inside of ellipses"))
+            (wrong-syntax/syntax-spec stx "cannot mix imports or exports with other kinds of binding specs inside of ellipses"))
         bspec]
        [_ bspec]))
    bspec))
@@ -510,13 +519,13 @@
       (f (car specs) (cdr specs))))
 
 (define (binding-scope-error stx)
-  (wrong-syntax/orig stx "binding must occur within a scope"))
+  (wrong-syntax/syntax-spec stx "binding must occur within a scope"))
 
 (define (export-context-error stx)
-  (wrong-syntax/orig stx "exports may only occur at the top-level of an exporting binding spec"))
+  (wrong-syntax/syntax-spec stx "exports may only occur at the top-level of an exporting binding spec"))
 
 (define (re-export-context-error stx)
-  (wrong-syntax/orig stx "re-exports may only occur at the top-level of an exporting binding spec"))
+  (wrong-syntax/syntax-spec stx "re-exports may only occur at the top-level of an exporting binding spec"))
 
 ; spec -> (void) or raised syntax error
 ; enforces the above grammar for an unscoped expression
@@ -532,7 +541,7 @@
       [(or (and (s* import) (with-stx stx))
            (imports _ (cons (with-stx stx) _)))
        ; TODO use imports stx once it's sorce location is more refined.
-       (wrong-syntax/orig stx "import binding groups must occur within a scope")]
+       (wrong-syntax/syntax-spec stx "import binding groups must occur within a scope")]
       [(imports _ (list))
        ; impossible
        (void)]
@@ -576,14 +585,14 @@
        (refs+subexps group-spec (append group-specs specs))]
       [(group _ (list)) (check-sequence refs+subexps specs)]
       [(and (or (s* bind) (s* bind-syntax) (s* bind-syntaxes)) (with-stx stx))
-       (wrong-syntax/orig stx "bindings must appear first within a scope")]
+       (wrong-syntax/syntax-spec stx "bindings must appear first within a scope")]
       [(and (or (s* export) (s* export-syntax) (s* export-syntaxes)) (with-stx stx))
        (export-context-error stx)]
       [(and (s* re-export) (with-stx stx))
        (re-export-context-error stx)]
       [(or (and (s* import) (with-stx stx))
            (imports _ (cons (with-stx stx) _)))
-       (wrong-syntax/orig stx "an import binding group must appear before references and subexpressions")]
+       (wrong-syntax/syntax-spec stx "an import binding group must appear before references and subexpressions")]
       [(imports _ (list))
        ; impossible
        (void)]
@@ -633,12 +642,12 @@
       [(and (or (s* bind) (s* bind-syntax) (s* bind-syntaxes)) (with-stx stx))
        (binding-scope-error stx)]
       [(and (or (s* export) (s* export-syntax) (s* export-syntaxes)) (with-stx stx))
-       (wrong-syntax/orig stx "exports must appear first in a exporting spec")]
+       (wrong-syntax/syntax-spec stx "exports must appear first in a exporting spec")]
       [(and (s* re-export) (with-stx stx))
-       (wrong-syntax/orig stx "re-exports must occur before references and subexpressions")]
+       (wrong-syntax/syntax-spec stx "re-exports must occur before references and subexpressions")]
       [(or (and (s* import) (with-stx stx))
            (imports _ (cons (and (s* import) (with-stx stx)) _)))
-       (wrong-syntax/orig stx "import must occur within a scope")]
+       (wrong-syntax/syntax-spec stx "import must occur within a scope")]
       [(imports _ (list))
        ; impossible
        (void)]
@@ -668,9 +677,9 @@
        [(nested-binding)
         #`(nested)]
        [(nonterm-rep (nesting-nonterm-info _))
-        (wrong-syntax/orig v "nesting nonterminals may only be used with `nest`")]
+        (wrong-syntax/syntax-spec v "nesting nonterminals must be used with `nest`")]
        [(nonterm-rep (exporting-nonterm-info _ _))
-        (wrong-syntax/orig v "exporting nonterminals may only be used with `import` and `re-export`")]
+        (wrong-syntax/syntax-spec v "exporting nonterminals must be used with `import` or `re-export`")]
        [(or (? stxclass-rep?) (? special-syntax-class-binding?))
         #`(group (list))])]
     [(suspend _ (pvar v info))

private/syntax/compile/nonterminal-expander.rkt

@@ -117,7 +117,7 @@
         (syntax-parse (car prods)
           [(~or (p:form-production) (p:form-rewrite-production))
            (when (free-id-table-ref seen-forms #'p.form-name #f)
-             (wrong-syntax/orig #'p.form-name "all variants of the same-named form must occur together"))
+             (wrong-syntax/syntax-spec #'p.form-name "all variants of the same-named form must occur together"))
            (define-values (group remaining-prods) (gather-group prods))
            (loop remaining-prods (free-id-table-set seen-forms #'p.form-name #t) (cons group res))]
           [_ (loop (cdr prods) seen-forms (cons (car prods) res))]))))
@@ -214,7 +214,7 @@
 (define (generate-macro-clause extclass recur-id)
   (let ([ext-info (lookup extclass extclass-rep?)])
     (when (not ext-info)
-      (wrong-syntax/orig extclass "expected extension class name"))
+      (wrong-syntax/syntax-spec extclass "expected extension class name"))
 
     (with-syntax ([m-pred (extclass-rep-pred ext-info)]
                   [m-acc (extclass-rep-acc ext-info)]

private/syntax/compile/syntax-spec.rkt

@@ -72,7 +72,7 @@
        #:do [(define binding (lookup #'r.ref stxclass-rep?))]
        #:when binding
        #'(~var r.var r.ref)]
-      [_ (wrong-syntax/orig this-syntax "expected a syntax spec term")]))
+      [_ (wrong-syntax/syntax-spec this-syntax "expected a syntax spec term")]))
 
   (generate-pattern-form stx))
 
@@ -143,7 +143,7 @@
       [r:ref-id
        #:with c:special-syntax-class #'r.ref
        (when (member #'r.var res bound-identifier=?)
-         (wrong-syntax/orig #'r.ref "duplicate pattern variable"))
+         (wrong-syntax/syntax-spec #'r.var "duplicate pattern variable"))
        (bind! #'r.var (pvar-rep (special-syntax-class-binding) depth))
        (set! res (cons #'r.var res))]
       [r:ref-id
@@ -154,9 +154,9 @@
                                      (nonterm-rep? v)
                                      (stxclass-rep? v)))))
        (when (not binding)
-         (wrong-syntax/orig #'r.ref "expected a reference to a binding class, extension class, syntax class, or nonterminal"))
+         (wrong-syntax/syntax-spec #'r.ref "expected a reference to a binding class, extension class, syntax class, or nonterminal"))
        (when (member #'r.var res bound-identifier=?)
-         (wrong-syntax/orig #'r.ref "duplicate pattern variable"))
+         (wrong-syntax/syntax-spec #'r.var "duplicate pattern variable"))
        (bind! #'r.var (pvar-rep binding depth))
        (set! res (cons #'r.var res))]
       [_ (void)]))

private/syntax/interface.rkt

@@ -179,19 +179,19 @@
           #f))]
       [(host-interface/expression
          ~! (name:id . sspec)
-         (~optional (~seq #:binding bspec))
-         parse-body ...+)
+         bdecl:maybe-binding-decl
+         c:compiler)
        (values
         #f
         #f
         #'(define-syntax name
             (expression-macro
              (generate-host-interface-transformer
-              name sspec (~? (bspec) ()) (#:simple) parse-body ...))))]
+              name sspec (~? (bdecl.bspec) ()) (#:simple) c.body ...))))]
       [(host-interface/definitions
          ~! (name:id . sspec)
-         (~optional (~seq #:binding bspec))
-         parse-body ...+)
+         bdecl:maybe-binding-decl
+         c:compiler)
        (values
         #f
         #f
@@ -200,12 +200,12 @@
               (wrap-bind-trampoline
                (wrap-persist
                 (generate-host-interface-transformer
-                 name sspec (~? (bspec) ()) (#:pass1 #:pass2) parse-body ...))))))]
+                 name sspec (~? (bdecl.bspec) ()) (#:pass1 #:pass2) c.body ...))))))]
       [(host-interface/definition
          ~! (name:id . sspec)
-         (~optional (~seq #:binding bspec))
-         #:lhs [name-parse-body ...+]
-         #:rhs [rhs-parse-body ...+])
+         bdecl:maybe-binding-decl
+         #:lhs [lhs-c:compiler]
+         #:rhs [rhs-c:compiler])
        (values
         #f
         #f
@@ -217,12 +217,12 @@
                 (wrap-bind-trampoline
                  (wrap-persist
                   (generate-host-interface-transformer/definition-pass1
-                   sspec (~? (bspec) ()) [name-parse-body ...] pass2-macro)))))
+                   sspec (~? (bdecl.bspec) ()) [lhs-c.body ...] pass2-macro)))))
             ;; (before this one)
             (define-syntax pass2-macro
               (expression-macro
                (generate-host-interface-transformer
-                name sspec (~? (bspec) ()) (#:pass2) rhs-parse-body ...)))))])))
+                name sspec (~? (bdecl.bspec) ()) (#:pass2) rhs-c.body ...)))))])))
 
 (begin-for-syntax
   (define (generate-nonterminal-declarations name-stx opts-stx form-names variant-info-stx)
@@ -248,8 +248,7 @@
   (define-syntax generate-nonterminal-expander
     (syntax-parser
       [(_ orig-stx . decls)
-       (parameterize ([current-orig-stx #'orig-stx])
-         (compile-nonterminal-expander #'decls))]))  
+       (compile-nonterminal-expander #'decls)]))  
   )
 
 ;;

private/syntax/syntax-classes.rkt

@@ -3,6 +3,7 @@
 (provide
  current-orig-stx
  wrong-syntax/orig
+ wrong-syntax/syntax-spec
 
  maybe-description
  maybe-binding-space
@@ -47,7 +48,10 @@
  extclass-spec
 
  nonterminal-options
- )
+
+ compiler
+ parse-body
+ maybe-binding-decl)
 
 (require
   racket/string
@@ -68,6 +72,18 @@
 
 (define current-orig-stx (make-parameter #f))
 
+;; Used for meta-level errors where there is no good more-specific form
+;; to blame; that is, incorrect syntax-spec syntax, but on something like
+;; spec-var:[nt] where the error is not related to the immediately surrounding
+;; syntax. For errors where there is more appropriate immediately surrounding
+;; syntax, we use plain `wrong-syntax`.
+(define (wrong-syntax/syntax-spec
+         stx #:extra [extras null] format-string . args)
+  (parameterize ([current-syntax-context (datum->syntax #f 'syntax-spec)])
+    (apply wrong-syntax stx #:extra extras format-string args)))
+
+;; Used by DSL expanders to raise object-level errors; that is, a my-expression
+;; was expected by my-interface-macro.
 (define (wrong-syntax/orig stx #:extra [extras null] format-string . args)
   (parameterize ([current-syntax-context (current-orig-stx)])
     (apply wrong-syntax stx #:extra extras format-string args)))
@@ -185,3 +201,14 @@
     #:attr space-stx (attribute maybe-space.stx)
     #:attr space-sym (attribute maybe-space.sym)
     #:attr ext-classes (if (attribute extensions) (attribute extensions.classes) '())))
+
+(define-splicing-syntax-class compiler
+  #:description "host interface compiler"
+  (pattern (~seq body:parse-body ...+)))
+
+(define-syntax-class parse-body
+  #:description "pattern directive or body"
+  (pattern _))
+
+(define-splicing-syntax-class maybe-binding-decl
+  (pattern (~optional (~seq #:binding ~! bspec))))