stxclass: consolidated runtime modules into runtime.ss

svn: r13470

collects/stxclass/private/codegen-data.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/match
-         (for-template scheme/base "kws.ss"))
+         (for-template scheme/base "runtime.ss"))
 (provide (all-defined-out))
 
 ;; A PK is (make-pk (listof Pattern) stx)

collects/stxclass/private/codegen.ss

@@ -2,8 +2,7 @@
 (require (for-template scheme/base
                        syntax/stx
                        scheme/stxparam
-                       "kws.ss"
-                       "messages.ss")
+                       "runtime.ss")
          scheme/match
          scheme/contract
          scheme/private/sc

collects/stxclass/private/kws.ss

@@ -1,100 +0,0 @@
-#lang scheme/base
-(require scheme/stxparam
-         (for-syntax scheme/base))
-(provide pattern
-         ...*
-
-         with-enclosing-fail
-         enclosing-fail
-
-         ok?
-         (struct-out failed)
-
-         current-expression
-         current-macro-name)
-
-;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*)
-;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*)
-
-;; A SCDirective is one of
-;;   #:description String
-;;   #:transparent
-
-;; A SyntaxClassRHS is
-;;   (pattern Pattern PatternDirective ...)
-
-;; A Pattern is one of
-;;   name:syntaxclass
-;;   (Pattern . Pattern)
-;;   (Pattern ... . Pattern)
-;;   (((Pattern*) HeadDirective* *) ...* . Pattern)
-;;   datum, including ()
-
-;; A PatternDirective is one of
-;;   #:declare name SyntaxClassName
-;;   #:declare name (SyntaxClassName expr ...)
-;;   #:rename internal-id external-id
-;;   #:with pattern expr
-;;     #:with clauses are let*-scoped
-;;   #:when expr
-
-;; A HeadDirective is one of
-;;   #:min nat/#f
-;;   #:max nat/#f
-;;   #:opt
-;;   #:mand
-;;   -- For optional heads only:
-;;     #:occurs id
-;;       'id' is bound to #t is the pattern occurs, #f otherwise
-;;     #:default form
-;;       Preceding head must have a single pvar
-;;       If the head is not present, the pvar is bound to 'form' instead
-
-(define-syntax-rule (define-keyword name)
-  (define-syntax name
-    (lambda (stx)
-      (raise-syntax-error #f "keyword used out of context" stx))))
-
-(define-keyword pattern)
-(define-keyword basic-syntax-class)
-(define-keyword ...*)
-(define-keyword ...**)
-
-(define-syntax-parameter enclosing-fail
-  (lambda (stx)
-    (raise-syntax-error #f
-                        "used out of context: not parsing pattern"
-                        stx)))
-
-(define-syntax-parameter pattern-source
-  (lambda (stx)
-    (raise-syntax-error #f "used out of context: not in syntax-class parser" stx)))
-
-(define current-expression (make-parameter #f))
-
-(define (current-macro-name)
-  (let ([expr (current-expression)])
-    (and expr
-         (syntax-case expr (set!)
-           [(set! kw . _)
-            #'kw]
-           [(kw . _)
-            (identifier? #'kw)
-            #'kw]
-           [kw
-            (identifier? #'kw)
-            #'kw]
-           [_ #f]))))
-
-;; A PatternParseResult is one of
-;;   - (listof value)
-;;   - (make-failed stx expectation/c frontier/#f)
-(define (ok? x) (or (pair? x) (null? x)))
-(define-struct failed (stx expectation frontier)
-  #:transparent)
-
-
-(define-syntax-rule (with-enclosing-fail failvar expr)
-  (syntax-parameterize ((enclosing-fail
-                         (make-rename-transformer (quote-syntax failvar))))
-    expr))

collects/stxclass/private/rep-data.ss

@@ -1,10 +1,6 @@
-
 #lang scheme/base
-(require (for-template "kws.ss")
-         (for-template scheme/base)
-         scheme/contract
+(require scheme/contract
          scheme/match
-         syntax/boundmap
          syntax/stx
          "../util.ss")
 (provide (struct-out sc)

collects/stxclass/private/rep.ss

@@ -1,5 +1,5 @@
 #lang scheme/base
-(require (for-template "kws.ss")
+(require (for-template "runtime.ss")
          (for-template scheme/base)
          scheme/contract
          scheme/match

collects/stxclass/private/runtime.ss

@@ -1,21 +1,95 @@
 #lang scheme/base
-(require (for-syntax scheme/base syntax/stx "rep-data.ss")
-         scheme/contract
-         scheme/match)
-(provide (for-syntax expectation-of-stxclass
+(require scheme/contract
+         scheme/match
+         scheme/stxparam
+         (for-syntax scheme/base)
+         (for-syntax syntax/stx)
+         (for-syntax "rep-data.ss")
+         (for-syntax "../util/error.ss"))
+(provide pattern
+         ...*
+
+         with-enclosing-fail
+         enclosing-fail
+
+         ok?
+         (struct-out failed)
+
+         current-expression
+         current-macro-name
+
+         (for-syntax expectation-of-stxclass
                      expectation-of-constants
                      expectation-of/message)
+
          try
          expectation/c
          expectation-of-null?
          expectation->string)
 
-(define-struct scdyn (name desc)
+;; Keywords
+
+(define-syntax-rule (define-keyword name)
+  (define-syntax name
+    (lambda (stx)
+      (raise-syntax-error #f "keyword used out of context" stx))))
+
+(define-keyword pattern)
+(define-keyword ...*)
+(define-keyword ...**)
+
+;; Parameters & Syntax Parameters
+
+(define-syntax-parameter enclosing-fail
+  (lambda (stx)
+    (wrong-syntax stx "used out of context: not parsing pattern")))
+
+(define-syntax-rule (with-enclosing-fail failvar expr)
+  (syntax-parameterize ((enclosing-fail
+                         (make-rename-transformer (quote-syntax failvar))))
+    expr))
+
+(define-syntax-parameter pattern-source
+  (lambda (stx)
+    (wrong-syntax stx "used out of context: not parsing pattern")))
+
+(define current-expression (make-parameter #f))
+
+(define (current-macro-name)
+  (let ([expr (current-expression)])
+    (and expr
+         (syntax-case expr (set!)
+           [(set! kw . _)
+            #'kw]
+           [(kw . _)
+            (identifier? #'kw)
+            #'kw]
+           [kw
+            (identifier? #'kw)
+            #'kw]
+           [_ #f]))))
+
+;; Runtime: syntax-class parser results
+
+;; A PatternParseResult is one of
+;;   - (listof value)
+;;   - (make-failed stx expectation/c frontier/#f)
+
+(define (ok? x) (or (pair? x) (null? x)))
+(define-struct failed (stx expectation frontier)
   #:transparent)
 
+
+;; Runtime: parsing failures/expectations
+
+;; An Expectation is
+;;   (make-expc (listof scdyn) bool (listof atom) (listof id))
 (define-struct expc (stxclasses pairs? data literals)
   #:transparent)
 
+(define-struct scdyn (name desc)
+  #:transparent)
+
 (define expectation/c (or/c expc?))
 
 (define (make-stxclass-expc scdyn)
@@ -36,7 +110,8 @@
                   [(literal ...) literals]
                   [pairs? pairs?])
       (certify
-       #'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...)))))
+       #'(make-expc null 'pairs? (list 'datum ...)
+                    (list (quote-syntax literal) ...)))))
 
   (define (expectation-of/message msg)
     (with-syntax ([msg msg])

collects/stxclass/private/sc.ss

@@ -9,8 +9,7 @@
                      "../util.ss")
          scheme/match
          syntax/stx
-         "kws.ss"
-         "messages.ss")
+         "runtime.ss")
 
 (provide define-syntax-class
          define-basic-syntax-class
@@ -33,6 +32,43 @@
          current-expression
          current-macro-name)
 
+;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*)
+;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*)
+
+;; A SCDirective is one of
+;;   #:description String
+;;   #:transparent
+
+;; A SyntaxClassRHS is
+;;   (pattern Pattern PatternDirective ...)
+
+;; A Pattern is one of
+;;   name:syntaxclass
+;;   (Pattern . Pattern)
+;;   (Pattern ... . Pattern)
+;;   (((Pattern*) HeadDirective* *) ...* . Pattern)
+;;   datum, including ()
+
+;; A PatternDirective is one of
+;;   #:declare name SyntaxClassName
+;;   #:declare name (SyntaxClassName expr ...)
+;;   #:rename internal-id external-id
+;;   #:with pattern expr
+;;     #:with clauses are let*-scoped
+;;   #:when expr
+
+;; A HeadDirective is one of
+;;   #:min nat/#f
+;;   #:max nat/#f
+;;   #:opt
+;;   #:mand
+;;   -- For optional heads only:
+;;     #:occurs id
+;;       'id' is bound to #t is the pattern occurs, #f otherwise
+;;     #:default form
+;;       Preceding head must have a single pvar
+;;       If the head is not present, the pvar is bound to 'form' instead
+
 (define-syntax (define-syntax-class stx)
   (syntax-case stx ()
     [(define-syntax-class (name arg ...) . rhss)