diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 81f9733d9f..006932a23c 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -603,6 +603,23 @@ Conventions: (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr]) k)))] + [#s(hpat:peek-not () subpattern) + #`(let* ([fh0 fail-handler] + [pr0 pr] + [es0 es] + [fail-to-succeed + (lambda (fs) + (let ([rest-x x] + [rest-cx cx] + [rest-pr pr]) + k))]) + ;; ~not implicitly prompts to be safe, + ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) + ;; (statically checked!) + (with ([fail-handler fail-to-succeed] + [cut-prompt fail-to-succeed]) ;; to be safe + (parse:H x cx rest-x rest-cx rest-pr subpattern pr es + (fh0 (failure pr0 es0)))))] [_ (with-syntax ([attrs (pattern-attrs (wash #'head))]) #'(parse:S x cx diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt index cfe315996b..392e1a8c73 100644 --- a/collects/syntax/parse/private/rep-patterns.rkt +++ b/collects/syntax/parse/private/rep-patterns.rkt @@ -105,6 +105,7 @@ A HeadPattern is one of (hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) (hpat:post Base HeadPattern) (hpat:peek Base HeadPattern) + (hpat:peek-not Base HeadPattern) |# (define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab) @@ -119,6 +120,7 @@ A HeadPattern is one of (define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) (define-struct hpat:post (attrs pattern) #:prefab) (define-struct hpat:peek (attrs pattern) #:prefab) +(define-struct hpat:peek-not (attrs pattern) #:prefab) #| An EllipsisHeadPattern is @@ -192,7 +194,8 @@ A SideClause is one of (hpat:commit? x) (hpat:reflect? x) (hpat:post? x) - (hpat:peek? x))) + (hpat:peek? x) + (hpat:peek-not? x))) (define (ellipsis-head-pattern? x) (ehpat? x)) @@ -224,7 +227,7 @@ A SideClause is one of action:do action:post hpat:var hpat:seq hpat:action hpat:and hpat:or hpat:describe hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post - hpat:peek + hpat:peek hpat:peek-not ehpat))) ;; ---- @@ -375,6 +378,9 @@ A SideClause is one of (define (create-hpat:peek pattern) (make hpat:peek (pattern-attrs pattern) pattern)) +(define (create-hpat:peek-not pattern) + (make hpat:peek-not null pattern)) + ;; ---- (define (action/head-pattern->list-pattern p) diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index a5fec9c550..a9fa225021 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -120,7 +120,8 @@ (quote-syntax ~reflect) (quote-syntax ~splicing-reflect) (quote-syntax ~eh-var) - (quote-syntax ~peek))) + (quote-syntax ~peek) + (quote-syntax ~peek-not))) (define (reserved? stx) (and (identifier? stx) @@ -464,7 +465,7 @@ A syntax class is integrable if (wrong-syntax stx "action pattern not allowed here")])) (syntax-case stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe ~seq ~optional ~! ~bind ~fail ~parse ~do - ~post ~peek ~delimit-cut ~commit ~reflect + ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect ~splicing-reflect) [wildcard (wildcard? #'wildcard) @@ -550,6 +551,10 @@ A syntax class is integrable if (disappeared! stx) (check-head! (parse-pat:peek stx decls))] + [(~peek-not . rest) + (disappeared! stx) + (check-head! + (parse-pat:peek-not stx decls))] [(~parse . rest) (disappeared! stx) (check-action! @@ -1028,6 +1033,12 @@ A syntax class is integrable if (let ([p (parse-head-pattern #'pattern decls)]) (create-hpat:peek p))])) +(define (parse-pat:peek-not stx decls) + (syntax-case stx (~peek-not) + [(~peek-not pattern) + (let ([p (parse-head-pattern #'pattern decls)]) + (create-hpat:peek-not p))])) + (define (parse-pat:parse stx decls) (syntax-case stx (~parse) [(~parse pattern expr) diff --git a/collects/syntax/parse/todo.txt b/collects/syntax/parse/todo.txt index b68c0c3e4c..9977c7335d 100644 --- a/collects/syntax/parse/todo.txt +++ b/collects/syntax/parse/todo.txt @@ -29,7 +29,18 @@ Allow reflected syntax classes in conventions. Rename "conventions" to "convention-set"? +Unify convention-sets and literal-sets? + For documentation, talk about "primary attributes" vs "nested attributes". Helps explain ~eh-var and #:auto-nested-attributes. +For documentation, deftech "term-sequence", use consistently in +H-pattern docs, etc. + +Add documentation sections: + - Pattern matching model + - Static semantics (attributes) + +Add syntax exception variant with more information. + Fix syntaxes pinpointed for repetition constraint violations. diff --git a/collects/syntax/scribblings/parse/patterns.scrbl b/collects/syntax/scribblings/parse/patterns.scrbl index 1df9766e2d..e3029b280f 100644 --- a/collects/syntax/scribblings/parse/patterns.scrbl +++ b/collects/syntax/scribblings/parse/patterns.scrbl @@ -32,7 +32,7 @@ means specifically @tech{@Spattern}. @schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~datum ~describe ~seq ~optional ~rep ~once ~between - ~! ~bind ~fail ~parse ~peek) + ~! ~bind ~fail ~parse ~peek ~peek-not) [S-pattern pvar-id pvar-id:syntax-class-id @@ -77,6 +77,7 @@ means specifically @tech{@Spattern}. (@#,ref[~commit h] H-pattern) (@#,ref[~delimit-cut h] H-pattern) (~peek H-pattern) + (~peek-not H-pattern) proper-S-pattern] [EH-pattern (@#,ref[~or eh] EH-pattern ...) @@ -733,6 +734,25 @@ a sequence. ] } +@specsubform[(@#,defhere[~peek-not] H-pattern)]{ + +Like @racket[~peek], but succeeds if the subpattern fails and fails if +the subpattern succeeds. On success, the @racket[~peek-not] resets the +matching position, so the pattern consumes no input. Used to look +ahead in a sequence. None of the subpattern's attributes are bound +outside of the @scheme[~peek-not]-pattern. + +@myexamples[ +(define-splicing-syntax-class final (code:comment "final term") + (pattern (~seq x (~peek-not _)))) + +(syntax-parse #'(a b c) + [((~or f:final o:other) ...) + (printf "finals are ~s\n" (syntax->datum #'(f.x ...))) + (printf "others are ~s\n" (syntax->datum #'(o ...)))]) +] +} + @specsubform[S-pattern]{ Matches a sequence of one element, which must be a term matching