diff --git a/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl index 0de49e896d..a96ad93b43 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl @@ -165,7 +165,7 @@ One of @ref[~delimit-cut s] or @ref[~delimit-cut h]: One of @ref[~post s], @ref[~post h], or @ref[~post a]: @itemize[ -@item{@ref[~post a] if the subpattern is a @tech{proper @Apattern}} +@item{@ref[~post a] if the subpattern is an @tech{@Apattern}} @item{@ref[~post h] if the subpattern is a @tech{proper @Hpattern}} @item{@ref[~post s] otherwise} ] diff --git a/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl index 6fef55dd0f..9d34664ddb 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl @@ -193,6 +193,8 @@ follows: @racketgrammar[pattern-directive (code:line #:declare pattern-id stxclass maybe-role) + (code:line #:post action-pattern) + (code:line #:and action-pattern) (code:line #:with syntax-pattern expr) (code:line #:attr attr-arity-decl expr) (code:line #:fail-when condition-expr message-expr) @@ -239,6 +241,27 @@ pattern may be declared. ] } +@specsubform[(code:line #:post action-pattern)]{ + +Executes the given @tech{@Apattern} as a ``post-traversal check'' +after matching the main pattern. That is, the following are +equivalent: +@racketblock[ +_main-pattern #:post action-pattern +_main-pattern #:and (~post action-pattern) +(~and _main-pattern (~post action-pattern)) +] +} + +@specsubform[(code:line #:and action-pattern)]{ + +Like @racket[#:post] except that no @racket[~post] wrapper is +added. That is, the following are equivalent: +@racketblock[ +_main-pattern #:and action-pattern +(~and _main-pattern action-pattern) +]} + @specsubform[(code:line #:with syntax-pattern stx-expr)]{ Evaluates the @racket[stx-expr] in the context of all previous @@ -254,6 +277,8 @@ implicitly converted to a syntax object. If the the conversion would produce @deftech{3D syntax}---that is, syntax that contains unwritable values such as procedures, non-prefab structures, etc---then an exception is raised instead. + +Equivalent to @racket[#:post (~parse syntax-pattern stx-expr)]. } @specsubform[(code:line #:attr attr-arity-decl expr)]{ @@ -262,6 +287,8 @@ Evaluates the @racket[expr] in the context of all previous attribute bindings and binds it to the given attribute. The value of @racket[expr] need not be, or even contain, syntax---see @racket[attribute] for details. + +Equivalent to @racket[#:and (~bind attr-arity-decl expr)]. } @specsubform[(code:line #:fail-when condition-expr message-expr) @@ -276,12 +303,16 @@ object, it is indicated as the cause of the error. If the @racket[message-expr] produces a string it is used as the failure message; otherwise the failure is reported in terms of the enclosing descriptions. + +Equivalent to @racket[#:post (~fail #:when condition-expr message-expr)]. } @specsubform[(code:line #:fail-unless condition-expr message-expr) #:contracts ([message-expr (or/c string? #f)])]{ Like @racket[#:fail-when] with the condition negated. + +Equivalent to @racket[#:post (~fail #:unless condition-expr message-expr)]. } @specsubform[(code:line #:when condition-expr)]{ @@ -290,6 +321,8 @@ Evaluates the @racket[condition-expr] in the context of all previous attribute bindings. If the value is @racket[#f], the matching process backtracks. In other words, @racket[#:when] is like @racket[#:fail-unless] without the message argument. + +Equivalent to @racket[#:post (~fail #:unless condition-expr #f)]. } @specsubform[(code:line #:do [def-or-expr ...])]{ @@ -302,6 +335,8 @@ the expressions of subsequent patterns and clauses. There is currently no way to bind attributes using a @racket[#:do] block. It is an error to shadow an attribute binding with a definition in a @racket[#:do] block. + +Equivalent to @racket[#:and (~do def-or-expr ...)]. } diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 591d085977..0d8804a481 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -416,6 +416,23 @@ (check-equal? counter 5) (void)]))) +;; #:and, #:post side-clauses + +(test-case "#:and side-clause" + (check-exn #rx"non-decreasing" + (lambda () + (syntax-parse #'(1 2) + [(a b) + #:and (~fail #:unless (> (syntax-e #'a) (syntax-e #'b)) "non-decreasing") + (void)])))) +(test-case "#:post side-clause" + (check-exn #rx"non-decreasing" + (lambda () + (syntax-parse #'(1 2) + [(a b) + #:post (~fail #:unless (> (syntax-e #'a) (syntax-e #'b)) "non-decreasing") + (void)])))) + ;; == Lib tests ;; static diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index 4120c97a73..6f4d6c3bd4 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -397,8 +397,7 @@ (check-pattern (cond [(pair? sides) (define actions-pattern - (create-post-pattern - (create-action:and (ord-and-patterns sides (gensym*))))) + (create-action:and (ord-and-patterns sides (gensym*)))) (define and-patterns (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any))) (gensym*))) @@ -423,6 +422,13 @@ (define (parse-head-pattern stx decls) (parse-*-pattern stx decls #t #f)) +;; parse-action-pattern : Stx DeclEnv -> ActionPattern +(define (parse-action-pattern stx decls) + (define p (parse-*-pattern stx decls #f #t)) + (unless (action-pattern? p) + (wrong-syntax stx "expected action pattern")) + p) + (define ((make-not-shadowed? decls) id) ;; Returns #f if id is in literals/datum-literals list. ;; Conventions to not shadow pattern-form bindings, under the @@ -1213,23 +1219,29 @@ [(cons (list '#:role role-stx _) rest) (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")] [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest) - (cons (action:fail when-expr msg-expr) + (cons (create-post-pattern (action:fail when-expr msg-expr)) (parse-pattern-sides rest decls))] [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest) - (cons (action:fail #`(not #,unless-expr) msg-expr) + (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr)) (parse-pattern-sides rest decls))] [(cons (list '#:when w-stx unless-expr) rest) - (cons (action:fail #`(not #,unless-expr) #'#f) + (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#f)) (parse-pattern-sides rest decls))] [(cons (list '#:with with-stx pattern expr) rest) (let-values ([(decls2 rest) (grab-decls rest decls)]) (let-values ([(decls2a defs) (decls-create-defs decls2)]) - (cons (create-action:and - (list (action:do defs) - (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr))) - (parse-pattern-sides rest decls))))] + (list* (action:do defs) + (create-post-pattern + (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)) + (parse-pattern-sides rest decls))))] [(cons (list '#:attr attr-stx a expr) rest) - (cons (action:bind a expr) + (cons (action:bind a expr) ;; no POST wrapper, cannot fail + (parse-pattern-sides rest decls))] + [(cons (list '#:post post-stx pattern) rest) + (cons (create-post-pattern (parse-action-pattern pattern decls)) + (parse-pattern-sides rest decls))] + [(cons (list '#:and and-stx pattern) rest) + (cons (parse-action-pattern pattern decls) ;; no POST wrapper (parse-pattern-sides rest decls))] [(cons (list '#:do do-stx stmts) rest) (cons (action:do stmts) @@ -1596,6 +1608,8 @@ (list '#:when check-expression) (list '#:with check-expression check-expression) (list '#:attr check-attr-arity check-expression) + (list '#:and check-expression) + (list '#:post check-expression) (list '#:do check-stmt-list))) ;; fail-directive-table