From 2057b51f21e38cfd7cbfc4e481a874e2bc0c12da Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 30 Jul 2013 19:55:04 -0400 Subject: [PATCH] syntax/parse: add "expected more terms" message Only for proper list patterns; otherwise, "more terms" might be mischaracterization. --- .../racket-test/tests/stxparse/test.rkt | 2 +- racket/collects/syntax/parse/private/opt.rkt | 20 ++++++++++--------- .../collects/syntax/parse/private/parse.rkt | 17 +++++++++------- .../syntax/parse/private/rep-patterns.rkt | 20 +++++++++++++++---- racket/collects/syntax/parse/private/rep.rkt | 18 ++--------------- .../syntax/parse/private/runtime-progress.rkt | 13 ++++++++++-- .../syntax/parse/private/runtime-report.rkt | 8 ++++++-- 7 files changed, 57 insertions(+), 41 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-pkgs/racket-test/tests/stxparse/test.rkt index e28095e9c5..29c515349a 100644 --- a/pkgs/racket-pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/stxparse/test.rkt @@ -44,7 +44,7 @@ #:pre [()] #:post [x:two]) ;; check if wildcard, no attr bound -(terx (1) _:two "expected two") +(terx (1) _:two "expected more terms") ;(terx (1 2) _:one "expected one") (terx (1 (2 3)) (_:one _:two) "expected one") (terx ((1) 2) (_:one _:two) "expected two") diff --git a/racket/collects/syntax/parse/private/opt.rkt b/racket/collects/syntax/parse/private/opt.rkt index 410f865647..72bcee972f 100644 --- a/racket/collects/syntax/parse/private/opt.rkt +++ b/racket/collects/syntax/parse/private/opt.rkt @@ -24,18 +24,18 @@ ;; A PK is one of ;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix ;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out -;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded +;; - (pk/pair boolean Matrix) -- a submatrix with pair patterns in the first column unfolded ;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded (struct pk1 (patterns k) #:prefab) (struct pk/same (pattern inner) #:prefab) -(struct pk/pair (inner) #:prefab) +(struct pk/pair (proper? inner) #:prefab) (struct pk/and (inner) #:prefab) (define (pk-columns pk) (match pk [(pk1 patterns k) (length patterns)] [(pk/same p inner) (add1 (pk-columns inner))] - [(pk/pair inner) (sub1 (pk-columns inner))] + [(pk/pair proper? inner) (sub1 (pk-columns inner))] [(pk/and inner) (sub1 (pk-columns inner))])) ;; Can factor pattern P given clauses like @@ -113,13 +113,14 @@ ;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) (define (pattern->partitioner pat1) (match pat1 - [(pat:pair attrs head tail) - (values pat:pair? + [(pat:pair proper? attrs head tail) + (values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?))) (lambda (rows) (cond [(> (length rows) 1) (when DEBUG-OPT-SUCCEED (eprintf "** pairs (~s)\n" (length rows))) - (pk/pair (optimize-matrix + (pk/pair proper? + (optimize-matrix (for/list ([row (in-list rows)]) (let* ([patterns (pk1-patterns row)] [pat1 (car patterns)]) @@ -191,7 +192,7 @@ (andmap pattern-factorable? patterns)] [(pat:or _as patterns) #f] [(pat:not _as pattern) #f] ;; FIXME: ? - [(pat:pair _as head tail) + [(pat:pair _as _p? head tail) (and (pattern-factorable? head) (pattern-factorable? tail))] [(pat:vector _as pattern) @@ -263,7 +264,8 @@ [(and (pat:not? a) (pat:not? b)) (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] [(and (pat:pair? a) (pat:pair? b)) - (and (pattern-equal? (pat:pair-head a) (pat:pair-head b)) + (and (eq? (pat:pair-proper? a) (pat:pair-proper? b)) + (pattern-equal? (pat:pair-head a) (pat:pair-head b)) (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] [(and (pat:vector? a) (pat:vector? b)) (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] @@ -402,7 +404,7 @@ [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] [(pat:datum _as datum) datum] [(? pat:action?) 'ACTION] - [(pat:pair _as head tail) + [(pat:pair _as _p? head tail) (cons (pattern->sexpr head) (pattern->sexpr tail))] [(pat:head _as head tail) (cons (pattern->sexpr head) (pattern->sexpr tail))] diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 87364090e3..4760287a92 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -449,7 +449,7 @@ Conventions: #'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))] [(parse:pk ((x cx pr es) . ins) #s(pk/same pat1 inner)) #'(parse:S x cx pat1 pr es (parse:matrix ins inner))] - [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner)) + [(parse:pk ((x cx pr es) . ins) #s(pk/pair proper? inner)) #'(let-values ([(datum tcx) (if (syntax? x) (values (syntax-e x) x) @@ -461,7 +461,8 @@ Conventions: [tx (cdr datum)] [tpr (ps-add-cdr pr)]) (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) - (fail (failure pr es))))] + (let ([es* (if (and 'proper? (null? datum)) (es-add-proper es) es)]) + (fail (failure pr es*)))))] [(parse:pk (in1 . ins) #s(pk/and inner)) #'(parse:matrix (in1 in1 . ins) inner)])) @@ -568,7 +569,7 @@ Conventions: [cut-prompt fail-to-succeed]) ;; to be safe (parse:S x cx subpattern pr es (fh0 (failure pr0 es0)))))] - [#s(pat:pair _attrs head tail) + [#s(pat:pair _attrs proper? head tail) #`(let-values ([(datum cx) (if (syntax? x) (values (syntax-e x) x) @@ -581,7 +582,8 @@ Conventions: [tpr (ps-add-cdr pr)]) (parse:S hx hcx head hpr es (parse:S tx cx tail tpr es k))) - (fail (failure pr es))))] + (let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair es) es)]) + (fail (failure pr es*)))))] [#s(pat:vector _attrs subpattern) #`(let ([datum (if (syntax? x) (syntax-e x) x)]) (if (vector? datum) @@ -717,9 +719,9 @@ Conventions: [#s(pat:dots attrs head tail) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) #'#s(pat:dots attrs head tail))] - [#s(pat:pair attrs head-part tail-part) + [#s(pat:pair attrs proper? head-part tail-part) (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) - #'#s(pat:pair attrs head-part tail-part))]))) + #'#s(pat:pair attrs proper? head-part tail-part))]))) ;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k) ;; In k: rest, rest-pr, attrs(H-pattern) are bound. @@ -857,7 +859,8 @@ Conventions: [_ (with-syntax ([attrs (pattern-attrs (wash #'head))]) #'(parse:S x cx - #s(pat:pair attrs head #s(internal-rest-pattern rest-x rest-cx rest-pr)) + ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) + #s(pat:pair attrs #t head #s(internal-rest-pattern rest-x rest-cx rest-pr)) pr es k))])])) ;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index c9a725a66c..06f71564dd 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -31,7 +31,7 @@ A SinglePattern is one of (pat:and Base (listof SinglePattern)) (pat:or Base (listof SinglePattern)) (pat:not Base SinglePattern) - (pat:pair Base SinglePattern SinglePattern) + (pat:pair Base boolean SinglePattern SinglePattern) (pat:vector Base SinglePattern) (pat:box Base SinglePattern) (pat:pstruct Base key SinglePattern) @@ -46,7 +46,7 @@ A ListPattern is a subtype of SinglePattern; one of (pat:datum Base '()) (pat:action Base ActionPattern ListPattern) (pat:head Base HeadPattern ListPattern) - (pat:pair Base SinglePattern ListPattern) + (pat:pair Base #t SinglePattern ListPattern) (pat:dots Base EllipsisHeadPattern SinglePattern) |# @@ -60,7 +60,7 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:and (attrs patterns) #:prefab) (define-struct pat:or (attrs patterns) #:prefab) (define-struct pat:not (attrs pattern) #:prefab) -(define-struct pat:pair (attrs head tail) #:prefab) +(define-struct pat:pair (attrs proper? head tail) #:prefab) (define-struct pat:vector (attrs pattern) #:prefab) (define-struct pat:box (attrs pattern) #:prefab) (define-struct pat:pstruct (attrs key pattern) #:prefab) @@ -268,7 +268,9 @@ A SideClause is one of (make pat:head attrs headp tailp))) (define (create-pat:pair headp tailp) - (make pat:pair (append-iattrs (map pattern-attrs (list headp tailp))) headp tailp)) + (let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))] + [proper? (proper-list-pattern? tailp #t)]) + (make pat:pair attrs proper? headp tailp))) (define (create-pat:vector pattern) (make pat:vector (pattern-attrs pattern) pattern)) @@ -412,3 +414,13 @@ A SideClause is one of (define (action-pattern->single-pattern gp) (create-pat:action gp (create-pat:any))) + +(define (proper-list-pattern? p trust-pair?) + (or (and (pat:datum? p) (eq? (pat:datum-datum p) '())) + (and (pat:pair? p) + (if trust-pair? + (pat:pair-proper? p) + (proper-list-pattern? (pat:pair-tail p)))) + (and (pat:head? p) (proper-list-pattern? (pat:head-tail p) trust-pair?)) + (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p) trust-pair?)) + (and (pat:action? p) (proper-list-pattern? (pat:action-inner p) trust-pair?)))) diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index 53ae5bffa7..adc87ea889 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -911,7 +911,8 @@ (define (parse-hpat:seq stx list-stx decls) (define pattern (parse-single-pattern list-stx decls)) - (check-list-pattern pattern stx) + (unless (proper-list-pattern? pattern #t) + (wrong-syntax stx "expected proper list pattern")) (create-hpat:seq pattern)) (define (parse-cdr-patterns stx decls allow-head? allow-action?) @@ -1014,21 +1015,6 @@ [(_ pattern) (parse-single-pattern #'pattern decls)])) -(define (check-list-pattern pattern stx) - (match pattern - [(pat:datum _base '()) - #t] - [(pat:head _base _head tail) - (check-list-pattern tail stx)] - [(pat:action _base _action tail) - (check-list-pattern tail stx)] - [(pat:dots _base _head tail) - (check-list-pattern tail stx)] - [(pat:pair _base _head tail) - (check-list-pattern tail stx)] - [_ - (wrong-syntax stx "expected proper list pattern")])) - (define (parse-hpat:optional stx decls) (define-values (head-stx head iattrs _name _tmm defaults) (parse*-optional-pattern stx decls h-optional-directive-table)) diff --git a/racket/collects/syntax/parse/private/runtime-progress.rkt b/racket/collects/syntax/parse/private/runtime-progress.rkt index 5faf58f33c..edbe845a1e 100644 --- a/racket/collects/syntax/parse/private/runtime-progress.rkt +++ b/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -22,11 +22,13 @@ (struct-out expect:literal) (struct-out expect:message) (struct-out expect:disj) + (struct-out expect:proper-pair) es-add-thing es-add-message es-add-atom - es-add-literal) + es-add-literal + es-add-proper-pair) ;; FIXME: add phase to expect:literal @@ -143,6 +145,7 @@ An ExpectStack (during parsing) is one of * (make-expect:message string ExpectStack) * (make-expect:atom atom ExpectStack) * (make-expect:literal identifier ExpectStack) + * (make-expect:proper-pair ExpectStack) The *-marked variants can only occur at the top of the stack. @@ -156,6 +159,7 @@ An Expect is one of * (expect:message string _) * (expect:atom atom _) * (expect:literal identifier _) + * (expect:proper-pair _) - (expect:disj (non-empty-listof Expect) _) That is, next link always ignored (replace with #f for sake of equal? cmp) @@ -168,13 +172,15 @@ Goal during reporting is ease of manipulation. (struct expect:atom (atom next) #:prefab) (struct expect:literal (literal next) #:prefab) (struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (next) #:prefab) (define (expect? x) (or (expect:thing? x) (expect:message? x) (expect:atom? x) (expect:literal? x) - (expect:disj? x))) + (expect:disj? x) + (expect:proper-pair? x))) (define (es-add-thing ps description transparent? role next) (if description @@ -191,3 +197,6 @@ Goal during reporting is ease of manipulation. (define (es-add-literal literal next) (expect:literal literal next)) + +(define (es-add-proper-pair next) + (expect:proper-pair next)) diff --git a/racket/collects/syntax/parse/private/runtime-report.rkt b/racket/collects/syntax/parse/private/runtime-report.rkt index 1e11438033..1b84b860a4 100644 --- a/racket/collects/syntax/parse/private/runtime-report.rkt +++ b/racket/collects/syntax/parse/private/runtime-report.rkt @@ -131,7 +131,9 @@ complicated. [(expect:literal literal _) (format "expected the identifier `~s'" (syntax-e literal))] [(expect:message message _) - (format "~a" message)])) + (format "~a" message)] + [(expect:proper-pair _) + "expected more terms"])) ;; == Do Report == @@ -201,7 +203,9 @@ complicated. [(expect:atom atom rest-es) (cons (expect:atom atom #f) (loop rest-es))] [(expect:literal literal rest-es) - (cons (expect:literal literal #f) (loop rest-es))])))) + (cons (expect:literal literal #f) (loop rest-es))] + [(expect:proper-pair rest-es) + (cons (expect:proper-pair #f) (loop rest-es))])))) #| Simplification dilemma