suzanne.soy/extensible-parser-specifications
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed ~lift-rest so that different ~lift-rest patterns can bind the same attributes (as long as only one of them matches the rest)

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-24 14:00:41 +02:00
parent 4f7e3353d1
commit a8001c282b
1 changed files with 26 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
private/no-order.rkt
View File

@ -24,6 +24,7 @@
phc-toolkit/untyped phc-toolkit/untyped
racket/list racket/list
racket/function racket/function
racket/format
(for-syntax racket/base (for-syntax racket/base
syntax/parse syntax/parse
racket/syntax racket/syntax
@ -138,10 +139,10 @@
(set! post-groups-acc (cons v post-groups-acc))) (set! post-groups-acc (cons v post-groups-acc)))
(define lifted-rest '()) (define lifted-rest '())
(define (add-to-lift-rest! present-clause expanded-pat) (define (add-to-lift-rest! present-clause expanded-pat)
(define succeeded-clause (get-new-clause!)) (define succeeded (get-new-clause!))
(set! lifted-rest (cons (list present-clause (set! lifted-rest (cons (list present-clause
expanded-pat expanded-pat
succeeded-clause) succeeded)
lifted-rest))) lifted-rest)))
;; expand EH alternatives: ;; expand EH alternatives:
(parameterize ([eh-first-accumulate add-to-first!] (parameterize ([eh-first-accumulate add-to-first!]
@ -196,34 +197,32 @@
(define rest-handlers (define rest-handlers
(if (null? lifted-rest) (if (null? lifted-rest)
#'() #'()
(map (match-lambda (with-syntax ([[(present expanded-pat succeeded) …] lifted-rest])
[(list present expanded-pat succeeded) #'({~parse
#`{~parse {~or {~and {~parse {~or (_ {~parse #t
#t
(ormap identity (ormap identity
(flatten (flatten (attribute present)))}
(attribute #,present)))} {~parse expanded-pat
#,expanded-pat #'rest-clause}
{~bind [#,succeeded #t]}} {~bind [succeeded #t]})
_} …
#'rest-clause}]) (_ {~fail (~a "expected one of the rest patterns"
lifted-rest))) " to match")})}
(define check-at-least-one-rest-handler #'(dummy)}))))
(if (null? lifted-rest)
#'()
(with-syntax ([([_ _ succeeded] …) lifted-rest])
#'({~fail #:unless (or (attribute succeeded) …)
"expected one of the rest patterns to match"}))))
(define check-no-dup-rest-handlers (define check-no-dup-rest-handlers
(if (null? lifted-rest) (if (null? lifted-rest)
#'() #'()
(with-syntax ([([_ _ succeeded] …) lifted-rest]) (with-syntax ([([present expanded-pat succeeded] …) lifted-rest])
#'({~fail #:when (> (length #'({~fail #:when (or (and (not (attribute succeeded))
(filter (λ (x) x) (ormap identity
(list (attribute succeeded) …))) (flatten (attribute present)))
1) (syntax-parse #'rest-clause
(string-append "more than one of the lifted rest" [expanded-pat #t]
" patterns matched")})))) [_ #f]))
…)
(~a "more than one of the lifted rest patterns"
" matched")}))))
((λ (x) #;(pretty-write (syntax->datum #`(syntax-parser [#,x 'ok]))) x) ((λ (x) #;(pretty-write (syntax->datum #`(syntax-parser [#,x 'ok]))) x)
#`(~delimit-cut #`(~delimit-cut
(~and #,(fix-disappeared-uses) (~and #,(fix-disappeared-uses)
@ -244,7 +243,6 @@
#,@(reverse pre-acc) #,@(reverse pre-acc)
#,@caught-omitable-lifted-rest #,@caught-omitable-lifted-rest
#,@rest-handlers #,@rest-handlers
#,@check-at-least-one-rest-handler
~! ~!
#,@check-no-dup-rest-handlers #,@check-no-dup-rest-handlers
(~bind #,@post-group-bindings) (~bind #,@post-group-bindings)