From f816a8afcd2b7bb61310208ea6571495ed070b3b Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 27 Nov 2017 16:59:10 +0100 Subject: [PATCH] syntax/parse: add ~undo, #:undo for unwinding effects Note: this version doesn't work with ~commit or ~!, because it stores both choice points and undo actions in the failure continuation. Commit and cut should discard choice points but preserve undo actions. --- .../syntax/parse/private/keywords.rkt | 1 + .../collects/syntax/parse/private/parse.rkt | 4 ++++ .../syntax/parse/private/rep-patterns.rkt | 7 +++++++ racket/collects/syntax/parse/private/rep.rkt | 20 +++++++++++++++++-- .../syntax/parse/private/residual.rkt | 5 +++++ 5 files changed, 35 insertions(+), 2 deletions(-) diff --git a/racket/collects/syntax/parse/private/keywords.rkt b/racket/collects/syntax/parse/private/keywords.rkt index 8572770f86..419b1f2a0d 100644 --- a/racket/collects/syntax/parse/private/keywords.rkt +++ b/racket/collects/syntax/parse/private/keywords.rkt @@ -29,6 +29,7 @@ (define-keyword ~fail) (define-keyword ~parse) (define-keyword ~do) +(define-keyword ~undo) (define-keyword ...+) (define-keyword ~delimit-cut) (define-keyword ~commit) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index db71140242..4239e6f3a8 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -771,6 +771,10 @@ Conventions: (parse:S y cy pattern pr* es k))] [#s(action:do (stmt ...)) #'(let () (no-shadow stmt) ... (#%expression k))] + [#s(action:undo (stmt ...)) + #'(try (with ([cut-prompt illegal-cut-error]) + (#%expression k)) + (begin (#%expression stmt) ... (fail (failure* pr es))))] [#s(action:ord pattern group index) #'(let ([pr* (ps-add pr '#s(ord group index))]) (parse:A x cx pattern pr* es k))] diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index addbf2ab19..2f7c001fd1 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -73,6 +73,7 @@ A ActionPattern is one of (action:and (listof ActionPattern)) (action:parse SinglePattern stx) (action:do (listof stx)) + (action:undo (listof stx)) (action:ord ActionPattern UninternedSymbol Nat) (action:post ActionPattern) @@ -86,6 +87,7 @@ A SideClause is just an ActionPattern (define-struct action:and (patterns) #:prefab) (define-struct action:parse (pattern expr) #:prefab) (define-struct action:do (stmts) #:prefab) +(define-struct action:undo (stmts) #:prefab) (define-struct action:ord (pattern group index) #:prefab) (define-struct action:post (pattern) #:prefab) @@ -167,6 +169,7 @@ A RepConstraint is one of (action:and? x) (action:parse? x) (action:do? x) + (action:undo? x) (action:ord? x) (action:post? x))) @@ -268,6 +271,8 @@ A RepConstraint is one of (pattern-attrs sp)] [(action:do _) null] + [(action:undo _) + null] [(action:ord sp _ _) (pattern-attrs sp)] [(action:post sp) @@ -343,6 +348,7 @@ A RepConstraint is one of [(action:and ps) (ormap pattern-has-cut? ps)] [(action:parse sp _) (pattern-has-cut? sp)] [(action:do _) #f] + [(action:undo _) #f] [(action:ord sp _ _) (pattern-has-cut? sp)] [(action:post sp) (pattern-has-cut? sp)] @@ -484,6 +490,7 @@ A RepConstraint is one of [(action:and? p) (patterns-AF (action:and-patterns p))] [(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)] [(action:do? p) AF-NONE] + [(action:undo? p) AF-SUB] [(action:ord? p) (pattern-AF (action:ord-pattern p))] [(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)] ;; Head patterns, eh patterns, etc diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index 75c70b8931..9f8d239d5d 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -121,6 +121,7 @@ (quote-syntax ~fail) (quote-syntax ~parse) (quote-syntax ~do) + (quote-syntax ~undo) (quote-syntax ...+) (quote-syntax ~delimit-cut) (quote-syntax ~commit) @@ -459,7 +460,7 @@ (define not-shadowed? (make-not-shadowed? decls)) (check-pattern (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe - ~seq ~optional ~! ~bind ~fail ~parse ~do + ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect ~splicing-reflect) (make-not-shadowed-id=? decls) @@ -578,6 +579,10 @@ (disappeared! stx) (check-action! (parse-pat:do stx decls))] + [(~undo . rest) + (disappeared! stx) + (check-action! + (parse-pat:undo stx decls))] [(head dots . tail) (and (dots? #'dots) (not-shadowed? #'dots)) (begin (disappeared! #'dots) @@ -1087,6 +1092,13 @@ [_ (wrong-syntax stx "bad ~~do pattern")])) +(define (parse-pat:undo stx decls) + (syntax-case stx () + [(_ stmt ...) + (action:undo (syntax->list #'(stmt ...)))] + [_ + (wrong-syntax stx "bad ~~undo pattern")])) + (define (parse-pat:rest stx decls) (syntax-case stx () [(_ pattern) @@ -1252,6 +1264,9 @@ [(cons (list '#:do do-stx stmts) rest) (cons (action:do stmts) (parse-pattern-sides rest decls))] + [(cons (list '#:undo undo-stx stmts) rest) + (cons (action:undo stmts) + (parse-pattern-sides rest decls))] ['() '()])) @@ -1616,7 +1631,8 @@ (list '#:attr check-attr-arity check-expression) (list '#:and check-expression) (list '#:post check-expression) - (list '#:do check-stmt-list))) + (list '#:do check-stmt-list) + (list '#:undo check-stmt-list))) ;; fail-directive-table (define fail-directive-table diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt index baea0658a0..bb25158ad7 100644 --- a/racket/collects/syntax/parse/private/residual.rkt +++ b/racket/collects/syntax/parse/private/residual.rkt @@ -300,3 +300,8 @@ ;; that *should* have been cancelled out by ineffable pair failures. |#) (values 'fail (failure pr es)))]))))) + +(provide illegal-cut-error) + +(define (illegal-cut-error . _) + (error 'syntax-parse "illegal use of cut"))