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

syntax/parse: make undo cooperate with ~commit and ~! (cut)

Browse Source
This commit is contained in:
Ryan Culpepper 2017-12-09 00:55:31 +01:00 committed by Georges Dupéron
parent c61353a0f8
commit bf47b22091
9 changed files with 120 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
parse/debug.rkt
View File

@ -43,8 +43,8 @@
[(name ...) (map attr-name attrs)] [(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)]) [(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (fs) fs)]) #'(let ([fh (lambda (fs) fs)])
(app-argu parser x x (ps-empty x x) #f fh fh #f (app-argu parser x x (ps-empty x x) #f null fh fh #f
(lambda (fh . attr-values) (lambda (fh undos . attr-values)
(map vector '(name ...) '(depth ...) attr-values)) (map vector '(name ...) '(depth ...) attr-values))
argu))))))])) argu))))))]))

2
parse/experimental/provide.rkt
View File

@ -84,7 +84,7 @@
[opc-id opc] ... [opc-id opc] ...
[okwc-id okwc] ...) [okwc-id okwc] ...)
(rename-contract (rename-contract
(->* (any/c any/c any/c any/c any/c any/c any/c any/c (->* (any/c any/c any/c any/c any/c any/c any/c any/c any/c
mpc-id ... mkw-c-part ... ...) mpc-id ... mkw-c-part ... ...)
(okw-c-part ... ...) (okw-c-part ... ...)
any) any)

4
parse/experimental/reflect.rkt
View File

@ -73,9 +73,9 @@
(arity minpos* maxpos* minkws* maxkws*))])] (arity minpos* maxpos* minkws* maxkws*))])]
[curried-parser [curried-parser
(make-keyword-procedure (make-keyword-procedure
(lambda (kws2 kwargs2 x cx pr es fh cp rl success . rest2) (lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)]) (let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
(keyword-apply parser kws kwargs x cx pr es fh cp rl success (keyword-apply parser kws kwargs x cx pr es undos fh cp rl success
(append rest1 rest2)))))] (append rest1 rest2)))))]
[ctor [ctor
(cond [(reified-syntax-class? r) (cond [(reified-syntax-class? r)

4
parse/experimental/specialize.rkt
View File

@ -36,5 +36,5 @@
'splicing? 'splicing?
'opts #f)) 'opts #f))
(define-values (parser) (define-values (parser)
(lambda (x cx pr es fh0 cp0 rl success . formals) (lambda (x cx pr es undos fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))]))) (app-argu target-parser x cx pr es undos fh0 cp0 rl success argu))))))))])))

10
parse/experimental/splicing.rkt
View File

@ -35,7 +35,7 @@
description) description)
(define parser (define parser
(let ([permute (mk-permute '(a.name ...))]) (let ([permute (mk-permute '(a.name ...))])
(lambda (x cx pr es fh _cp rl success param ...) (lambda (x cx pr es undos fh _cp rl success param ...)
(let ([stx (datum->syntax cx x cx)]) (let ([stx (datum->syntax cx x cx)])
(let ([result (let ([result
(let/ec escape (let/ec escape
@ -46,13 +46,13 @@
(case (car result) (case (car result)
((ok) ((ok)
(apply success (apply success
((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh) ((mk-check-result pr 'name (length '(a.name ...)) permute x cx undos fh)
(cdr result)))) (cdr result))))
((error) ((error)
(let ([es (let ([es
(es-add-message (cadr result) (es-add-message (cadr result)
(es-add-thing pr (get-description param ...) #f rl es))]) (es-add-thing pr (get-description param ...) #f rl es))])
(fh (failure pr es)))))))))) (fh undos (failure pr es))))))))))
(define-syntax name (define-syntax name
(stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '()) (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
(sort-sattrs '(#s(attr a.name a.depth #f) ...)) (sort-sattrs '(#s(attr a.name a.depth #f) ...))
@ -76,7 +76,7 @@
(for/list ([index (in-vector indexes)]) (for/list ([index (in-vector indexes)])
(list-ref result index))))))) (list-ref result index)))))))
(define (mk-check-result pr name attr-count permute x cx fh) (define (mk-check-result pr name attr-count permute x cx undos fh)
(lambda (result) (lambda (result)
(unless (list? result) (unless (list? result)
(error name "parser returned non-list")) (error name "parser returned non-list"))
@ -91,5 +91,5 @@
(error name "expected exact nonnegative integer for first element of result list, got ~e" (error name "expected exact nonnegative integer for first element of result list, got ~e"
skip)) skip))
(let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)]) (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
(list* fh rest-x rest-cx (ps-add-cdr pr skip) (list* fh undos rest-x rest-cx (ps-add-cdr pr skip)
(permute (cdr result)))))))) (permute (cdr result))))))))

