use syntax-parse more for errors

michaelballantyne · Oct 18, 2024 · d9600f6 · d9600f6
1 parent 5c9f52d
commit d9600f6
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 16 deletions.
diff --git a/private/syntax/interface.rkt b/private/syntax/interface.rkt
@@ -177,25 +177,21 @@
                  #,this-syntax
                  #:pass2 name opts prod ...)))
           #f))]
-      [((~or host-interface/expression host-interface/definitions)
-         _
-         #:binding _)
-       (wrong-syntax this-syntax "missing compilation in host interface")]
       [(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
@@ -204,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
@@ -221,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)

diff --git a/private/syntax/syntax-classes.rkt b/private/syntax/syntax-classes.rkt
@@ -47,7 +47,10 @@
  extclass-spec
 
  nonterminal-options
- )
+
+ compiler
+ parse-body
+ maybe-binding-decl)
 
 (require
   racket/string
@@ -185,3 +188,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))))