diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 1c6f9f3ec3..957d33482f 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -97,7 +97,7 @@ (if (predicate x) (success fh0) (let ([es (es-add-thing pr 'description #t rl es)]) - (fh0 (failure pr es)))))))])) + (fh0 (failure* pr es)))))))])) (define-syntax (parser/rhs stx) (syntax-case stx () @@ -108,23 +108,27 @@ (parameterize ((current-syntax-context #'ctx)) (parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?) #:context #'ctx))) - (rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?))))])) + (rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?) #'ctx)))])) (begin-for-syntax - (define (rhs->parser name formals relsattrs the-rhs splicing?) + (define (rhs->parser name formals relsattrs the-rhs splicing? [ctx #f]) (define-values (transparent? description variants defs commit? delimit-cut?) (match the-rhs [(rhs _ transparent? description variants defs commit? delimit-cut?) (values transparent? description variants defs commit? delimit-cut?)])) (define vdefss (map variant-definitions variants)) (define formals* (rewrite-formals formals #'x #'rl)) + (define patterns (map variant-pattern variants)) + (define no-fail? + (and (not splicing?) ;; FIXME: commit? needed? + (patterns-cannot-fail? patterns))) + (when no-fail? (log-syntax-parse-debug "(stxclass) cannot fail: ~e" ctx)) (define body - (cond [(null? variants) - #'(fail (failure pr es))] + (cond [(null? patterns) + #'(fail (failure* pr es))] [splicing? (with-syntax ([(alternative ...) - (for/list ([variant (in-list variants)]) - (define pattern (variant-pattern variant)) + (for/list ([pattern (in-list patterns)]) (with-syntax ([pattern pattern] [relsattrs relsattrs] [iattrs (pattern-attrs pattern)] @@ -140,8 +144,7 @@ [else (with-syntax ([matrix (optimize-matrix - (for/list ([variant (in-list variants)]) - (define pattern (variant-pattern variant)) + (for/list ([pattern (in-list patterns)]) (with-syntax ([iattrs (pattern-attrs pattern)] [relsattrs relsattrs] [commit? commit?]) @@ -165,7 +168,8 @@ (syntax-parameterize ((this-context-syntax (syntax-rules () [(tbs) (ps-context-syntax pr)]))) - (let ([es (es-add-thing pr description 'transparent? rl es)] + (let ([es (es-add-thing pr description 'transparent? rl + #,(if no-fail? #'#f #'es))] [pr (if 'transparent? pr (ps-add-opaque pr))]) (with ([fail-handler fh0] [cut-prompt cp0]) @@ -274,6 +278,7 @@ Some optimizations: - commit protocol for stxclasses (but not ~commit, no point) - avoid continue-vs-end choice point in (EH ... . ()) by eager pair check - integrable stxclasses, specialize ellipses of integrable stxclasses + - pattern lists that cannot fail set es=#f to disable ExpectStack allocation |# ;; ---- @@ -425,10 +430,12 @@ Conventions: (define-values (patterns body-exprs defs2s) (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))]) (for-clause clause))) + (define no-fail? (patterns-cannot-fail? patterns)) + (when no-fail? (log-syntax-parse-debug "cannot fail: ~e" #'ctx)) (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)]) #`(let* ([ctx0 (normalize-context '#,who #,context x)] [pr (ps-empty x (cadr ctx0))] - [es #f] + [es #,(if no-fail? #'#f #'#t)] [cx x] [fh0 (syntax-patterns-fail ctx0)]) def ... @@ -450,7 +457,7 @@ Conventions: #`(try alternative ...)) |#] [else - #`(fail (failure pr es))]))))))))])) + #`(fail (failure* pr es))]))))))))])) ;; ---- @@ -488,7 +495,7 @@ Conventions: [tpr (ps-add-cdr pr)]) (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)]) - (fail (failure pr es*)))))] + (fail (failure* pr es*)))))] [(parse:pk (in1 . ins) #s(pk/and inner)) #'(parse:matrix (in1 in1 . ins) inner)])) @@ -569,12 +576,12 @@ Conventions: #`(let ([d unwrap-x]) (if (equal? d (quote datum)) k - (fail (failure pr (es-add-atom 'datum es))))))] + (fail (failure* pr (es-add-atom 'datum es))))))] [#s(pat:literal literal input-phase lit-phase) #`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal) input-phase lit-phase)) k - (fail (failure pr (es-add-literal (quote-syntax literal) es))))] + (fail (failure* pr (es-add-literal (quote-syntax literal) es))))] [#s(pat:action action subpattern) #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] [#s(pat:head head tail) @@ -607,7 +614,7 @@ Conventions: (with ([fail-handler fail-to-succeed] [cut-prompt fail-to-succeed]) ;; to be safe (parse:S x cx subpattern pr es - (fh0 (failure pr0 es0)))))] + (fh0 (failure* pr0 es0)))))] [#s(pat:pair head tail) #`(let ([datum (if (syntax? x) (syntax-e x) x)] [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?! @@ -620,7 +627,7 @@ Conventions: (parse:S hx hcx head hpr es (parse:S tx cx tail tpr es k))) (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)]) - (fail (failure pr es*)))))] + (fail (failure* pr es*)))))] [#s(pat:vector subpattern) #`(let ([datum (if (syntax? x) (syntax-e x) x)]) (if (vector? datum) @@ -628,7 +635,7 @@ Conventions: [vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ??? [pr* (ps-add-unvector pr)]) (parse:S datum vcx subpattern pr* es k)) - (fail (failure pr es))))] + (fail (failure* pr es))))] [#s(pat:box subpattern) #`(let ([datum (if (syntax? x) (syntax-e x) x)]) (if (box? datum) @@ -636,7 +643,7 @@ Conventions: [bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ??? [pr* (ps-add-unbox pr)]) (parse:S datum bcx subpattern pr* es k)) - (fail (failure pr es))))] + (fail (failure* pr es))))] [#s(pat:pstruct key subpattern) #`(let ([datum (if (syntax? x) (syntax-e x) x)]) (if (let ([xkey (prefab-struct-key datum)]) @@ -645,7 +652,7 @@ Conventions: [scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ??? [pr* (ps-add-unpstruct pr)]) (parse:S datum scx subpattern pr* es k)) - (fail (failure pr es))))] + (fail (failure* pr es))))] [#s(pat:describe pattern description transparent? role) #`(let ([es* (es-add-thing pr description transparent? role es)] [pr* (if 'transparent? pr (ps-add-opaque pr))]) @@ -677,7 +684,7 @@ Conventions: (if (predicate x*) (let-attributes (name-attr ...) k) (let ([es* (es-add-thing pr 'description #t role es)]) - (fail (failure pr es*))))))])])) + (fail (failure* pr es*))))))])])) ;; (first-desc:S S-pattern) : expr[FirstDesc] (define-syntax (first-desc:S stx) @@ -758,7 +765,7 @@ Conventions: (if c (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)] [es* (es-add-message message es)]) - (fail (failure pr* es*))) + (fail (failure* pr* es*))) k))] [#s(action:parse pattern expr) #`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))] @@ -917,7 +924,7 @@ Conventions: (with ([fail-handler fail-to-succeed] [cut-prompt fail-to-succeed]) ;; to be safe (parse:H x cx rest-x rest-cx rest-pr subpattern pr es - (fh0 (failure pr0 es0)))))] + (fh0 (failure* pr0 es0)))))] [_ #'(parse:S x cx ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) @@ -995,7 +1002,7 @@ Conventions: ...) (cond [(< rel-rep (rep:min-number rel-repc)) (let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)]) - (fail (failure loop-pr es)))] + (fail (failure* loop-pr es)))] ... [else (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...) @@ -1010,7 +1017,7 @@ Conventions: [(topc #t x cx pr es pair-alt null-alt) (cond [(stx-pair? x) pair-alt] [(stx-null? x) null-alt] - [else (fail (failure pr es))])] + [else (fail (failure* pr es))])] [(topc _ x cx pr es alt1 alt2) (try alt1 alt2)])) @@ -1041,7 +1048,7 @@ Conventions: (if (< rep (rep:max-number repc)) (let ([rep (add1 rep)]) k*) (let ([es* (expectation-of-reps/too-many es rep repc)]) - (fail (failure pr* es*)))))]))])) + (fail (failure* pr* es*)))))]))])) ;; (rep:initial-value RepConstraint) : expr (define-syntax (rep:initial-value stx) diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index b283cf5dc0..4d46626cd2 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -511,6 +511,15 @@ A RepConstraint is one of ;; ---- +;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean +;; Returns true if the disjunction of the patterns always succeeds---and thus no +;; failure-tracking needed. Note: beware cut! +(define (patterns-cannot-fail? patterns) + (and (not (ormap pattern-has-cut? patterns)) + (ormap pattern-cannot-fail? patterns))) + +;; ---- + ;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic) (define (3and a b) diff --git a/racket/collects/syntax/parse/private/runtime-progress.rkt b/racket/collects/syntax/parse/private/runtime-progress.rkt index 7dbebbdf3d..ba8eebcb18 100644 --- a/racket/collects/syntax/parse/private/runtime-progress.rkt +++ b/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -20,6 +20,8 @@ ps-difference (struct-out failure) + failure* + expect? (struct-out expect:thing) (struct-out expect:atom) @@ -49,6 +51,8 @@ A FailFunction = (FailureSet -> Answer) |# (define-struct failure (progress expectstack) #:prefab) +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) ;; == Progress == @@ -177,11 +181,15 @@ An ExpectStack (during parsing) is one of * (expect:atom Datum ExpectStack) * (expect:literal Identifier ExpectStack) * (expect:proper-pair FirstDesc ExpectStack) + * #t The *-marked variants can only occur at the top of the stack (ie, not in the next field of another Expect). The top of the stack contains the most specific information. +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + -- During reporting, the goal is ease of manipulation. An ExpectList (during reporting) is (listof Expect). @@ -221,23 +229,23 @@ RExpectList when the most specific information comes last. (expect:proper-pair? x))) (define (es-add-thing ps description transparent? role next) - (if description + (if (and next description) (expect:thing ps description transparent? role next) next)) (define (es-add-message message next) - (if message + (if (and next message) (expect:message message next) next)) (define (es-add-atom atom next) - (expect:atom atom next)) + (and next (expect:atom atom next))) (define (es-add-literal literal next) - (expect:literal literal next)) + (and next (expect:literal literal next))) (define (es-add-proper-pair first-desc next) - (expect:proper-pair first-desc next)) + (and next (expect:proper-pair first-desc next))) #| A FirstDesc is one of diff --git a/racket/collects/syntax/parse/private/runtime-report.rkt b/racket/collects/syntax/parse/private/runtime-report.rkt index f1c66106c1..8029e9f6aa 100644 --- a/racket/collects/syntax/parse/private/runtime-report.rkt +++ b/racket/collects/syntax/parse/private/runtime-report.rkt @@ -292,6 +292,7 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2). (let loop ([es es] [acc null]) (match es ['#f acc] + ['#t acc] [(expect:thing ps desc tr? role rest-es) (cond [(and truncate-opaque? (not tr?)) (loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]