syntax/parse: added ~parse action pattern

svn: r16097

collects/syntax/private/stxparse/codegen-data.ss

@@ -19,7 +19,7 @@
   (make-fce x (list #'(+ 0))))
 
 (define (done-frontier x)
-  (make-fce x (list #'(+ +inf.0))))
+  (make-fce x (list #'(+ 0) #'(+ +inf.0))))
 
 (define (frontier:add-car fc x)
   (make-fce x (cons #'(+ 0) (fce-indexes fc))))
@@ -49,6 +49,11 @@
 (define (frontier:add-unpstruct fc x)
   (frontier:add-car fc x))
 
+(define (frontier:add-subparse fc x)
+  (frontier:add-car
+   (frontier:add-index (frontier:add-car fc x) +inf.0)
+   x))
+
 ;; A DynamicFrontierContext (DFC) is a list of numbers.
 ;; More operations on DFCs in runtime.ss
 

collects/syntax/private/stxparse/parse.ss

@@ -329,7 +329,11 @@
               (fail x
                     #:expect (expectation pattern0)
                     #:fce fc)
-              k)])]))
+              k)]
+       [#s(ghost:parse _ pattern expr)
+        #`(let ([y (datum->syntax #f (without-fails expr))])
+            (parse:S y #,(frontier:add-subparse (wash #'fc) #'y)
+                     pattern k))])]))
 
 (begin-for-syntax
  ;; convert-list-pattern : ListPattern id -> SinglePattern

collects/syntax/private/stxparse/rep-patterns.ss

@@ -55,6 +55,7 @@ A GhostPattern is one of
   (make-ghost:fail Base stx stx)
   (make-ghost:bind Base (listof clause:attr))
 * (make-ghost:and Base (listof GhostPattern))
+  (make-ghost:parse Base SinglePattern stx)
 
 ghost:and is desugared below in create-* procedures
 |#
@@ -63,6 +64,7 @@ ghost:and is desugared below in create-* procedures
 (define-struct ghost:fail (attrs when message) #:prefab)
 (define-struct ghost:bind (attrs clauses) #:prefab)
 (define-struct ghost:and (attrs patterns) #:prefab)
+(define-struct ghost:parse (attrs pattern expr) #:prefab)
 
 #|
 A HeadPattern is one of 
@@ -126,7 +128,8 @@ A Kind is one of
   (or (ghost:cut? x)
       (ghost:bind? x)
       (ghost:fail? x)
-      (ghost:and? x)))
+      (ghost:and? x)
+      (ghost:parse? x)))
 
 (define (head-pattern? x)
   (or (hpat:var? x)
@@ -163,7 +166,7 @@ A Kind is one of
                      [else (raise-type-error 'pattern-attrs "pattern" x)])))]))
     (mk-get-attrs pat:any pat:var pat:datum pat:literal pat:ghost pat:head
                   pat:dots pat:and pat:or pat:not pat:compound pat:describe
-                  ghost:cut ghost:bind ghost:fail ghost:and
+                  ghost:cut ghost:bind ghost:fail ghost:and ghost:parse
                   hpat:var hpat:seq hpat:ghost hpat:and hpat:or hpat:describe
                   hpat:optional
                   ehpat)))
@@ -233,6 +236,9 @@ A Kind is one of
   (let ([attrs (append-iattrs (map pattern-attrs patterns))])
     (make ghost:and attrs patterns)))
 
+(define (create-ghost:parse pattern expr)
+  (make ghost:parse (pattern-attrs pattern) pattern expr))
+
 ;; ----
 
 (define (create-hpat:var name parser args nested-attrs)

collects/syntax/private/stxparse/rep.ss

@@ -85,10 +85,11 @@
         (quote-syntax ~bounds)
         (quote-syntax ~rest)
         (quote-syntax ~struct)
-        (quote-syntax ~!)
         (quote-syntax ~describe)
+        (quote-syntax ~!)
         (quote-syntax ~bind)
-        (quote-syntax ~fail)))
+        (quote-syntax ~fail)
+        (quote-syntax ~parse)))
 
 (define (reserved? stx)
   (and (identifier? stx)
@@ -279,8 +280,8 @@
           [(not allow-head?) (ghost-pattern->single-pattern x)]
           [else
            (wrong-syntax stx "action pattern not allowed here")]))
