suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: remove unused field from pat:pair, pk/pair

Browse Source
This commit is contained in:
Ryan Culpepper 2016-07-31 22:23:24 -04:00
parent d6a3a22989
commit f968b87385
4 changed files with 29 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
racket/collects/syntax/parse/private/opt.rkt
View File

@ -18,18 +18,18 @@
;; A PK is one of ;; A PK is one of
;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix ;; - (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/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 ;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded
(struct pk1 (patterns k) #:prefab) (struct pk1 (patterns k) #:prefab)
(struct pk/same (pattern inner) #:prefab) (struct pk/same (pattern inner) #:prefab)
(struct pk/pair (proper? inner) #:prefab) (struct pk/pair (inner) #:prefab)
(struct pk/and (inner) #:prefab) (struct pk/and (inner) #:prefab)
(define (pk-columns pk) (define (pk-columns pk)
(match pk (match pk
[(pk1 patterns k) (length patterns)] [(pk1 patterns k) (length patterns)]
[(pk/same p inner) (add1 (pk-columns inner))] [(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))])) [(pk/and inner) (sub1 (pk-columns inner))]))
;; Can factor pattern P given clauses like ;; Can factor pattern P given clauses like
@ -112,14 +112,13 @@
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) ;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
(define (pattern->partitioner pat1) (define (pattern->partitioner pat1)
(match pat1 (match pat1
[(pat:pair proper? head tail) [(pat:pair head tail)
(values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?))) (values (lambda (p) (pat:pair? p))
(lambda (rows) (lambda (rows)
(when DEBUG-OPT-SUCCEED (when DEBUG-OPT-SUCCEED
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1) (cond [(> (length rows) 1)
(pk/pair proper? (pk/pair (optimize-matrix
(optimize-matrix
(for/list ([row (in-list rows)]) (for/list ([row (in-list rows)])
(let* ([patterns (pk1-patterns row)] (let* ([patterns (pk1-patterns row)]
[pat1 (car patterns)]) [pat1 (car patterns)])
@ -192,7 +191,7 @@
(andmap pattern-factorable? patterns)] (andmap pattern-factorable? patterns)]
[(pat:or patterns) #f] [(pat:or patterns) #f]
[(pat:not pattern) #f] ;; FIXME: ? [(pat:not pattern) #f] ;; FIXME: ?
[(pat:pair _p? head tail) [(pat:pair head tail)
(and (pattern-factorable? head) (and (pattern-factorable? head)
(pattern-factorable? tail))] (pattern-factorable? tail))]
[(pat:vector pattern) [(pat:vector pattern)
@ -268,8 +267,7 @@
[(and (pat:not? a) (pat:not? b)) [(and (pat:not? a) (pat:not? b))
(pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))]
[(and (pat:pair? a) (pat:pair? b)) [(and (pat:pair? a) (pat:pair? b))
(and (eq? (pat:pair-proper? a) (pat:pair-proper? b)) (and (pattern-equal? (pat:pair-head a) (pat:pair-head b))
(pattern-equal? (pat:pair-head a) (pat:pair-head b))
(pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))]
[(and (pat:vector? a) (pat:vector? b)) [(and (pat:vector? a) (pat:vector? b))
(pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))]
@ -401,7 +399,7 @@
(cons 'MATCH (map pattern->sexpr pats))] (cons 'MATCH (map pattern->sexpr pats))]
[(pk/same pat inner) [(pk/same pat inner)
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
[(pk/pair proper? inner) [(pk/pair inner)
(list 'PAIR (matrix->sexpr inner))] (list 'PAIR (matrix->sexpr inner))]
[(pk/and inner) [(pk/and inner)
(list 'AND (matrix->sexpr inner))])) (list 'AND (matrix->sexpr inner))]))
@ -421,10 +419,8 @@
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))]
[(pat:datum _as datum) datum] [(pat:datum _as datum) datum]
[(? pat:action?) 'ACTION] [(? pat:action?) 'ACTION]
[(pat:pair _as '#t head tail) [(pat:pair _as head tail)
(cons (pattern->sexpr head) (pattern->sexpr 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) [(pat:head _as head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))] (cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:dots _as (list eh) tail) [(pat:dots _as (list eh) tail)

16
racket/collects/syntax/parse/private/parse.rkt
View File

@ -475,7 +475,7 @@ Conventions:
#'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))] #'(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:pk ((x cx pr es) . ins) #s(pk/same pat1 inner))
#'(parse:S x cx pat1 pr es (parse:matrix ins 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) #'(let-values ([(datum tcx)
(if (syntax? x) (if (syntax? x)
(values (syntax-e x) x) (values (syntax-e x) x)
@ -487,9 +487,7 @@ Conventions:
[tx (cdr datum)] [tx (cdr datum)]
[tpr (ps-add-cdr pr)]) [tpr (ps-add-cdr pr)])
(parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner))
(let ([es* (if (and 'proper? (null? datum)) (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)])
(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:pk (in1 . ins) #s(pk/and inner))
#'(parse:matrix (in1 in1 . ins) inner)])) #'(parse:matrix (in1 in1 . ins) inner)]))
@ -610,7 +608,7 @@ Conventions:
[cut-prompt fail-to-succeed]) ;; to be safe [cut-prompt fail-to-succeed]) ;; to be safe
(parse:S x cx subpattern pr es (parse:S x cx subpattern pr es
(fh0 (failure pr0 es0)))))] (fh0 (failure pr0 es0)))))]
[#s(pat:pair proper? head tail) [#s(pat:pair head tail)
#`(let ([datum (if (syntax? x) (syntax-e x) x)] #`(let ([datum (if (syntax? x) (syntax-e x) x)]
[cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?! [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?!
(if (pair? datum) (if (pair? datum)
@ -621,7 +619,7 @@ Conventions:
[tpr (ps-add-cdr pr)]) [tpr (ps-add-cdr pr)])
(parse:S hx hcx head hpr es (parse:S hx hcx head hpr es
(parse:S tx cx tail tpr es k))) (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*)))))] (fail (failure pr es*)))))]
[#s(pat:vector subpattern) [#s(pat:vector subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)]) #`(let ([datum (if (syntax? x) (syntax-e x) x)])
@ -771,9 +769,9 @@ Conventions:
[#s(pat:dots head tail) [#s(pat:dots head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:dots head tail))] #'#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)]) (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) ;; (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. ;; In k: rest, rest-pr, attrs(H-pattern) are bound.
@ -901,7 +899,7 @@ Conventions:
[_ [_
#'(parse:S x cx #'(parse:S x cx
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) ;; 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)])])) pr es k)])]))
;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] ;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans]

23
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -22,7 +22,7 @@ A SinglePattern is one of
(pat:and (listof SinglePattern)) (pat:and (listof SinglePattern))
(pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr))) (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
(pat:not SinglePattern) (pat:not SinglePattern)
(pat:pair boolean SinglePattern SinglePattern) (pat:pair SinglePattern SinglePattern)
(pat:vector SinglePattern) (pat:vector SinglePattern)
(pat:box SinglePattern) (pat:box SinglePattern)
(pat:pstruct key SinglePattern) (pat:pstruct key SinglePattern)
@ -38,7 +38,7 @@ A ListPattern is a subtype of SinglePattern; one of
(pat:datum '()) (pat:datum '())
(pat:action ActionPattern ListPattern) (pat:action ActionPattern ListPattern)
(pat:head HeadPattern ListPattern) (pat:head HeadPattern ListPattern)
(pat:pair #t SinglePattern ListPattern) (pat:pair SinglePattern ListPattern)
(pat:dots EllipsisHeadPattern 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:and (patterns) #:prefab)
(define-struct pat:or (attrs patterns attrss) #:prefab) (define-struct pat:or (attrs patterns attrss) #:prefab)
(define-struct pat:not (pattern) #: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:vector (pattern) #:prefab)
(define-struct pat:box (pattern) #:prefab) (define-struct pat:box (pattern) #:prefab)
(define-struct pat:pstruct (key 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)))] (append-iattrs (map pattern-attrs (list a sp)))]
[(pat:head headp tailp) [(pat:head headp tailp)
(append-iattrs (map pattern-attrs (list 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)))] (append-iattrs (map pattern-attrs (list headp tailp)))]
[(pat:vector sp) [(pat:vector sp)
(pattern-attrs sp)] (pattern-attrs sp)]
@ -355,15 +355,12 @@ A RepConstraint is one of
(define (action-pattern->single-pattern a) (define (action-pattern->single-pattern a)
(pat:action a (pat:any))) (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) '())) (or (and (pat:datum? p) (eq? (pat:datum-datum p) '()))
(and (pat:pair? p) (and (pat:pair? p) (proper-list-pattern? (pat:pair-tail p)))
(if trust-pair? (and (pat:head? p) (proper-list-pattern? (pat:head-tail p)))
(pat:pair-proper? p) (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p)))
(proper-list-pattern? (pat:pair-tail p) trust-pair?))) (and (pat:action? p) (proper-list-pattern? (pat:action-inner 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?))))
;; ---- ;; ----
@ -474,7 +471,7 @@ A RepConstraint is one of
[(pat:datum '()) 'yes] [(pat:datum '()) 'yes]
[(pat:action ap lp) (lpat-nullable lp)] [(pat:action ap lp) (lpat-nullable lp)]
[(pat:head hp lp) (3and (hpat-nullable hp) (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))] [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))]
;; For hpat:and, handle the following which are not ListPatterns ;; For hpat:and, handle the following which are not ListPatterns
[(pat:and lps) (3andmap lpat-nullable lps)] [(pat:and lps) (3andmap lpat-nullable lps)]

5
racket/collects/syntax/parse/private/rep.rkt
View File

@ -592,8 +592,7 @@
(pat:action headp tailp)] (pat:action headp tailp)]
[(head-pattern? headp) [(head-pattern? headp)
(pat:head headp tailp)] (pat:head headp tailp)]
[else [else (pat:pair headp tailp)]))]
(pat:pair (proper-list-pattern? tailp #t) headp tailp)]))]
[#(a ...) [#(a ...)
(let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
(pat:vector lp))] (pat:vector lp))]
@ -968,7 +967,7 @@
(define (parse-hpat:seq stx list-stx decls) (define (parse-hpat:seq stx list-stx decls)
(define pattern (parse-single-pattern 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")) (wrong-syntax stx "expected proper list pattern"))
(hpat:seq pattern)) (hpat:seq pattern))