diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index dc872606cb..ac002b221f 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -369,6 +369,7 @@ #'#s(pat:compound attrs #:pair (head-part tail-part)))]))) ;; (parse:H id FCE HeadPattern id id expr) : expr +;; x must not alias rest (define-syntax (parse:H stx) (syntax-case stx () [(parse:H x fc head rest rest-fc k) @@ -471,11 +472,11 @@ [(attr-repc ...) attr-repcs]) (define-pattern-variable alt-map #'((id . alt-id) ...)) (define-pattern-variable loop-k - #'(dots-loop dx loop-fc* enclosing-fail rel-rep ... alt-id ...)) + #'(dots-loop dx* loop-fc* enclosing-fail rel-rep ... alt-id ...)) #`(let () (define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...) (with-enclosing-fail loop-fail - (try (parse:EH dx loop-fc head head-repc loop-fc* alt-map head-rep + (try (parse:EH dx loop-fc head head-repc dx* loop-fc* alt-map head-rep loop-k) ... (cond [(< rel-rep (rep:min-number rel-repc)) @@ -494,7 +495,7 @@ ;; RepConstraint/#f expr) : expr (define-syntax (parse:EH stx) (syntax-case stx () - [(parse:EH x fc head repc fc* alts rep k0) + [(parse:EH x fc head repc x* fc* alts rep k0) (let () (define-pattern-variable k (let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] @@ -511,11 +512,11 @@ #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) k0)))) (syntax-case #'repc () - [#f #`(parse:H x fc head x fc* k)] - [_ #`(parse:H x fc head x fc* + [#f #`(parse:H x fc head x* fc* k)] + [_ #`(parse:H x fc head x* fc* (if (< rep (rep:max-number repc)) (let ([rep (add1 rep)]) k) - (fail x + (fail x* #:expect (expectation-of-reps/too-many rep repc) #:fce fc*)))]))])) diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index 25a1139d22..dc1c828c03 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -357,7 +357,8 @@ variables that do not explicitly specify a syntax class. Uses the @tech{conventions} specified. The advantage of @scheme[#:local-conventions] over @scheme[#:conventions] is that local -conventions can be in the scope of syntax-class parameter bindings. +conventions can be in the scope of syntax-class parameter +bindings. See the section on @tech{conventions} for examples. } Each clause consists of a @tech{syntax pattern}, an optional sequence @@ -751,6 +752,28 @@ class. (syntax->datum #'(x0 (x ...) n0 (n ...)))]) ] +Local conventions, introduced with the @scheme[#:local-conventions] +keyword argument of @scheme[syntax-parse] and syntax class +definitions, may refer to local bindings: + +@myexamples[ +(define-syntax-class (nat> bound) + (pattern n:nat + #:fail-unless (> (syntax-e #'n) bound) + (format "expected number > ~s" bound))) + +(define-syntax-class (natlist> bound) + #:local-conventions ([N (nat> bound)]) + (pattern (N ...))) + +(define (parse-natlist> bound x) + (syntax-parse x + #:local-conventions ([NS (natlist> bound)]) + [NS 'ok])) +(parse-natlist> 0 #'(1 2 3)) +(parse-natlist> 5 #'(8 6 4 2)) +] + } @;{----------} diff --git a/collects/tests/stxparse/more-tests.ss b/collects/tests/stxparse/more-tests.ss index 86e903c862..1e794b1da0 100644 --- a/collects/tests/stxparse/more-tests.ss +++ b/collects/tests/stxparse/more-tests.ss @@ -189,19 +189,19 @@ (tcerr "parse-ehpat/bounds: min" (syntax-parser - [((~bounds x 1.0 9) ...) 'ok]) + [((~between x 1.0 9) ...) 'ok]) #rx"^syntax-parser: " #rx"expected exact nonnegative integer") (tcerr "parse-ehpat/bounds: max" (syntax-parser - [((~bounds x 1 "foo") ...) 'ok]) + [((~between x 1 "foo") ...) 'ok]) #rx"^syntax-parser: " #rx"expected exact nonnegative integer") (tcerr "parse-ehpat/bounds: min>max" (syntax-parser - [((~bounds x 3 2) ...) 'ok]) + [((~between x 3 2) ...) 'ok]) #rx"^syntax-parser: " #rx"minimum larger than maximum") diff --git a/collects/tests/stxparse/stxclass.ss b/collects/tests/stxparse/stxclass.ss index 7f93ec1260..da957d5c2a 100644 --- a/collects/tests/stxparse/stxclass.ss +++ b/collects/tests/stxparse/stxclass.ss @@ -210,3 +210,26 @@ (syntax-parse #'(4 -1) #:conventions (nat-convs) [(N ...) (void)])) (error 'test-conv1 "didn't work")) + +;; Local conventions + +(define-syntax-class (nats> bound) + #:local-conventions ([N (nat> bound)]) + (pattern (N ...))) + +(define (p1 bound x) + (syntax-parse x + #:local-conventions ([ns (nats> bound)]) + [ns 'yes] + [_ 'no])) + +(eq? (p1 0 #'(1 2 3)) 'yes) +(eq? (p1 2 #'(1 2 3)) 'no) + +;; Regression (2/2/2010) + +(define-splicing-syntax-class twoseq + (pattern (~seq a b))) + +(syntax-parse #'(1 2 3 4) + [(x:twoseq ...) 'ok])