-  (syntax-case stx (~var ~literal ~and ~or ~not ~rest ~struct
-                    ~! ~describe ~bind ~fail ~seq ~optional)
+  (syntax-case stx (~var ~literal ~and ~or ~not ~rest ~struct ~describe
+                    ~seq ~optional ~! ~bind ~fail ~parse)
     [wildcard
      (wildcard? #'wildcard)
      (create-pat:any)]
@@ -322,6 +323,9 @@
     [(~fail . rest)
      (check-ghost!
       (parse-pat:fail stx decls))]
+    [(~parse . rest)
+     (check-ghost!
+      (parse-pat:parse stx decls))]
     [(head dots . tail)
      (dots? #'dots)
      (parse-pat:dots stx #'head #'tail decls)]
@@ -630,7 +634,16 @@
            [()
             (wrong-syntax stx "missing message expression")]
            [_
-            (wrong-syntax stx "bad fail pattern")])))]))
+            (wrong-syntax stx "bad ~fail pattern")])))]))
+
+(define (parse-pat:parse stx decls)
+  (syntax-case stx (~parse)
+    [(~parse pattern expr)
+     (let ([p (parse-single-pattern #'pattern decls)])
+       (create-ghost:parse p #'expr))]
+    [_
+     (wrong-syntax stx "bad ~parse pattern")]))
+
 
 (define (parse-pat:rest stx decls)
   (syntax-case stx ()

collects/syntax/private/stxparse/runtime.ss

@@ -22,10 +22,11 @@
          ~optional
          ~rest
          ~struct
-         ~!
          ~describe
+         ~!
          ~bind
          ~fail
+         ~parse
 
          current-expression
          current-macro-name
@@ -88,10 +89,11 @@
 (define-keyword ~optional)
 (define-keyword ~rest)
 (define-keyword ~struct)
-(define-keyword ~!)
 (define-keyword ~describe)
+(define-keyword ~!)
 (define-keyword ~bind)
 (define-keyword ~fail)
+(define-keyword ~parse)
 
 ;; == Parameters & Syntax Parameters
 

collects/syntax/private/stxparse/sc.ss

@@ -37,10 +37,11 @@
          ~optional
          ~rest
          ~struct
-         ~!
          ~describe
+         ~!
          ~bind
          ~fail
+         ~parse
 
          attribute
          this-syntax)

collects/syntax/scribblings/parse-patterns.scrbl

@@ -83,9 +83,9 @@ When a special form in this manual refers to @svar[syntax-pattern]
 (eg, the description of the @scheme[syntax-parse] special form), it
 means specifically @tech{@Spattern}.
 
-@schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~seq 
-                            ~rep ~once ~optional
-                            ~rest ~struct ~! ~describe ~bind ~fail)
+@schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~struct
+                            ~describe ~seq ~optional ~rep ~once
+                            ~! ~bind ~fail ~parse)
                 [S-pattern
                  pvar-id
                  pvar-id:syntax-class-id
@@ -130,6 +130,7 @@ means specifically @tech{@Spattern}.
                  ~!
                  (~bind [attr-id expr] ...)
                  (~fail maybe-fail-condition message-expr)
+                 (~parse S-pattern stx-expr)
                  (@#,ref[~and a] A-pattern ...+)]
                 [proper-S-pattern
                  #, @elem{a @svar{S-pattern} that is not a @svar{A-pattern}}]
@@ -800,6 +801,13 @@ specific ill-formed terms and address them with specially-created
 failure messages.
 }
 
+@specsubform[(@#,defhere[~parse] S-pattern stx-expr)
+             #:contracts ([stx-expr syntax?])]{
+
+Evaluates @scheme[stx-expr] to a syntax object and matches it against
+@scheme[S-pattern].
+}
+
 @specsubform[(@#,def[~and a] A-pattern ...+)]{
 
 Performs the actions of each @scheme[A-pattern].

collects/tests/stxclass/test.ss

@@ -198,6 +198,27 @@
 (tok (1 2) (~and x:two :two)
      (and (bound (x 0) (x.a 0) (a 0)) (s= x '(1 2)) (s= x.a 1) (s= a 1)))
 
+;; -- H patterns
+
+;; seq
+(tok (1 2 3) ((~seq 1 2) 3))
+(tok (1 2 3) (1 (~seq 2) 3))
+(tok (1 2 3) ((~seq) 1 2 3))
+
+;; or
+(tok (1 2 3) ((~or (~seq 1 2) 1) 3))
+(tok (1 2 3) ((~or 1 (~seq 1 2)) 3))
+(tok (1 2 3) ((~or (~seq 1) (~seq 1 2)) 3))
+(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3))
+(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3 (~or (~seq 4) (~seq))))
+
+;; describe
+(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3))
+(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3)
+      "one-two")
+
+;; -- A patterns
+
 ;; cut patterns
 (terx* (1 2 3) [(1 ~! 4) (1 2 3)]
        "4" (not "2"))
@@ -227,24 +248,15 @@
 (terx 1 (~and n:nat (~fail #:unless (even? (syntax-e #'n)) "wanted even number"))
       #rx"wanted even number")
 
-;; -- H patterns
+;; fail as S-pattern
+(terx 1 (~fail "grr")
+      #rx"grr")
 
-;; seq
-(tok (1 2 3) ((~seq 1 2) 3))
-(tok (1 2 3) (1 (~seq 2) 3))
-(tok (1 2 3) ((~seq) 1 2 3))
-
-;; or
-(tok (1 2 3) ((~or (~seq 1 2) 1) 3))
-(tok (1 2 3) ((~or 1 (~seq 1 2)) 3))
-(tok (1 2 3) ((~or (~seq 1) (~seq 1 2)) 3))
-(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3))
-(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3 (~or (~seq 4) (~seq))))
-
-;; describe
-(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3))
-(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3)
-      "one-two")
+(tok (1 2 3) (x:nat y:nat (~parse (~or 2 3) (+ (syntax-e #'x) (syntax-e #'y))) z:nat))
+(terx (1 2 3) (x:nat y:nat (~parse 4 (+ (syntax-e #'x) (syntax-e #'y))) z:nat)
+      "expected the literal 4")
+(terx (1 2 3) (x:nat y:nat (~parse (2 4) #'(x y)))
+      "expected the literal 2")
 
 ;; == Lib tests