diff --git a/collects/syntax/parse/experimental/splicing.rkt b/collects/syntax/parse/experimental/splicing.rkt index b8dcc3db45..44276b6b3c 100644 --- a/collects/syntax/parse/experimental/splicing.rkt +++ b/collects/syntax/parse/experimental/splicing.rkt @@ -40,8 +40,8 @@ (cdr result)))) ((error) (let ([es - (list* (cons (expect:thing (get-description param ...) #f) stx) - (cons (expect:message (cadr result)) (caddr result)) + (list* (expect:message (cadr result)) + (expect:thing (get-description param ...) #f) es)]) (fh (failure pr es)))))))))) (define-syntax name diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 006932a23c..bedfb85891 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -103,7 +103,7 @@ Conventions: (syntax-parameterize ((this-context-syntax (syntax-rules () [(tbs) (ps-context-syntax pr)]))) - (let ([es (cons (cons (expect:thing description 'transparent?) x) es)] + (let ([es (cons (expect:thing description 'transparent?) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (with ([fail-handler fh0] [cut-prompt cp0]) @@ -288,14 +288,14 @@ Conventions: #`(let ([d (if (syntax? x) (syntax-e x) x)]) (if (equal? d (quote datum)) k - (fail (failure pr (cons (cons (expect:atom 'datum) x) es)))))] + (fail (failure pr (cons(expect:atom 'datum) es)))))] [#s(pat:literal attrs literal input-phase lit-phase) #`(if (and (identifier? x) (free-identifier=?/phases x input-phase (quote-syntax literal) lit-phase)) k - (fail (failure pr (cons (cons (expect:literal (quote-syntax literal)) x) es))))] + (fail (failure pr (cons(expect:literal (quote-syntax literal)) es))))] [#s(pat:action attrs action subpattern) #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] [#s(pat:head attrs head tail) @@ -370,7 +370,7 @@ Conventions: (parse:S datum scx subpattern pr es k)) (fail (failure pr es))))] [#s(pat:describe attrs description transparent? pattern) - #`(let ([es (cons (cons (expect:thing description transparent?) x) es)] + #`(let ([es (cons (expect:thing description transparent?) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (parse:S x cx pattern pr es k))] [#s(pat:delimit attrs pattern) @@ -396,7 +396,7 @@ Conventions: ;; NOTE: predicate must not assume x (ie, this-syntax) is stx #'(if (app-argu predicate x argu) (let-attributes (name-attr ...) k) - (let ([es (cons (cons (expect:thing 'description #t) x) es)]) + (let ([es (cons (expect:thing 'description #t) es)]) (fail (failure pr es)))))])])) ;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans] @@ -437,9 +437,7 @@ Conventions: (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)] - [es* (cons (cons (expect:message message) - (if (syntax? c) c x)) - es)]) + [es* (cons (expect:message message) es)]) (fail (failure pr* es*))) k))] [#s(action:parse _ pattern expr) @@ -492,7 +490,7 @@ Conventions: [(parse:H x cx rest-x rest-cx rest-pr head pr es k) (syntax-case #'head () [#s(hpat:describe _ description transparent? pattern) - #`(let ([es (cons (cons (expect:thing description transparent?) x) es)]) + #`(let ([es (cons (expect:thing description transparent?) es)]) (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))] [#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit?) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] @@ -669,7 +667,7 @@ Conventions: head es loop-k) ...) (cond [(< rel-rep (rep:min-number rel-repc)) - (let ([es (cons (cons (expectation-of-reps/too-few rel-rep rel-repc) dx) es)]) + (let ([es (cons (expectation-of-reps/too-few rel-rep rel-repc) es)]) (fail (failure loop-pr es)))] ... [else @@ -714,7 +712,7 @@ Conventions: [_ #`(parse:H x cx x* cx* pr* head pr es (if (< rep (rep:max-number repc)) (let ([rep (add1 rep)]) k*) - (let ([es (cons (cons (expectation-of-reps/too-many rep repc) x*) es)]) + (let ([es (cons (expectation-of-reps/too-many rep repc) es)]) (fail (failure pr* es)))))]))])) ;; (rep:initial-value RepConstraint) : expr diff --git a/collects/syntax/parse/private/runtime-failure.rkt b/collects/syntax/parse/private/runtime-failure.rkt index 2f33ee7696..78f0b042bd 100644 --- a/collects/syntax/parse/private/runtime-failure.rkt +++ b/collects/syntax/parse/private/runtime-failure.rkt @@ -29,10 +29,7 @@ ;; FIXME: add phase to expect:literal #| -An ExpectStack is (listof (cons Expect syntax)) - -FIXME: (cons Expect syntax) -> struct instead? -FIXME: replace syntax with progress (better cdr handling) +An ExpectStack is (listof Expect) An Expect is one of - (make-expect:thing string boolean) @@ -85,21 +82,21 @@ The *-marked variants can only occur at the top of the stack. (let loop ([es es]) (match es ['() '()] - [(cons (cons (expect:thing description '#f) stx) rest-es) + [(cons (expect:thing description '#f) rest-es) ;; Tricky! If multiple opaque frames, multiple "returns", ;; but innermost one called first, so jumps past the rest. (return (cons (car es) (loop rest-es)))] - [(cons expect+stx rest-es) - (cons expect+stx (loop rest-es))])))) + [(cons expect rest-es) + (cons expect (loop rest-es))])))) ;; filter-expectstack : ExpectStack -> ExpectStack ;; Eliminates missing (ie, #f) messages and descriptions (define (filter-expectstack es) (filter (lambda (expect) (match expect - [(cons (expect:thing '#f _) _) + [(expect:thing '#f _) #f] - [(cons (expect:message '#f) _) + [(expect:message '#f) #f] [_ #t])) es)) @@ -139,13 +136,10 @@ So we go with option 2. (define (simplify/check-leafs ress) (let ([ress (simplify ress)]) (cond [(andmap singleton? ress) - ;; Assume the syntax parts are the same - (let* ([frames (map car ress)] - [frame-stx (cdr (car frames))]) - (list (list (cons (if (singleton? frames) - (car (car frames)) - (expect:disj (map car frames))) - frame-stx))))] + (let* ([frames (map car ress)]) + (list (list (if (singleton? frames) + (car frames) + (expect:disj frames)))))] [else ress]))) ;; singleton? : list -> boolean (define (singleton? res) diff --git a/collects/syntax/parse/private/runtime-progress.rkt b/collects/syntax/parse/private/runtime-progress.rkt index 726242ed17..d7a1789f8e 100644 --- a/collects/syntax/parse/private/runtime-progress.rkt +++ b/collects/syntax/parse/private/runtime-progress.rkt @@ -96,15 +96,16 @@ Interpretation: Inner PS structures are applied first. (stx-cdr stx))] [(cons 'post parent) (interp parent)])) - (match ps - [(cons (? syntax? stx) _) - (values stx 0)] - [(cons 'car parent) - (values (interp ps) 0)] - [(cons (? exact-positive-integer? n) parent) - (values (interp parent) n)] - [(cons 'post parent) - (ps->stx+index parent)])) + (let ([ps (ps-truncate-opaque ps)]) + (match ps + [(cons (? syntax? stx) _) + (values stx 0)] + [(cons 'car parent) + (values (interp ps) 0)] + [(cons (? exact-positive-integer? n) parent) + (values (interp parent) n)] + [(cons 'post parent) + (ps->stx+index parent)]))) ;; ps-difference : PS PS -> nat ;; Returns N s.t. B = (ps-add-cdr^N A) diff --git a/collects/syntax/parse/private/runtime-report.rkt b/collects/syntax/parse/private/runtime-report.rkt index 73801d814f..f819480239 100644 --- a/collects/syntax/parse/private/runtime-report.rkt +++ b/collects/syntax/parse/private/runtime-report.rkt @@ -57,12 +57,11 @@ complicated. ;; report/expectstack : ExpectStack syntax nat -> Report (define (report/expectstack es stx index) - (let ([top-frame (and (pair? es) (car es))]) - (cond [(not top-frame) + (let ([frame-expect (and (pair? es) (car es))]) + (cond [(not frame-expect) (report "bad syntax" #f)] [else - (let ([frame-expect (and top-frame (car top-frame))] - [frame-stx + (let ([frame-stx (let-values ([(x cx) (stx-list-drop/cx stx stx index)]) (datum->syntax cx x cx))]) (cond [(equal? frame-expect (expect:atom '()))