diff --git a/racket/collects/syntax/parse/private/opt.rkt b/racket/collects/syntax/parse/private/opt.rkt index e188508ca9..90d2dbd8cb 100644 --- a/racket/collects/syntax/parse/private/opt.rkt +++ b/racket/collects/syntax/parse/private/opt.rkt @@ -18,18 +18,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 boolean Matrix) -- a submatrix with pair patterns in the first column unfolded +;; - (pk/pair 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 (proper? inner) #:prefab) +(struct pk/pair (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 proper? inner) (sub1 (pk-columns inner))] + [(pk/pair inner) (sub1 (pk-columns inner))] [(pk/and inner) (sub1 (pk-columns inner))])) ;; Can factor pattern P given clauses like @@ -112,14 +112,13 @@ ;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) (define (pattern->partitioner pat1) (match pat1 - [(pat:pair proper? head tail) - (values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?))) + [(pat:pair head tail) + (values (lambda (p) (pat:pair? p)) (lambda (rows) (when DEBUG-OPT-SUCCEED (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) (cond [(> (length rows) 1) - (pk/pair proper? - (optimize-matrix + (pk/pair (optimize-matrix (for/list ([row (in-list rows)]) (let* ([patterns (pk1-patterns row)] [pat1 (car patterns)]) @@ -192,7 +191,7 @@ (andmap pattern-factorable? patterns)] [(pat:or patterns) #f] [(pat:not pattern) #f] ;; FIXME: ? - [(pat:pair _p? head tail) + [(pat:pair head tail) (and (pattern-factorable? head) (pattern-factorable? tail))] [(pat:vector pattern) @@ -268,8 +267,7 @@ [(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 (eq? (pat:pair-proper? a) (pat:pair-proper? b)) - (pattern-equal? (pat:pair-head a) (pat:pair-head b)) + (and (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))] @@ -401,7 +399,7 @@ (cons 'MATCH (map pattern->sexpr pats))] [(pk/same pat inner) (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] - [(pk/pair proper? inner) + [(pk/pair inner) (list 'PAIR (matrix->sexpr inner))] [(pk/and inner) (list 'AND (matrix->sexpr inner))])) @@ -421,10 +419,8 @@ [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] [(pat:datum _as datum) datum] [(? pat:action?) 'ACTION] - [(pat:pair _as '#t head tail) + [(pat:pair _as head tail) (cons (pattern->sexpr head) (pattern->sexpr tail))] - [(pat:pair _as '#f head tail) - (list '~pair (pattern->sexpr head) (pattern->sexpr tail))] [(pat:head _as head tail) (cons (pattern->sexpr head) (pattern->sexpr tail))] [(pat:dots _as (list eh) tail) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index de44de3c79..eb62a70d0e 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -475,7 +475,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 proper? inner)) + [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner)) #'(let-values ([(datum tcx) (if (syntax? x) (values (syntax-e x) x) @@ -487,9 +487,7 @@ Conventions: [tx (cdr datum)] [tpr (ps-add-cdr pr)]) (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) - (let ([es* (if (and 'proper? (null? datum)) - (es-add-proper-pair (first-desc:matrix inner) es) - es)]) + (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)]) (fail (failure pr es*)))))] [(parse:pk (in1 . ins) #s(pk/and inner)) #'(parse:matrix (in1 in1 . ins) inner)])) @@ -610,7 +608,7 @@ Conventions: [cut-prompt fail-to-succeed]) ;; to be safe (parse:S x cx subpattern pr es (fh0 (failure pr0 es0)))))] - [#s(pat:pair proper? head tail) + [#s(pat:pair head tail) #`(let ([datum (if (syntax? x) (syntax-e x) x)] [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?! (if (pair? datum) @@ -621,7 +619,7 @@ Conventions: [tpr (ps-add-cdr pr)]) (parse:S hx hcx head hpr es (parse:S tx cx tail tpr es k))) - (let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair (first-desc:S head) es) es)]) + (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)]) (fail (failure pr es*)))))] [#s(pat:vector subpattern) #`(let ([datum (if (syntax? x) (syntax-e x) x)]) @@ -771,9 +769,9 @@ Conventions: [#s(pat:dots head tail) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) #'#s(pat:dots head tail))] - [#s(pat:pair proper? head-part tail-part) + [#s(pat:pair head-part tail-part) (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) - #'#s(pat:pair proper? head-part tail-part))]))) + #'#s(pat:pair 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. @@ -901,7 +899,7 @@ Conventions: [_ #'(parse:S x cx ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) - #s(pat:pair #t head #s(internal-rest-pattern rest-x rest-cx rest-pr)) + #s(pat:pair 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 57cff901ec..8682f93444 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -22,7 +22,7 @@ A SinglePattern is one of (pat:and (listof SinglePattern)) (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr))) (pat:not SinglePattern) - (pat:pair boolean SinglePattern SinglePattern) + (pat:pair SinglePattern SinglePattern) (pat:vector SinglePattern) (pat:box SinglePattern) (pat:pstruct key SinglePattern) @@ -38,7 +38,7 @@ A ListPattern is a subtype of SinglePattern; one of (pat:datum '()) (pat:action ActionPattern ListPattern) (pat:head HeadPattern ListPattern) - (pat:pair #t SinglePattern ListPattern) + (pat:pair SinglePattern ListPattern) (pat:dots EllipsisHeadPattern ListPattern) |# @@ -53,7 +53,7 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:and (patterns) #:prefab) (define-struct pat:or (attrs patterns attrss) #:prefab) (define-struct pat:not (pattern) #:prefab) -(define-struct pat:pair (proper? head tail) #:prefab) +(define-struct pat:pair (head tail) #:prefab) (define-struct pat:vector (pattern) #:prefab) (define-struct pat:box (pattern) #:prefab) (define-struct pat:pstruct (key pattern) #:prefab) @@ -226,7 +226,7 @@ A RepConstraint is one of (append-iattrs (map pattern-attrs (list a sp)))] [(pat:head headp tailp) (append-iattrs (map pattern-attrs (list headp tailp)))] - [(pat:pair _proper? headp tailp) + [(pat:pair headp tailp) (append-iattrs (map pattern-attrs (list headp tailp)))] [(pat:vector sp) (pattern-attrs sp)] @@ -355,15 +355,12 @@ A RepConstraint is one of (define (action-pattern->single-pattern a) (pat:action a (pat:any))) -(define (proper-list-pattern? p trust-pair?) +(define (proper-list-pattern? p) (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) trust-pair?))) - (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?)))) + (and (pat:pair? p) (proper-list-pattern? (pat:pair-tail p))) + (and (pat:head? p) (proper-list-pattern? (pat:head-tail p))) + (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p))) + (and (pat:action? p) (proper-list-pattern? (pat:action-inner p))))) ;; ---- @@ -474,7 +471,7 @@ A RepConstraint is one of [(pat:datum '()) 'yes] [(pat:action ap lp) (lpat-nullable lp)] [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))] - [(pat:pair '#t sp lp) 'no] + [(pat:pair sp lp) 'no] [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))] ;; For hpat:and, handle the following which are not ListPatterns [(pat:and lps) (3andmap lpat-nullable lps)] diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index f376e34d18..607e74a864 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -592,8 +592,7 @@ (pat:action headp tailp)] [(head-pattern? headp) (pat:head headp tailp)] - [else - (pat:pair (proper-list-pattern? tailp #t) headp tailp)]))] + [else (pat:pair headp tailp)]))] [#(a ...) (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) (pat:vector lp))] @@ -968,7 +967,7 @@ (define (parse-hpat:seq stx list-stx decls) (define pattern (parse-single-pattern list-stx decls)) - (unless (proper-list-pattern? pattern #t) + (unless (proper-list-pattern? pattern) (wrong-syntax stx "expected proper list pattern")) (hpat:seq pattern))