syntax/parse:

fixed bug (thanks Jay!)
  some internal additions/changes

svn: r18731

collects/syntax/private/stxparse/parse.ss

@@ -365,9 +365,11 @@
         #`(with-enclosing-fail enclosing-cut-fail k)]
        [#s(ghost:bind _ clauses)
         #`(convert-sides x clauses (clause-success () k))]
-       [#s(ghost:fail _ condition message)
+       [#s(ghost:fail _ early? condition message)
         #`(let* ([c (without-fails condition)]
-                 [fc* (dfc-add-post fc (if (syntax? c) c x))])
+                 [fc* (if (quote early?)
+                          fc
+                          (dfc-add-post fc (if (syntax? c) c x)))])
             (if c
                 (fail (if (syntax? c) c x)
                       #:expect (expectation pattern0)
@@ -633,7 +635,7 @@
      #'(collect-error 'ineffable)]
     [(_ #s(pat:not _ pattern))
      #'(collect-error 'ineffable)]
-    [(_ #s(ghost:fail _ condition message))
+    [(_ #s(ghost:fail _ _e condition message))
      #'(expectation-of-message message)]))
 
 ;; ----

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

@@ -52,7 +52,7 @@ A ListPattern is a subtype of SinglePattern; one of
 #|
 A GhostPattern is one of
   (make-ghost:cut Base)
-  (make-ghost:fail Base stx stx)
+  (make-ghost:fail Base bool stx stx)
   (make-ghost:bind Base (listof clause:attr))
 * (make-ghost:and Base (listof GhostPattern))
   (make-ghost:parse Base SinglePattern stx)
@@ -61,7 +61,7 @@ ghost:and is desugared below in create-* procedures
 |#
 
 (define-struct ghost:cut (attrs) #:prefab)
-(define-struct ghost:fail (attrs when message) #:prefab)
+(define-struct ghost:fail (attrs early? 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)
@@ -227,8 +227,8 @@ A Kind is one of
 (define (create-ghost:cut)
   (make ghost:cut null))
 
-(define (create-ghost:fail condition message)
-  (make ghost:fail null condition message))
+(define (create-ghost:fail early? condition message)
+  (make ghost:fail null early? condition message))
 
 (define (create-ghost:and patterns)
   (let ([attrs (append-iattrs (map pattern-attrs patterns))])

collects/syntax/private/stxparse/rep.ss

@@ -92,6 +92,7 @@
         (quote-syntax ~!)
         (quote-syntax ~bind)
         (quote-syntax ~fail)
+        (quote-syntax ~early-fail)
         (quote-syntax ~parse)
         (quote-syntax ...+)))
 
@@ -341,7 +342,7 @@
           [else
            (wrong-syntax stx "action pattern not allowed here")]))
   (syntax-case stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe
-                    ~seq ~optional ~! ~bind ~fail ~parse)
+                    ~seq ~optional ~! ~bind ~fail ~early-fail ~parse)
     [wildcard
      (wildcard? #'wildcard)
      (begin (disappeared! stx)
@@ -401,7 +402,11 @@
     [(~fail . rest)
      (disappeared! stx)
      (check-ghost!
-      (parse-pat:fail stx decls))]
+      (parse-pat:fail stx decls #f))]
+    [(~early-fail . rest)
+     (disappeared! stx)
+     (check-ghost!
+      (parse-pat:fail stx decls #t))]
     [(~parse . rest)
      (disappeared! stx)
      (check-ghost!
@@ -726,7 +731,7 @@
          (append-iattrs (side-clauses-attrss clauses))
          clauses))]))
 
-(define (parse-pat:fail stx decls)
+(define (parse-pat:fail stx decls early?)
   (syntax-case stx ()
     [(_ . rest)
      (let-values ([(chunks rest)
@@ -743,7 +748,7 @@
                         #`(not #,(caddr chunk)))))])
          (syntax-case rest ()
            [(message)
-            (create-ghost:fail condition #'message)]
+            (create-ghost:fail early? condition #'message)]
            [()
             (wrong-syntax stx "missing message expression")]
            [_
@@ -843,11 +848,12 @@
                        "expected exact nonnegative integer or +inf.0"))
        (when (> minN maxN)
          (wrong-syntax stx "minimum larger than maximum repetition constraint"))
-       (let ([chunks (parse-keyword-options #'options
-                                            (list (list '#:too-few check-expression)
-                                                  (list '#:too-many check-expression)
-                                                  (list '#:name check-expression))
-                                            #:context stx)])
+       (let ([chunks (parse-keyword-options/eol
+                      #'options
+                      (list (list '#:too-few check-expression)
+                            (list '#:too-many check-expression)
+                            (list '#:name check-expression))
+                      #:context stx)])
          (let ([too-few-msg
                 (options-select-value chunks '#:too-few #:default #'#f)]
                [too-many-msg

collects/syntax/private/stxparse/runtime.ss

@@ -27,6 +27,7 @@
          ~!
          ~bind
          ~fail
+         ~early-fail
          ~parse
          ...+
 
@@ -93,6 +94,7 @@
 (define-keyword ~!)
 (define-keyword ~bind)
 (define-keyword ~fail)
+(define-keyword ~early-fail)
 (define-keyword ~parse)
 (define-keyword ...+)
 

collects/syntax/private/stxparse/sc.ss

@@ -44,6 +44,7 @@
          ~!
          ~bind
          ~fail
+         ;; ~early-fail
          ~parse
          ...+