From e2404184ee4d08ccfbf984521904022c3d10d5a8 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 7 Feb 2012 04:03:12 -0700 Subject: [PATCH] syntax/parse: fix opaque head patterns and splicing syntax classes closes PR 12537 --- collects/syntax/parse/private/parse.rkt | 29 ++++++--- .../syntax/parse/private/runtime-progress.rkt | 11 +++- .../syntax/parse/private/runtime-report.rkt | 3 +- collects/tests/stxparse/test.rkt | 64 +++++++++++++++++++ 4 files changed, 95 insertions(+), 12 deletions(-) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index f1dcd53a5d..b8448add48 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -267,7 +267,7 @@ Conventions: ;; Update the prompt, if required ;; FIXME: can be optimized away if no cut immediately within variants... (with-maybe-delimit-cut delimit-cut? - (parse:variants x cx relsattrs variants splicing? + (parse:variants x cx relsattrs variants splicing? transparent? pr es success cp0 commit?))))))))])) ;; (with-maybe-delimit-cut bool expr) @@ -281,27 +281,33 @@ Conventions: ;; (parse:variants x cx relsattrs variants splicing? pr es success cp0) : expr[Ans] (define-syntax (parse:variants stx) (syntax-case stx () - [(parse:variants x cx relsattrs () splicing? pr es success cp0 commit?) + [(parse:variants x cx relsattrs () splicing? transparent? + pr es success cp0 commit?) ;; Special case: no variants #'(fail (failure pr es))] - [(parse:variants x cx relsattrs (variant ...) splicing? pr es success cp0 commit?) - #'(try (parse:variant x cx relsattrs variant splicing? pr es success cp0 commit?) ...)])) + [(parse:variants x cx relsattrs (variant ...) splicing? transparent? + pr es success cp0 commit?) + #'(try (parse:variant x cx relsattrs variant splicing? transparent? + pr es success cp0 commit?) ...)])) ;; (parse:variant x cx relsattrs variant splicing? pr es success cp0) : expr[Ans] (define-syntax (parse:variant stx) (syntax-case stx () - [(parse:variant x cx relsattrs variant #f pr es success cp0 commit?) + [(parse:variant x cx relsattrs variant #f _ pr es success cp0 commit?) (with-syntax ([#s(variant _ _ pattern (def ...)) #'variant]) #`(let () def ... (parse:S x cx pattern pr es - (variant-success relsattrs variant () success cp0 commit?))))] - [(parse:variant x cx relsattrs variant #t pr es success cp0 commit?) + (variant-success relsattrs variant + () + success cp0 commit?))))] + [(parse:variant x cx relsattrs variant #t transparent? pr es success cp0 commit?) (with-syntax ([#s(variant _ _ pattern (def ...)) #'variant]) #`(let () def ... (parse:H x cx rest-x rest-cx rest-pr pattern pr es - (variant-success relsattrs variant (rest-x rest-cx rest-pr) + (variant-success relsattrs variant + (rest-x rest-cx (if 'transparent? rest-pr (ps-pop-opaque rest-pr))) success cp0 commit?))))])) ;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans] @@ -666,8 +672,11 @@ Conventions: [(parse:H x cx rest-x rest-cx rest-pr head pr es k) (syntax-case #'head () [#s(hpat:describe _ description transparent? pattern) - #`(let ([es (cons (expect:thing description transparent?) es)]) - (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))] + #`(let ([es* (cons (expect:thing description transparent?) es)] + [pr (if 'transparent? pr (ps-add-opaque pr))]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es* + (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) + k)))] [#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit?) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) diff --git a/collects/syntax/parse/private/runtime-progress.rkt b/collects/syntax/parse/private/runtime-progress.rkt index a2db66223e..562f1f244a 100644 --- a/collects/syntax/parse/private/runtime-progress.rkt +++ b/collects/syntax/parse/private/runtime-progress.rkt @@ -14,6 +14,7 @@ ps-add-opaque invert-ps + ps-pop-opaque ps->stx+index ps-context-syntax ps-difference @@ -152,6 +153,14 @@ Interpretation: Inner PS structures are applied first. (define (invert-ps ps) (reverse (ps-truncate-opaque ps))) +;; ps-pop-opaque : PS -> IPS +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (cons n ps*)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "opaque marker not found: ~e" ps)])) ;; ==== Failure ==== @@ -202,7 +211,7 @@ The *-marked variants can only occur at the top of the stack. expect->sexpr) (define (failureset->sexpr fs) - (let ([fs (flatten fs null)]) + (let ([fs (flatten fs)]) (case (length fs) ((1) (failure->sexpr (car fs))) (else `(union ,@(map failure->sexpr fs)))))) diff --git a/collects/syntax/parse/private/runtime-report.rkt b/collects/syntax/parse/private/runtime-report.rkt index bd0f369aea..83d251f3b2 100644 --- a/collects/syntax/parse/private/runtime-report.rkt +++ b/collects/syntax/parse/private/runtime-report.rkt @@ -5,7 +5,8 @@ syntax-patterns-fail) "kws.rkt") (provide syntax-patterns-fail - current-failure-handler) + current-failure-handler + maximal-failures) #| Note: there is a cyclic dependence between residual.rkt and this module, diff --git a/collects/tests/stxparse/test.rkt b/collects/tests/stxparse/test.rkt index 40c832d012..717c77026e 100644 --- a/collects/tests/stxparse/test.rkt +++ b/collects/tests/stxparse/test.rkt @@ -395,3 +395,67 @@ [(_ 1 ... . after-ones:expr) (syntax? #'after-ones)])) (void)) + +(begin + ;; from samth 2/4/2012 + ;; opaque head patterns used to propagate progress *with opaque marker* to tail + (test-case "opaque H, ok" + (check-equal? (syntax-parse #'(a b) + [((~describe #:opaque "x" (~seq x)) y:id) 'ok]) + 'ok)) + (test-case "opaque splicing stxclass, ok" + (check-equal? (let () + (define-splicing-syntax-class foo + #:opaque + #:description "foo" + (pattern (~seq x))) + (syntax-parse #'(a b) + [(f:foo y:id) 'ok])) + 'ok)) + + (test-case "opaque empty H, ok" + (check-equal? (syntax-parse #'(b) + [((~describe #:opaque "x" (~seq)) y:id) 'ok]) + 'ok)) + (test-case "opaque empty splicing stxclass, ok" + (check-equal? (let () + (define-splicing-syntax-class foo + #:opaque + #:description "foo" + (pattern (~seq))) + (syntax-parse #'(b) + [(f:foo y:id) 'ok])) + 'ok)) + + (tcerr "extent of opaque in H pattern" + (syntax-parse #'(a b) + [((~describe #:opaque "x" (~seq x)) y:nat) (void)]) + (not #rx"expected x") ;; y:nat was incorrectly considered part of opaque region + #rx"expected exact-nonnegative-integer") + (tcerr "extent of opaque in splicing stxclass" + (let () + (define-splicing-syntax-class foo + #:description "foo" + #:opaque + (pattern (~seq x))) + (syntax-parse #'(a b) + [(f:foo n:nat) (void)])) + (not #rx"expected foo") ;; y:nat was incorrectly considered part of opaque region + #rx"expected exact-nonnegative-integer") + + (tcerr "extent of opaque in empty H pattern" + (syntax-parse #'(b) + [((~describe #:opaque "x" (~seq)) y:nat) (void)]) + (not #rx"expected x") ;; y:nat was incorrectly considered part of opaque region + #rx"expected exact-nonnegative-integer") + (tcerr "extent of opaque in empty splicing stxclass" + (let () + (define-splicing-syntax-class foo + #:description "foo" + #:opaque + (pattern (~seq))) + (syntax-parse #'(b) + [(f:foo n:nat) (void)])) + (not #rx"expected foo") ;; y:nat was incorrectly considered part of opaque region + #rx"expected exact-nonnegative-integer") + )