suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: fix opaque head patterns and splicing syntax classes

Browse Source 
closes PR 12537
This commit is contained in:
Ryan Culpepper 2012-02-07 04:03:12 -07:00
parent 2de9de9b26
commit e2404184ee
4 changed files with 95 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/syntax/parse/private/parse.rkt
View File

@ -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 ...)

11
collects/syntax/parse/private/runtime-progress.rkt
View File

@ -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))))))

3
collects/syntax/parse/private/runtime-report.rkt
View File

@ -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,

64
collects/tests/stxparse/test.rkt
View File

@ -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")
)