diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index f38b30c5a7..ec5f70cc05 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/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)])) ;; ---- diff --git a/collects/syntax/private/stxparse/rep-patterns.ss b/collects/syntax/private/stxparse/rep-patterns.ss index b789e7235b..ac2d34839f 100644 --- a/collects/syntax/private/stxparse/rep-patterns.ss +++ b/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))]) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 8050721f7d..0e055c1709 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/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 diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index 37924ecf50..53bcb283a7 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/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 ...+) diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 824cb344bf..2a50158235 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -44,6 +44,7 @@ ~! ~bind ~fail + ;; ~early-fail ~parse ...+