122
parse/private/parse.rkt
View File

@ -89,11 +89,11 @@
#f #f
(scopts 0 #t #t 'description) (scopts 0 #t #t 'description)
(quote-syntax predicate))) (quote-syntax predicate)))
(define (parser x cx pr es fh0 cp0 rl success) (define (parser x cx pr es undos fh0 cp0 rl success)
(if (predicate x) (if (predicate x)
(success fh0) (success fh0 undos)
(let ([es (es-add-thing pr 'description #t rl es)]) (let ([es (es-add-thing pr 'description #t rl es)])
(fh0 (failure* pr es)))))))])) (fh0 undos (failure* pr es)))))))]))
(define-syntax (parser/rhs stx) (define-syntax (parser/rhs stx)
(syntax-case stx () (syntax-case stx ()
@ -155,7 +155,7 @@
[transparent? transparent?] [transparent? transparent?]
[delimit-cut? delimit-cut?] [delimit-cut? delimit-cut?]
[body body]) [body body])
#`(lambda (x cx pr es fh0 cp0 rl success . formals*) #`(lambda (x cx pr es undos fh0 cp0 rl success . formals*)
(with ([this-syntax x] (with ([this-syntax x]
[this-role rl]) [this-role rl])
def ... def ...
@ -168,7 +168,8 @@
#,(if no-fail? #'#f #'es))] #,(if no-fail? #'#f #'es))]
[pr (if 'transparent? pr (ps-add-opaque pr))]) [pr (if 'transparent? pr (ps-add-opaque pr))])
(with ([fail-handler fh0] (with ([fail-handler fh0]
[cut-prompt cp0]) [cut-prompt cp0]
[undo-stack undos])
;; Update the prompt, if required ;; Update the prompt, if required
;; FIXME: can be optimized away if no cut exposed within variants ;; FIXME: can be optimized away if no cut exposed within variants
(with-maybe-delimit-cut delimit-cut? (with-maybe-delimit-cut delimit-cut?
@ -230,7 +231,8 @@
def ... def ...
(#%expression (#%expression
(with ([fail-handler fh0] (with ([fail-handler fh0]
[cut-prompt fh0]) [cut-prompt fh0]
[undo-stack null])
(parse:S x cx pattern pr es (parse:S x cx pattern pr es
(list (attribute name) ...)))))))))))])) (list (attribute name) ...)))))))))))]))
@ -251,18 +253,24 @@ Parsing protocols:
pr, es are progress and expectstack, respectively pr, es are progress and expectstack, respectively
rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr
(stxclass-parser x cx pr es fail-handler cut-prompt role success-proc arg ...) : Ans (stxclass-parser x cx pr es undos fail-handler cut-prompt role success-proc arg ...) : Ans
success-proc: success-proc:
for stxclass, is (fail-handler attr-value ... -> Ans) for stxclass, is (fail-handler undos attr-value ... -> Ans)
for splicing-stxclass, is (fail-handler rest-x rest-cx rest-pr attr-value -> Ans) for splicing-stxclass, is (undos fail-handler rest-x rest-cx rest-pr attr-value -> Ans)
fail-handler, cut-prompt : failure -> Ans fail-handler, cut-prompt : undos failure -> Ans
Fail-handler is normally represented with stxparam 'fail-handler', but must be Fail-handler is normally represented with stxparam 'fail-handler', but must be
threaded through stxclass calls (in through stxclass-parser, out through threaded through stxclass calls (in through stxclass-parser, out through
success-proc) to support backtracking. Cut-prompt is never changed within success-proc) to support backtracking. Cut-prompt is never changed within
stxclass or within alternative, so no threading needed. stxclass or within alternative, so no threading needed.
The undo stack is normally represented with stxparam 'undo-stack', but must be
threaded through stxclass calls (like fail-handler). A failure handler closes
over a base undo stack and receives an extended current undo stack; the failure
handler unwinds effects by performing every action in the difference between
them and then restores the saved undo stack.
Usually sub-patterns processed in tail position, but *can* do non-tail calls for: Usually sub-patterns processed in tail position, but *can* do non-tail calls for:
- ~commit - ~commit
- var of stxclass with ~commit - var of stxclass with ~commit
@ -368,7 +376,7 @@ Conventions:
(reorder-iattrs (wash-sattrs #'relsattrs) (reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))]) (wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs]) (with-syntax ([(#s(attr name _ _) ...) reliattrs])
#'(success fail-handler also ... (attribute name) ...)))])) #'(success fail-handler undo-stack also ... (attribute name) ...)))]))
;; ---- ;; ----
@ -443,7 +451,8 @@ Conventions:
def ... def ...
(parameterize ((current-syntax-context (cadr ctx0))) (parameterize ((current-syntax-context (cadr ctx0)))
(with ([fail-handler fh0] (with ([fail-handler fh0]
[cut-prompt fh0]) [cut-prompt fh0]
[undo-stack null])
#,(cond [(pair? patterns) #,(cond [(pair? patterns)
(with-syntax ([matrix (with-syntax ([matrix
(optimize-matrix (optimize-matrix
@ -537,26 +546,31 @@ Conventions:
#'())]) #'())])
(if (not (syntax-e #'commit?)) (if (not (syntax-e #'commit?))
;; The normal protocol ;; The normal protocol
#'(app-argu parser x cx pr es fail-handler cut-prompt role #'(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role
(lambda (fh av ...) (lambda (fh undos av ...)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...)) (let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
k)))) k))))
argu) argu)
;; The commit protocol ;; The commit protocol
;; (Avoids putting k in procedure) ;; (Avoids putting k in procedure)
#'(let-values ([(fs av ...) #'(let-values ([(fs undos av ...)
(with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))]) (with ([fail-handler
(lambda (undos fs)
(unwind-to undos undo-stack)
(values fs undo-stack (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler]) (with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt role (app-argu parser x cx pr es undo-stack
(lambda (fh av ...) (values #f av ...)) fail-handler cut-prompt role
(lambda (fh undos av ...) (values #f undos av ...))
argu)))]) argu)))])
(if fs (if fs
(fail fs) (fail fs)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...)) (let-attributes* ((nested-a ...) (av ...))
k))))))] (with ([undo-stack undos])
k)))))))]
[#s(pat:reflect obj argu attr-decls name (nested-a ...)) [#s(pat:reflect obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
@ -564,11 +578,11 @@ Conventions:
#'())]) #'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) (with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)]) #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)])
(app-argu parser x cx pr es fail-handler cut-prompt #f (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f
(lambda (fh . result) (lambda (fh undos . result)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result) (let/unpack ((nested-a ...) result)
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
k)))) k))))
argu))))] argu))))]
[#s(pat:datum datum) [#s(pat:datum datum)
@ -598,9 +612,9 @@ Conventions:
[#s(pat:or (a ...) (subpattern ...) (subattrs ...)) [#s(pat:or (a ...) (subpattern ...) (subattrs ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success #`(let ([success
(lambda (fh id ...) (lambda (fh undos id ...)
(let-attributes ([a id] ...) (let-attributes ([a id] ...)
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
k)))]) k)))])
(try (parse:S x cx subpattern pr es (try (parse:S x cx subpattern pr es
(disjunct subattrs success () (id ...))) (disjunct subattrs success () (id ...)))
@ -610,14 +624,14 @@ Conventions:
[pr0 pr] [pr0 pr]
[es0 es] [es0 es]
[fail-to-succeed [fail-to-succeed
(lambda (fs) k)]) (lambda (undos fs) (unwind-to undos undo-stack) k)])
;; ~not implicitly prompts to be safe, ;; ~not implicitly prompts to be safe,
;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
;; (statically checked!) ;; (statically checked!)
(with ([fail-handler fail-to-succeed] (with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe [cut-prompt fail-to-succeed]) ;; to be safe
(parse:S x cx subpattern pr es (parse:S x cx subpattern pr es
(fh0 (failure* pr0 es0)))))] (fh0 undo-stack (failure* pr0 es0)))))]
[#s(pat:pair head tail) [#s(pat:pair head tail)
#`(let ([datum (if (syntax? x) (syntax-e x) x)] #`(let ([datum (if (syntax? x) (syntax-e x) x)]
[cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?! [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?!
@ -748,7 +762,7 @@ Conventions:
#`(let ([alt-sub-id (attribute sub-id)] ...) #`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...) (let ([id #f] ...)
(let ([sub-id alt-sub-id] ...) (let ([sub-id alt-sub-id] ...)
(success fail-handler pre ... id ...)))))])) (success fail-handler undo-stack pre ... id ...)))))]))
;; (parse:A x cx A-pattern pr es k) : expr[Ans] ;; (parse:A x cx A-pattern pr es k) : expr[Ans]
;; In k: attrs(A-pattern) are bound. ;; In k: attrs(A-pattern) are bound.
@ -778,9 +792,9 @@ Conventions:
[#s(action:do (stmt ...)) [#s(action:do (stmt ...))
#'(let () (no-shadow stmt) ... (#%expression k))] #'(let () (no-shadow stmt) ... (#%expression k))]
[#s(action:undo (stmt ...)) [#s(action:undo (stmt ...))
#'(try (with ([cut-prompt illegal-cut-error]) #'(with ([undo-stack (cons (lambda () stmt ... (void)) undo-stack)]
(#%expression k)) [cut-prompt illegal-cut-error])
(begin (#%expression stmt) ... (fail (failure* pr es))))] k)]
[#s(action:ord pattern group index) [#s(action:ord pattern group index)
#'(let ([pr* (ps-add pr '#s(ord group index))]) #'(let ([pr* (ps-add pr '#s(ord group index))])
(parse:A x cx pattern pr* es k))] (parse:A x cx pattern pr* es k))]
@ -831,27 +845,32 @@ Conventions:
#'())]) #'())])
(if (not (syntax-e #'commit?)) (if (not (syntax-e #'commit?))
;; The normal protocol ;; The normal protocol
#`(app-argu parser x cx pr es fail-handler cut-prompt role #`(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role
(lambda (fh rest-x rest-cx rest-pr av ...) (lambda (fh undos rest-x rest-cx rest-pr av ...)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...)) (let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
k)))) k))))
argu) argu)
;; The commit protocol ;; The commit protocol
;; (Avoids putting k in procedure) ;; (Avoids putting k in procedure)
#'(let-values ([(fs rest-x rest-cx rest-pr av ...) #'(let-values ([(fs undos rest-x rest-cx rest-pr av ...)
(with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))]) (with ([fail-handler
(lambda (undos fs)
(unwind-to undos undo-stack)
(values fs undo-stack #f #f #f (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler]) (with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt role (app-argu parser x cx pr es undo-stack
(lambda (fh rest-x rest-cx rest-pr av ...) fail-handler cut-prompt role
(values #f rest-x rest-cx rest-pr av ...)) (lambda (fh undos rest-x rest-cx rest-pr av ...)
(values #f undos rest-x rest-cx rest-pr av ...))
argu)))]) argu)))])
(if fs (if fs
(fail fs) (fail fs)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...)) (let-attributes* ((nested-a ...) (av ...))
k))))))] (with ([undo-stack undos])
k)))))))]
[#s(hpat:reflect obj argu attr-decls name (nested-a ...)) [#s(hpat:reflect obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
@ -860,11 +879,11 @@ Conventions:
#'())]) #'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) (with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)]) #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)])
(app-argu parser x cx pr es fail-handler cut-prompt #f (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f
(lambda (fh rest-x rest-cx rest-pr . result) (lambda (fh undos rest-x rest-cx rest-pr . result)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result) (let/unpack ((nested-a ...) result)
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
k)))) k))))
argu))))] argu))))]
[#s(hpat:and head single) [#s(hpat:and head single)
@ -875,9 +894,9 @@ Conventions:
[#s(hpat:or (a ...) (subpattern ...) (subattrs ...)) [#s(hpat:or (a ...) (subpattern ...) (subattrs ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success #`(let ([success
(lambda (fh rest-x rest-cx rest-pr id ...) (lambda (fh undos rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...) (let-attributes ([a id] ...)
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
k)))]) k)))])
(try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(disjunct subattrs success (rest-x rest-cx rest-pr) (id ...))) (disjunct subattrs success (rest-x rest-cx rest-pr) (id ...)))
@ -921,7 +940,8 @@ Conventions:
[pr0 pr] [pr0 pr]
[es0 es] [es0 es]
[fail-to-succeed [fail-to-succeed
(lambda (fs) (lambda (undos fs)
(unwind-to undos undo-stack)
(let ([rest-x x] (let ([rest-x x]
[rest-cx cx] [rest-cx cx]
[rest-pr pr]) [rest-pr pr])
@ -932,7 +952,7 @@ Conventions:
(with ([fail-handler fail-to-succeed] (with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe [cut-prompt fail-to-succeed]) ;; to be safe
(parse:H x cx rest-x rest-cx rest-pr subpattern pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(fh0 (failure* pr0 es0)))))] (fh0 undo-stack (failure* pr0 es0)))))]
[_ [_
#'(parse:S x cx #'(parse:S x cx
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
@ -999,11 +1019,11 @@ Conventions:
tail-pattern-is-null?]) tail-pattern-is-null?])
(define/with-syntax alt-map #'((id . alt-id) ...)) (define/with-syntax alt-map #'((id . alt-id) ...))
(define/with-syntax loop-k (define/with-syntax loop-k
#'(dots-loop dx* dcx* loop-pr* fail-handler rel-rep ... alt-id ...)) #'(dots-loop dx* dcx* loop-pr* undo-stack fail-handler rel-rep ... alt-id ...))
#`(let () #`(let ()
;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
(define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...) (define (dots-loop dx dcx loop-pr undos fh rel-rep ... alt-id ...)
(with ([fail-handler fh]) (with ([fail-handler fh] [undo-stack undos])
(try-or-pair/null-check do-pair/null? dx dcx loop-pr es (try-or-pair/null-check do-pair/null? dx dcx loop-pr es
(try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr* (try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr*
alt-map head-rep head es loop-k) alt-map head-rep head es loop-k)
@ -1017,7 +1037,7 @@ Conventions:
(parse:S dx dcx tail loop-pr es k))])))) (parse:S dx dcx tail loop-pr es k))]))))
(let ([rel-rep 0] ... (let ([rel-rep 0] ...
[alt-id (rep:initial-value attr-repc)] ...) [alt-id (rep:initial-value attr-repc)] ...)
(dots-loop x cx pr fail-handler rel-rep ... alt-id ...)))))])) (dots-loop x cx pr undo-stack fail-handler rel-rep ... alt-id ...)))))]))
;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt) ;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt)
(define-syntax try-or-pair/null-check (define-syntax try-or-pair/null-check

13
parse/private/residual.rkt
View File

@ -279,8 +279,9 @@
["runtime-report.rkt" ["runtime-report.rkt"
(call-current-failure-handler ctx fs)]) (call-current-failure-handler ctx fs)])
;; syntax-patterns-fail : (list Symbol/#f Syntax) -> FailureSet -> (escapes) ;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes
(define ((syntax-patterns-fail ctx) fs) (define ((syntax-patterns-fail ctx) undos fs)
(unwind-to undos null)
(call-current-failure-handler ctx fs)) (call-current-failure-handler ctx fs))
;; == specialized ellipsis parser ;; == specialized ellipsis parser
@ -314,3 +315,11 @@
(define (illegal-cut-error . _) (define (illegal-cut-error . _)
(error 'syntax-parse "illegal use of cut")) (error 'syntax-parse "illegal use of cut"))
(provide unwind-to)
(define (unwind-to undos base)
;; PRE: undos = (list* proc ... base)
(unless (eq? undos base)
((car undos))
(unwind-to (cdr undos) base)))

12
parse/private/runtime-reflect.rkt
View File

@ -82,13 +82,13 @@ A Reified is
[else [else
(loop (cdr result) indexes (add1 i))]))) (loop (cdr result) indexes (add1 i))])))
(make-keyword-procedure (make-keyword-procedure
(lambda (kws kwargs x cx pr es fh cp rl success . rest) (lambda (kws kwargs x cx pr es undos fh cp rl success . rest)
(keyword-apply parser kws kwargs x cx pr es fh cp rl (keyword-apply parser kws kwargs x cx pr es undos fh cp rl
(if splicing? (if splicing?
(lambda (fh x cx pr . result) (lambda (fh undos x cx pr . result)
(apply success fh x cx pr (take-indexes result indexes))) (apply success fh undos x cx pr (take-indexes result indexes)))
(lambda (fh . result) (lambda (fh undos . result)
(apply success fh (take-indexes result indexes)))) (apply success fh undos (take-indexes result indexes))))
rest)))))) rest))))))
(define (wrong-depth who a b) (define (wrong-depth who a b)

30
parse/private/runtime.rkt
View File

@ -14,6 +14,7 @@
(provide with (provide with
fail-handler fail-handler
cut-prompt cut-prompt
undo-stack
wrap-user-code wrap-user-code
fail fail
@ -59,29 +60,38 @@ residual.rkt.
(define-syntax-parameter cut-prompt (define-syntax-parameter cut-prompt
(lambda (stx) (lambda (stx)
(wrong-syntax stx "internal error: cut-prompt used out of context"))) (wrong-syntax stx "internal error: cut-prompt used out of context")))
(define-syntax-parameter undo-stack
(lambda (stx)
(wrong-syntax stx "internal error: undo-stack used out of context")))
(define-syntax-rule (wrap-user-code e) (define-syntax-rule (wrap-user-code e)
(with ([fail-handler #f] (with ([fail-handler #f]
[cut-prompt #t]) [cut-prompt #t]
[undo-stack null])
e)) e))
(define-syntax-rule (fail fs) (define-syntax-rule (fail fs)
(fail-handler fs)) (fail-handler undo-stack fs))
(define-syntax (try stx) (define-syntax (try stx)
(syntax-case stx () (syntax-case stx ()
[(try e0 e ...) [(try e0 e ...)
(with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))]) (with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
(with-syntax ([(fh ...) (generate-temporaries #'(re ...))]) (with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
(with-syntax ([(next-fh ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)] (with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)])
[(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)]) #'(let* ([fh (lambda (undos1 fs1)
#'(let* ([fh (lambda (fs1)
(with ([fail-handler (with ([fail-handler
(lambda (fs2) (lambda (undos2 fs2)
(next-fh (cons fs1 fs2)))]) (unwind-to undos2 undos1)
(next-fh undos1 (cons fs1 fs2)))]
[undo-stack undos1])
re))] re))]
...) ...)
(with ([fail-handler last-fh]) (with ([fail-handler
(lambda (undos2 fs2)
(unwind-to undos2 undo-stack)
(last-fh undo-stack fs2))]
[undo-stack undo-stack])
e0)))))])) e0)))))]))
;; == Attributes ;; == Attributes
@ -208,8 +218,8 @@ residual.rkt.
(length (syntax->list #'(parg ...))) (length (syntax->list #'(parg ...)))
(syntax->datum #'(kw ...)))]) (syntax->datum #'(kw ...)))])
(with-syntax ([parser (stxclass-parser sc)]) (with-syntax ([parser (stxclass-parser sc)])
#'(lambda (x cx pr es fh cp rl success) #'(lambda (x cx pr es undos fh cp rl success)
(app-argu parser x cx pr es fh cp rl success argu)))))])) (app-argu parser x cx pr es undos fh cp rl success argu)))))]))
(define-syntax (app-argu stx) (define-syntax (app-argu stx)
(syntax-case stx () (syntax-case stx ()