From a0065b9efa322260ebfa5ea218588ed8820bb7a9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 29 Feb 2012 04:16:07 -0700 Subject: [PATCH] syntax/parse: cut-prompt is inherited, not threaded --- collects/syntax/parse/debug.rkt | 2 +- .../syntax/parse/experimental/reflect.rkt | 2 +- .../syntax/parse/experimental/splicing.rkt | 8 +-- collects/syntax/parse/private/parse.rkt | 63 +++++++++---------- .../syntax/parse/private/runtime-reflect.rkt | 8 +-- 5 files changed, 38 insertions(+), 45 deletions(-) diff --git a/collects/syntax/parse/debug.rkt b/collects/syntax/parse/debug.rkt index 5e89215486..f5b90c5855 100644 --- a/collects/syntax/parse/debug.rkt +++ b/collects/syntax/parse/debug.rkt @@ -40,7 +40,7 @@ [(depth ...) (map attr-depth attrs)]) #'(let ([fh (lambda (fs) fs)]) (app-argu parser x x (ps-empty x x) null fh fh - (lambda (fh cp . attr-values) + (lambda (fh . attr-values) (map vector '(name ...) '(depth ...) attr-values)) argu)))))])) diff --git a/collects/syntax/parse/experimental/reflect.rkt b/collects/syntax/parse/experimental/reflect.rkt index 578f0f4413..809663f777 100644 --- a/collects/syntax/parse/experimental/reflect.rkt +++ b/collects/syntax/parse/experimental/reflect.rkt @@ -74,7 +74,7 @@ (make-keyword-procedure (lambda (kws2 kwargs2 x cx pr es fh cp success . rest2) (let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)]) - (keyword-apply kws kwargs x cx pr es fh cp success + (keyword-apply parser kws kwargs x cx pr es fh cp success (append rest1 rest2)))))] [ctor (cond [(reified-syntax-class? r) diff --git a/collects/syntax/parse/experimental/splicing.rkt b/collects/syntax/parse/experimental/splicing.rkt index 9b0107c958..d73986267a 100644 --- a/collects/syntax/parse/experimental/splicing.rkt +++ b/collects/syntax/parse/experimental/splicing.rkt @@ -34,7 +34,7 @@ description) (define parser (let ([permute (mk-permute '(a.name ...))]) - (lambda (x cx pr es fh cp success param ...) + (lambda (x cx pr es fh _cp success param ...) (let ([stx (datum->syntax cx x cx)]) (let ([result (let/ec escape @@ -45,7 +45,7 @@ (case (car result) ((ok) (apply success - ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh cp) + ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh) (cdr result)))) ((error) (let ([es @@ -76,7 +76,7 @@ (for/list ([index (in-vector indexes)]) (list-ref result index))))))) -(define (mk-check-result pr name attr-count permute x cx fh cp) +(define (mk-check-result pr name attr-count permute x cx fh) (lambda (result) (unless (list? result) (error name "parser returned non-list")) @@ -91,5 +91,5 @@ (error name "expected exact nonnegative integer for first element of result list, got ~e" skip)) (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)]) - (list* fh cp rest-x rest-cx (ps-add-cdr pr skip) + (list* fh rest-x rest-cx (ps-add-cdr pr skip) (permute (cdr result)))))))) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index d75b3fc206..783ab157ad 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -75,7 +75,7 @@ (integrate (quote-syntax predicate) 'description))) (define (parser x cx pr es fh0 cp0 success) (if (predicate x) - (success fh0 cp0) + (success fh0) (let ([es (cons (expect:thing 'description #t) es)]) (fh0 (failure pr es)))))))])) @@ -179,6 +179,8 @@ x is term to parse, usually syntax but can be pair, empty in cdr patterns cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src +success-proc : fail-handler attr-value ... -> Ans + Usually sub-patterns processed in tail position, but *can* do non-tail calls for: - ~commit @@ -329,7 +331,7 @@ Conventions: (reorder-iattrs (wash-sattrs #'relsattrs) (wash-iattrs #'iattrs))]) (with-syntax ([(#s(attr name _ _) ...) reliattrs]) - #'(success fail-handler cut-prompt also ... (attribute name) ...)))])) + #'(success fail-handler also ... (attribute name) ...)))])) ;; ---- @@ -426,11 +428,10 @@ Conventions: (if (not (syntax-e #'commit?)) ;; The normal protocol #'(app-argu parser x cx pr es fail-handler cut-prompt - (lambda (fh cp av ...) + (lambda (fh av ...) (let-attributes (name-attr ...) (let-attributes* ((nested-a ...) (av ...)) - (with ([fail-handler fh] - [cut-prompt cp]) + (with ([fail-handler fh]) k)))) argu) ;; The commit protocol @@ -439,7 +440,7 @@ Conventions: (with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))]) (with ([cut-prompt fail-handler]) (app-argu parser x cx pr es fail-handler cut-prompt - (lambda (fh cp av ...) (values #f av ...)) + (lambda (fh av ...) (values #f av ...)) argu)))]) (if fs (fail fs) @@ -454,11 +455,10 @@ Conventions: (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)]) (app-argu parser x cx pr es fail-handler cut-prompt - (lambda (fh cp . result) + (lambda (fh . result) (let-attributes (name-attr ...) (let/unpack ((nested-a ...) result) - (with ([fail-handler fh] - [cut-prompt cp]) + (with ([fail-handler fh]) k)))) argu))))] [#s(pat:datum attrs datum) @@ -484,10 +484,9 @@ Conventions: [#s(pat:or (a ...) (subpattern ...)) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) #`(let ([success - (lambda (fh cp id ...) + (lambda (fh id ...) (let-attributes ([a id] ...) - (with ([fail-handler fh] - [cut-prompt cp]) + (with ([fail-handler fh]) k)))]) (try (parse:S x cx subpattern pr es (disjunct subpattern success () (id ...))) @@ -583,7 +582,7 @@ Conventions: #`(let ([alt-sub-id (attribute sub-id)] ...) (let ([id #f] ...) (let ([sub-id alt-sub-id] ...) - (success fail-handler cut-prompt pre ... id ...))))))])) + (success fail-handler pre ... id ...))))))])) ;; (disjunct/sides clauses success (pre:expr ...) (id:id ...)) : expr[Ans] (define-syntax (disjunct/sides stx) @@ -594,7 +593,7 @@ Conventions: #`(let ([alt-sub-id (attribute sub-id)] ...) (let ([id #f] ...) (let ([sub-id alt-sub-id] ...) - (success fail-handler cut-prompt pre ... id ...))))))])) + (success fail-handler pre ... id ...))))))])) ;; (parse:A x cx A-pattern pr es k) : expr[Ans] ;; In k: attrs(A-pattern) are bound. @@ -680,11 +679,10 @@ Conventions: (if (not (syntax-e #'commit?)) ;; The normal protocol #`(app-argu parser x cx pr es fail-handler cut-prompt - (lambda (fh cp rest-x rest-cx rest-pr av ...) + (lambda (fh rest-x rest-cx rest-pr av ...) (let-attributes (name-attr ...) (let-attributes* ((nested-a ...) (av ...)) - (with ([fail-handler fh] - [cut-prompt cp]) + (with ([fail-handler fh]) k)))) argu) ;; The commit protocol @@ -693,7 +691,7 @@ Conventions: (with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))]) (with ([cut-prompt fail-handler]) (app-argu parser x cx pr es fail-handler cut-prompt - (lambda (fh cp rest-x rest-cx rest-pr av ...) + (lambda (fh rest-x rest-cx rest-pr av ...) (values #f rest-x rest-cx rest-pr av ...)) argu)))]) (if fs @@ -710,12 +708,11 @@ Conventions: (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)]) (app-argu parser x cx pr es fail-handler cut-prompt - (lambda (fh cp rest-x rest-cx rest-pr . result) + (lambda (fh rest-x rest-cx rest-pr . result) (let-attributes (name-attr ...) (let/unpack ((nested-a ...) result) - (with ([fail-handler fh] - [cut-prompt cp]) - k)))) + (with ([fail-handler fh]) + k)))) argu))))] [#s(hpat:and (a ...) head single) #`(let ([cx0 cx]) @@ -725,10 +722,9 @@ Conventions: [#s(hpat:or (a ...) (subpattern ...)) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) #`(let ([success - (lambda (fh cp rest-x rest-cx rest-pr id ...) + (lambda (fh rest-x rest-cx rest-pr id ...) (let-attributes ([a id] ...) - (with ([fail-handler fh] - [cut-prompt cp]) + (with ([fail-handler fh]) k)))]) (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es (disjunct subpattern success @@ -743,14 +739,12 @@ Conventions: [#s(hpat:optional (a ...) pattern defaults) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) #`(let ([success - (lambda (fh cp rest-x rest-cx rest-pr id ...) + (lambda (fh rest-x rest-cx rest-pr id ...) (let-attributes ([a id] ...) - (with ([fail-handler fh] - [cut-prompt cp]) + (with ([fail-handler fh]) k)))]) (try (parse:H x cx rest-x rest-cx rest-pr pattern pr es - (success fail-handler cut-prompt - rest-x rest-cx rest-pr (attribute id) ...)) + (success fail-handler rest-x rest-cx rest-pr (attribute id) ...)) (let ([rest-x x] [rest-cx cx] [rest-pr pr]) @@ -858,12 +852,11 @@ Conventions: (equal? (syntax->datum #'tail) '#s(pat:datum () ()))]) (define/with-syntax alt-map #'((id . alt-id) ...)) (define/with-syntax loop-k - #'(dots-loop dx* dcx* loop-pr* fail-handler cut-prompt rel-rep ... alt-id ...)) + #'(dots-loop dx* dcx* loop-pr* fail-handler rel-rep ... alt-id ...)) #`(let () ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans - (define (dots-loop dx dcx loop-pr fh cp rel-rep ... alt-id ...) - (with ([fail-handler fh] - [cut-prompt cp]) + (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...) + (with ([fail-handler fh]) (try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es (try (parse:EH dx dcx loop-pr head-repc dx* dcx* loop-pr* alt-map head-rep head es loop-k) @@ -877,7 +870,7 @@ Conventions: (parse:S dx dcx tail loop-pr es k))])))) (let ([rel-rep 0] ... [alt-id (rep:initial-value attr-repc)] ...) - (dots-loop x cx pr fail-handler cut-prompt rel-rep ... alt-id ...)))))])) + (dots-loop x cx pr fail-handler rel-rep ... alt-id ...)))))])) ;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt) (define-syntax try-or-pair/null-check diff --git a/collects/syntax/parse/private/runtime-reflect.rkt b/collects/syntax/parse/private/runtime-reflect.rkt index 58280315c0..e542f7c77d 100644 --- a/collects/syntax/parse/private/runtime-reflect.rkt +++ b/collects/syntax/parse/private/runtime-reflect.rkt @@ -69,10 +69,10 @@ A Reified is (lambda (kws kwargs x cx pr es fh cp success . rest) (keyword-apply parser kws kwargs x cx pr es fh cp (if splicing? - (lambda (fh cp x cx . result) - (apply success fh cp x cx (take-indexes result indexes))) - (lambda (fh cp . result) - (apply success fh cp (take-indexes result indexes)))) + (lambda (fh x cx pr . result) + (apply success fh x cx pr (take-indexes result indexes))) + (lambda (fh . result) + (apply success fh (take-indexes result indexes)))) rest)))))) (define (wrong-depth who a b)