diff --git a/collects/stxclass/private/codegen-data.ss b/collects/stxclass/private/codegen-data.ss index 0791c80612..a60714aca4 100644 --- a/collects/stxclass/private/codegen-data.ss +++ b/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) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index e7e2b32621..d552f8f6ef 100644 --- a/collects/stxclass/private/codegen.ss +++ b/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 diff --git a/collects/stxclass/private/kws.ss b/collects/stxclass/private/kws.ss deleted file mode 100644 index b5acb950a7..0000000000 --- a/collects/stxclass/private/kws.ss +++ /dev/null @@ -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)) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index 782ad61126..4791ca110d 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/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) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 0f76109b18..cb32e4d1c6 100644 --- a/collects/stxclass/private/rep.ss +++ b/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 diff --git a/collects/stxclass/private/messages.ss b/collects/stxclass/private/runtime.ss similarity index 72% rename from collects/stxclass/private/messages.ss rename to collects/stxclass/private/runtime.ss index 5b56de1ff3..54c409eb7e 100644 --- a/collects/stxclass/private/messages.ss +++ b/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]) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 2d3c63bd30..884105bf0d 100644 --- a/collects/stxclass/private/sc.ss +++ b/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)