split out pattern optimization code
This commit is contained in:
Ryan Culpepper
parent
ae63f01cc7
commit
ab9207dbc7
410
collects/syntax/parse/private/opt.rkt
Normal file
410
collects/syntax/parse/private/opt.rkt
Normal file
|
|
@ -0,0 +1,410 @@
|
|||
#lang racket/base
|
||||
(require syntax/stx
|
||||
syntax/private/id-table
|
||||
syntax/keyword
|
||||
racket/syntax
|
||||
racket/pretty
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
"minimatch.rkt"
|
||||
"rep-attrs.rkt"
|
||||
"rep-data.rkt"
|
||||
"rep-patterns.rkt"
|
||||
"rep.rkt"
|
||||
"kws.rkt")
|
||||
(provide (struct-out pk1)
|
||||
(rename-out [optimize-matrix0 optimize-matrix]))
|
||||
|
||||
;; controls debugging output for optimization successes and failures
|
||||
(define DEBUG-OPT-SUCCEED #f)
|
||||
(define DEBUG-OPT-FAIL #f)
|
||||
|
||||
;; ----
|
||||
|
||||
;; A Matrix is a (listof PK) where each PK has same number of columns
|
||||
;; 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/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/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/and inner) (sub1 (pk-columns inner))]))
|
||||
|
||||
;; Can factor pattern P given clauses like
|
||||
;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
|
||||
;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ]
|
||||
; [ P PN ... | eN] [ | [PN ... | eN] ]
|
||||
;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking)
|
||||
|
||||
;; Can unfold pair patterns as follows:
|
||||
;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
|
||||
;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ]
|
||||
;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
|
||||
|
||||
;; Can unfold ~and patterns similarly; ~and patterns can hide
|
||||
;; factoring opportunities.
|
||||
|
||||
;; ----
|
||||
|
||||
(define (optimize-matrix0 rows)
|
||||
(define result (optimize-matrix rows))
|
||||
#|
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(let ([sexpr (matrix->sexpr result)])
|
||||
(unless (equal? (car sexpr) 'MATCH)
|
||||
(eprintf "%% optimized matrix (~s):\n" (length rows))
|
||||
(pretty-write (matrix->sexpr result) (current-error-port)))))
|
||||
|#
|
||||
result)
|
||||
|
||||
;; optimize-matrix : (listof pk1) -> Matrix
|
||||
(define (optimize-matrix rows)
|
||||
(cond [(null? rows) null]
|
||||
[(null? (cdr rows)) rows] ;; no opportunities for 1 row
|
||||
[(null? (pk1-patterns (car rows))) rows]
|
||||
[else
|
||||
;; first unfold and-patterns
|
||||
(let-values ([(col1 col2)
|
||||
(for/lists (col1 col2) ([row (in-list rows)])
|
||||
(unfold-and (car (pk1-patterns row)) null))])
|
||||
(cond [(ormap pair? col2)
|
||||
(list
|
||||
(pk/and
|
||||
(optimize-matrix*
|
||||
(for/list ([row (in-list rows)]
|
||||
[col1 (in-list col1)]
|
||||
[col2 (in-list col2)])
|
||||
(pk1 (list* col1
|
||||
(make-and-pattern col2)
|
||||
(cdr (pk1-patterns row)))
|
||||
(pk1-k row))))))]
|
||||
[else (optimize-matrix* rows)]))]))
|
||||
|
||||
;; optimize-matrix* : (listof pk1) -> Matrix
|
||||
;; The matrix is nonempty, and first column has no unfoldable pat:and.
|
||||
;; Split into submatrixes (sequences of rows) starting with similar patterns,
|
||||
;; handle according to similarity, then recursively optimize submatrixes.
|
||||
(define (optimize-matrix* rows)
|
||||
(define row1 (car rows))
|
||||
(define pat1 (car (pk1-patterns row1)))
|
||||
(define k1 (pk1-k row1))
|
||||
;; Now accumulate rows starting with patterns like pat1
|
||||
(define-values (like? combine) (pattern->partitioner pat1))
|
||||
(let loop ([rows (cdr rows)] [rrows (list row1)])
|
||||
(cond [(null? rows)
|
||||
(cons (combine (reverse rrows)) null)]
|
||||
[else
|
||||
(define row1 (car rows))
|
||||
(define pat1 (car (pk1-patterns row1)))
|
||||
(cond [(like? pat1)
|
||||
(loop (cdr rows) (cons row1 rrows))]
|
||||
[else
|
||||
(cons (combine (reverse rrows))
|
||||
(optimize-matrix* rows))])])))
|
||||
|
||||
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
|
||||
(define (pattern->partitioner pat1)
|
||||
(match pat1
|
||||
[(pat:pair attrs head tail)
|
||||
(values pat:pair?
|
||||
(lambda (rows)
|
||||
(cond [(> (length rows) 1)
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(eprintf "** pairs (~s)\n" (length rows)))
|
||||
(pk/pair (optimize-matrix
|
||||
(for/list ([row (in-list rows)])
|
||||
(let* ([patterns (pk1-patterns row)]
|
||||
[pat1 (car patterns)])
|
||||
(pk1 (list* (pat:pair-head pat1)
|
||||
(pat:pair-tail pat1)
|
||||
(cdr patterns))
|
||||
(pk1-k row))))))]
|
||||
[else (car rows)])))]
|
||||
[(? pattern-factorable?)
|
||||
(values (lambda (pat2) (pattern-equal? pat1 pat2))
|
||||
(lambda (rows)
|
||||
(cond [(> (length rows) 1)
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(eprintf "** factored(~s): ~e\n" (length rows) (syntax->datum #`#,pat1)))
|
||||
(pk/same pat1
|
||||
(optimize-matrix
|
||||
(for/list ([row (in-list rows)])
|
||||
(pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
|
||||
[else (car rows)])))]
|
||||
[_
|
||||
(values (lambda (pat2)
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (pattern-equal? pat1 pat2)
|
||||
(eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2))))
|
||||
#f)
|
||||
(lambda (rows)
|
||||
;; (length rows) = 1
|
||||
(car rows)))]))
|
||||
|
||||
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
|
||||
(define (unfold-and p onto)
|
||||
(match p
|
||||
[(pat:and _as subpatterns)
|
||||
;; pat:and is worth unfolding if first subpattern is not pat:action
|
||||
;; if first subpattern is also pat:and, keep unfolding
|
||||
(let* ([first-sub (car subpatterns)]
|
||||
[rest-subs (cdr subpatterns)])
|
||||
(cond [(not (pat:action? first-sub))
|
||||
(when #f ;; DEBUG-OPT-SUCCEED
|
||||
(eprintf ">> unfolding: ~e\n" p))
|
||||
(unfold-and first-sub (*append rest-subs onto))]
|
||||
[else (values p onto)]))]
|
||||
[_ (values p onto)]))
|
||||
|
||||
(define (pattern-factorable? p)
|
||||
;; Can factor out p if p can succeed at most once, does not cut
|
||||
;; - if p can succeed multiple times, then factoring changes success order
|
||||
;; - if p can cut, then factoring changes which choice points are discarded (too few)
|
||||
(match p
|
||||
[(pat:any _as) #t]
|
||||
[(pat:var _as _n _p _argu _na _ac commit? _r)
|
||||
;; commit? implies delimit-cut
|
||||
commit?]
|
||||
[(? pat:integrated?) #t]
|
||||
[(pat:literal _as _lit _ip _lp) #t]
|
||||
[(pat:datum _as _datum) #t]
|
||||
[(pat:action _as _act _pat) #f]
|
||||
[(pat:head _as head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:dots _as heads tail)
|
||||
;; Conservative approximation for common case: one head pattern
|
||||
;; In general, check if heads don't overlap, don't overlap with tail.
|
||||
(and (= (length heads) 1)
|
||||
(let ([head (car heads)])
|
||||
(and (pattern-factorable? head)))
|
||||
(equal? tail (create-pat:datum '())))]
|
||||
[(pat:and _as patterns)
|
||||
(andmap pattern-factorable? patterns)]
|
||||
[(pat:or _as patterns) #f]
|
||||
[(pat:not _as pattern) #f] ;; FIXME: ?
|
||||
[(pat:pair _as head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:vector _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:box _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:pstruct _as key pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:describe _as pattern _desc _trans _role)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:delimit _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:commit _as pattern) #t]
|
||||
[(? pat:reflect?) #f]
|
||||
[(pat:post _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
;; ----
|
||||
[(hpat:var _as _name _parser _argu _na _ac commit? _role)
|
||||
commit?]
|
||||
[(hpat:seq _as inner)
|
||||
(pattern-factorable? inner)]
|
||||
[(hpat:commit _as inner) #t]
|
||||
;; ----
|
||||
[(ehpat _as head repc)
|
||||
(and (equal? repc #f)
|
||||
(pattern-factorable? head))]
|
||||
;; ----
|
||||
[else #f]))
|
||||
|
||||
(define (subpatterns-equal? as bs)
|
||||
(and (= (length as) (length bs))
|
||||
(for/and ([a (in-list as)]
|
||||
[b (in-list bs)])
|
||||
(pattern-equal? a b))))
|
||||
|
||||
(define (pattern-equal? a b)
|
||||
(define result
|
||||
(cond [(and (pat:any? a) (pat:any? b)) #t]
|
||||
[(and (pat:var? a) (pat:var? b))
|
||||
(and (free-id/f-equal? (pat:var-parser a) (pat:var-parser b))
|
||||
(equal-iattrs? (pat:var-attrs a) (pat:var-attrs b))
|
||||
(equal-argu? (pat:var-argu a) (pat:var-argu b))
|
||||
(expr-equal? (pat:var-role a) (pat:var-role b)))]
|
||||
[(and (pat:integrated? a) (pat:integrated? b))
|
||||
(and (free-identifier=? (pat:integrated-predicate a)
|
||||
(pat:integrated-predicate b))
|
||||
(equal-iattrs? (pat:integrated-attrs a)
|
||||
(pat:integrated-attrs b))
|
||||
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
|
||||
[(and (pat:literal? a) (pat:literal? b))
|
||||
;; literals are hard to compare, so compare gensyms attached to
|
||||
;; literal ids (see rep.rkt) instead
|
||||
(let ([ka (syntax-property (pat:literal-id a) 'literal)]
|
||||
[kb (syntax-property (pat:literal-id b) 'literal)])
|
||||
(and ka kb (eq? ka kb)))]
|
||||
[(and (pat:datum? a) (pat:datum? b))
|
||||
(equal? (pat:datum-datum a)
|
||||
(pat:datum-datum b))]
|
||||
[(and (pat:head? a) (pat:head? b))
|
||||
(and (pattern-equal? (pat:head-head a) (pat:head-head b))
|
||||
(pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
|
||||
[(and (pat:dots? a) (pat:dots? b))
|
||||
(and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
|
||||
(pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
|
||||
[(and (pat:and? a) (pat:and? b))
|
||||
(subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
|
||||
[(and (pat:or? a) (pat:or? b))
|
||||
(subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
|
||||
[(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))
|
||||
(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))]
|
||||
[(and (pat:box? a) (pat:box? b))
|
||||
(pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
|
||||
[(and (pat:pstruct? a) (pat:pstruct? b))
|
||||
(and (equal? (pat:pstruct-key a)
|
||||
(pat:pstruct-key b))
|
||||
(pattern-equal? (pat:pstruct-pattern a)
|
||||
(pat:pstruct-pattern b)))]
|
||||
[(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
|
||||
[(and (pat:delimit? a) (pat:delimit? b))
|
||||
(pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
|
||||
[(and (pat:commit? a) (pat:commit? b))
|
||||
(pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
|
||||
[(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
|
||||
[(and (pat:post? a) (pat:post? b))
|
||||
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
|
||||
;; ---
|
||||
[(and (hpat:var? a) (hpat:var? b))
|
||||
(and (free-id/f-equal? (hpat:var-parser a) (hpat:var-parser b))
|
||||
(equal-iattrs? (hpat:var-attrs a) (hpat:var-attrs b))
|
||||
(equal-argu? (hpat:var-argu a) (hpat:var-argu b))
|
||||
(expr-equal? (hpat:var-role a) (hpat:var-role b)))]
|
||||
[(and (hpat:seq? a) (hpat:seq? b))
|
||||
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
|
||||
;; ---
|
||||
[(and (ehpat? a) (ehpat? b))
|
||||
(and (equal? (ehpat-repc a) #f)
|
||||
(equal? (ehpat-repc b) #f)
|
||||
(pattern-equal? (ehpat-head a) (ehpat-head b)))]
|
||||
;; FIXME: more?
|
||||
[else #f]))
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (and (eq? result #f)
|
||||
(equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
|
||||
(eprintf "** pattern-equal? failed on ~e\n" a)))
|
||||
result)
|
||||
|
||||
(define (equal-iattrs? as bs)
|
||||
(and (= (length as) (length bs))
|
||||
;; assumes attrs in same order
|
||||
(for/and ([aa (in-list as)]
|
||||
[ba (in-list bs)])
|
||||
(and (bound-identifier=? (attr-name aa) (attr-name ba))
|
||||
(equal? (attr-depth aa) (attr-depth ba))
|
||||
(equal? (attr-syntax? aa) (attr-syntax? ba))))))
|
||||
|
||||
(define (expr-equal? a b)
|
||||
;; Expression equality is undecidable in general. Especially difficult for unexpanded
|
||||
;; code, but it would be very difficult to set up correct env for local-expand because of
|
||||
;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
|
||||
;; FIXME: any other common cases?
|
||||
(cond [(not (and (syntax? a) (syntax? b)))
|
||||
(equal? a b)]
|
||||
[(and (identifier? a) (identifier? b))
|
||||
;; note: "vars" might be identifier macros (unsafe to consider equal),
|
||||
;; so check var has no compile-time binding
|
||||
(and (free-identifier=? a b)
|
||||
(let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
|
||||
[(syntax-case (list a b) (quote)
|
||||
[((quote ad) (quote bd))
|
||||
(cons (syntax->datum #'ad) (syntax->datum #'bd))]
|
||||
[_ #f])
|
||||
=> (lambda (ad+bd)
|
||||
(equal? (car ad+bd) (cdr ad+bd)))]
|
||||
[else
|
||||
;; approx: equal? only if both simple data (bool, string, etc), no inner stx
|
||||
(let ([ad (syntax-e a)]
|
||||
[bd (syntax-e b)])
|
||||
(and (equal? ad bd)
|
||||
(free-identifier=? (datum->syntax a '#%datum) #'#%datum)
|
||||
(free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
|
||||
|
||||
(define (equal-argu? a b)
|
||||
(define (unwrap-arguments x)
|
||||
(match x
|
||||
[(arguments pargs kws kwargs)
|
||||
(values pargs kws kwargs)]))
|
||||
(define (list-equal? as bs inner-equal?)
|
||||
(and (= (length as) (length bs))
|
||||
(andmap inner-equal? as bs)))
|
||||
(let-values ([(apargs akws akwargs) (unwrap-arguments a)]
|
||||
[(bpargs bkws bkwargs) (unwrap-arguments b)])
|
||||
(and (list-equal? apargs bpargs expr-equal?)
|
||||
(equal? akws bkws)
|
||||
(list-equal? akwargs bkwargs expr-equal?))))
|
||||
|
||||
(define (free-id/f-equal? a b)
|
||||
(or (and (eq? a #f)
|
||||
(eq? b #f))
|
||||
(and (identifier? a)
|
||||
(identifier? b)
|
||||
(free-identifier=? a b))))
|
||||
|
||||
(define (make-and-pattern subs)
|
||||
(cond [(null? subs) (create-pat:any)] ;; shouldn't happen
|
||||
[(null? (cdr subs)) (car subs)]
|
||||
[else (create-pat:and subs)]))
|
||||
|
||||
(define (*append a b) (if (null? b) a (append a b)))
|
||||
|
||||
(define (stx-e x) (if (syntax? x) (syntax-e x) x))
|
||||
|
||||
;; ----
|
||||
|
||||
#|
|
||||
(define (matrix->sexpr rows)
|
||||
(cond [(null? rows) ;; shouldn't happen
|
||||
'(FAIL)]
|
||||
[(null? (cdr rows))
|
||||
(pk->sexpr (car rows))]
|
||||
[else
|
||||
(cons 'TRY (map pk->sexpr rows))]))
|
||||
(define (pk->sexpr pk)
|
||||
(match pk
|
||||
[(pk1 pats k)
|
||||
(cons 'MATCH (map pattern->sexpr pats))]
|
||||
[(pk/same pat inner)
|
||||
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
|
||||
[(pk/pair inner)
|
||||
(list 'PAIR (matrix->sexpr inner))]
|
||||
[(pk/and inner)
|
||||
(list 'AND (matrix->sexpr inner))]))
|
||||
(define (pattern->sexpr p)
|
||||
(match p
|
||||
[(pat:any _as) '_]
|
||||
[(pat:integrated _as name pred desc _)
|
||||
(format-symbol "~a:~a" (or name '_) desc)]
|
||||
[(pat:var _as name parser _ _ _ _ _)
|
||||
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
|
||||
=> (lambda (m)
|
||||
(format-symbol "~a:~a" (or name '_) (cadr m)))]
|
||||
[else
|
||||
(if name (syntax-e name) '_)])]
|
||||
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))]
|
||||
[(pat:datum _as datum) datum]
|
||||
[(? pat:action?) 'ACTION]
|
||||
[(pat:pair _as head tail)
|
||||
(cons (pattern->sexpr head) (pattern->sexpr tail))]
|
||||
[(pat:head _as head tail)
|
||||
(cons (pattern->sexpr head) (pattern->sexpr tail))]
|
||||
[_ 'PATTERN]))
|
||||
|#
|
||||
|
|
@ -10,6 +10,7 @@
|
|||
"rep-patterns.rkt"
|
||||
"rep.rkt"
|
||||
"kws.rkt"
|
||||
"opt.rkt"
|
||||
"txlift.rkt")
|
||||
"keywords.rkt"
|
||||
racket/syntax
|
||||
|
|
@ -22,13 +23,6 @@
|
|||
|
||||
;; ============================================================
|
||||
|
||||
(begin-for-syntax
|
||||
;; controls debugging output for optimization successes and failures
|
||||
(define DEBUG-OPT-SUCCEED #f)
|
||||
(define DEBUG-OPT-FAIL #f))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
(provide define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
define-integrable-syntax-class
|
||||
|
|
@ -88,23 +82,72 @@
|
|||
|
||||
(define-syntax (parser/rhs stx)
|
||||
(syntax-case stx ()
|
||||
[(parser/rhs name formals attrs rhss splicing? ctx)
|
||||
[(parser/rhs name formals relsattrs rhss splicing? ctx)
|
||||
(with-disappeared-uses
|
||||
(let ([rhs
|
||||
(parameterize ((current-syntax-context #'ctx))
|
||||
(parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
|
||||
#:context #'ctx))])
|
||||
#`(parser/rhs/parsed name formals attrs
|
||||
#,rhs #,(and (rhs-description rhs) #t)
|
||||
splicing? ctx)))]))
|
||||
|
||||
(define-syntax (parser/rhs/parsed stx)
|
||||
(syntax-case stx ()
|
||||
[(prp name formals attrs rhs rhs-has-description? splicing? ctx)
|
||||
#`(parse:rhs rhs attrs formals splicing?
|
||||
(if 'rhs-has-description?
|
||||
#,(rhs-description (syntax-e #'rhs))
|
||||
(symbol->string 'name)))]))
|
||||
(let ()
|
||||
(define the-rhs
|
||||
(parameterize ((current-syntax-context #'ctx))
|
||||
(parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?)
|
||||
#:context #'ctx)))
|
||||
(define-values (transparent? description variants defs commit? delimit-cut?)
|
||||
(match the-rhs
|
||||
[(rhs _ _ transparent? description variants defs (options 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 body
|
||||
(cond [(null? variants)
|
||||
#'(fail (failure pr es))]
|
||||
[(syntax-e #'splicing?)
|
||||
(with-syntax ([(alternative ...)
|
||||
(for/list ([variant (in-list variants)])
|
||||
(define pattern (variant-pattern variant))
|
||||
(with-syntax ([pattern pattern]
|
||||
[iattrs (pattern-attrs pattern)]
|
||||
[commit? commit?]
|
||||
[result-pr
|
||||
(if transparent?
|
||||
#'rest-pr
|
||||
#'(ps-pop-opaque rest-pr))])
|
||||
#'(parse:H x cx rest-x rest-cx rest-pr pattern pr es
|
||||
(variant-success relsattrs iattrs (rest-x rest-cx result-pr)
|
||||
success cp0 commit?))))])
|
||||
#'(try alternative ...))]
|
||||
[else
|
||||
(with-syntax ([matrix
|
||||
(optimize-matrix
|
||||
(for/list ([variant (in-list variants)])
|
||||
(define pattern (variant-pattern variant))
|
||||
(with-syntax ([iattrs (pattern-attrs pattern)]
|
||||
[commit? commit?])
|
||||
(pk1 (list pattern)
|
||||
#'(variant-success relsattrs iattrs ()
|
||||
success cp0 commit?)))))])
|
||||
#'(parse:matrix ((x cx pr es)) matrix))]))
|
||||
(with-syntax ([formals* formals*]
|
||||
[(def ...) defs]
|
||||
[((vdef ...) ...) vdefss]
|
||||
[description (or description (symbol->string (syntax-e #'name)))]
|
||||
[transparent? transparent?]
|
||||
[delimit-cut? delimit-cut?]
|
||||
[body body])
|
||||
#`(lambda (x cx pr es fh0 cp0 rl success . formals*)
|
||||
(with ([this-syntax x]
|
||||
[this-role rl])
|
||||
def ...
|
||||
vdef ... ...
|
||||
(#%expression
|
||||
(syntax-parameterize ((this-context-syntax
|
||||
(syntax-rules ()
|
||||
[(tbs) (ps-context-syntax pr)])))
|
||||
(let ([es (es-add-thing pr description 'transparent? rl es)]
|
||||
[pr (if 'transparent? pr (ps-add-opaque pr))])
|
||||
(with ([fail-handler fh0]
|
||||
[cut-prompt cp0])
|
||||
;; Update the prompt, if required
|
||||
;; FIXME: can be optimized away if no cut exposed within variants
|
||||
(with-maybe-delimit-cut delimit-cut?
|
||||
body))))))))))]))
|
||||
|
||||
(define-syntax (syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -246,45 +289,23 @@ Conventions:
|
|||
- fh, cp, rl : id (var)
|
||||
|#
|
||||
|
||||
;; (parse:rhs rhs relsattrs formals splicing? expr)
|
||||
;; : expr[stxclass-parser]
|
||||
;; Takes a list of the relevant attrs; order is significant!
|
||||
(define-syntax (parse:rhs stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...)
|
||||
#s(options commit? delimit-cut?) _integrate)
|
||||
relsattrs formals splicing? description)
|
||||
(with-syntax ([formals
|
||||
(let loop ([fstx #'formals])
|
||||
(syntax-case fstx ()
|
||||
[([kw arg default] . more)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(cons #'(kw arg (with ([this-syntax x] [this-role rl]) default))
|
||||
(loop #'more))]
|
||||
[([arg default] . more)
|
||||
(not (keyword? (syntax-e #'kw)))
|
||||
(cons #'(arg (with ([this-syntax x] [this-role rl]) default))
|
||||
(loop #'more))]
|
||||
[(formal . more)
|
||||
(cons #'formal (loop #'more))]
|
||||
[_ fstx]))])
|
||||
#'(lambda (x cx pr es fh0 cp0 rl success . formals)
|
||||
(with ([this-syntax x]
|
||||
[this-role rl])
|
||||
def ...
|
||||
(#%expression
|
||||
(syntax-parameterize ((this-context-syntax
|
||||
(syntax-rules ()
|
||||
[(tbs) (ps-context-syntax pr)])))
|
||||
(let ([es (es-add-thing pr description 'transparent? rl es)]
|
||||
[pr (if 'transparent? pr (ps-add-opaque pr))])
|
||||
(with ([fail-handler fh0]
|
||||
[cut-prompt cp0])
|
||||
;; Update the prompt, if required
|
||||
;; FIXME: can be optimized away if no cut immediately within variants...
|
||||
(with-maybe-delimit-cut delimit-cut?
|
||||
(parse:variants x cx relsattrs variants splicing? transparent?
|
||||
pr es success cp0 commit?)))))))))]))
|
||||
(begin-for-syntax
|
||||
(define (rewrite-formals fstx x-id rl-id)
|
||||
(with-syntax ([x x-id]
|
||||
[rl rl-id])
|
||||
(let loop ([fstx fstx])
|
||||
(syntax-case fstx ()
|
||||
[([kw arg default] . more)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(cons #'(kw arg (with ([this-syntax x] [this-role rl]) default))
|
||||
(loop #'more))]
|
||||
[([arg default] . more)
|
||||
(not (keyword? (syntax-e #'kw)))
|
||||
(cons #'(arg (with ([this-syntax x] [this-role rl]) default))
|
||||
(loop #'more))]
|
||||
[(formal . more)
|
||||
(cons #'formal (loop #'more))]
|
||||
[_ fstx])))))
|
||||
|
||||
;; (with-maybe-delimit-cut bool expr)
|
||||
(define-syntax with-maybe-delimit-cut
|
||||
|
|
@ -294,46 +315,12 @@ Conventions:
|
|||
[(wmdc #f k)
|
||||
k]))
|
||||
|
||||
;; (parse:variants x cx relsattrs variants splicing? pr es success cp0) : expr[Ans]
|
||||
(define-syntax (parse:variants stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:variants x cx relsattrs () splicing? transparent?
|
||||
pr es success cp0 commit?)
|
||||
;; Special case: no variants
|
||||
#'(fail (failure pr es))]
|
||||
[(parse:variants x cx relsattrs (variant ...) #t transparent?
|
||||
pr es success cp0 commit?)
|
||||
(with-syntax ([(#s(variant _ _ pattern (def ...)) ...) #'(variant ...)])
|
||||
#'(let ()
|
||||
def ... ...
|
||||
(try (parse:H x cx rest-x rest-cx rest-pr pattern pr es
|
||||
(variant-success relsattrs variant
|
||||
(rest-x
|
||||
rest-cx
|
||||
(if 'transparent? rest-pr (ps-pop-opaque rest-pr)))
|
||||
success cp0 commit?))
|
||||
...)))]
|
||||
[(parse:variants x cx relsattrs (variant ...) splicing? transparent?
|
||||
pr es success cp0 commit?)
|
||||
(with-syntax ([(#s(variant _ _ pattern (def ...)) ...) #'(variant ...)])
|
||||
#'(let ()
|
||||
def ... ...
|
||||
(parse:S* ((x cx pr es))
|
||||
((pattern) ...)
|
||||
((variant-success relsattrs variant
|
||||
()
|
||||
success cp0 commit?)
|
||||
...))))]))
|
||||
|
||||
;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans]
|
||||
(define-syntax (variant-success stx)
|
||||
(syntax-case stx ()
|
||||
[(variant-success relsattrs #s(variant _ _ pattern _) (also ...) success cp0 commit?)
|
||||
[(variant-success relsattrs iattrs (also ...) success cp0 commit?)
|
||||
#`(with-maybe-reset-fail commit? cp0
|
||||
(base-success-expr #,(pattern-attrs (wash #'pattern))
|
||||
relsattrs
|
||||
(also ...)
|
||||
success))]))
|
||||
(base-success-expr iattrs relsattrs (also ...) success))]))
|
||||
|
||||
;; (with-maybe-reset-fail bool id expr)
|
||||
(define-syntax with-maybe-reset-fail
|
||||
|
|
@ -415,9 +402,12 @@ Conventions:
|
|||
(with ([fail-handler fh0]
|
||||
[cut-prompt fh0])
|
||||
#,(cond [(pair? patterns)
|
||||
(with-syntax ([(pattern ...) patterns]
|
||||
[(body ...) body-exprs])
|
||||
#'(parse:S* ((x cx pr es)) ((pattern) ...) (body ...)))
|
||||
(with-syntax ([matrix
|
||||
(optimize-matrix
|
||||
(for/list ([pattern (in-list patterns)]
|
||||
[body-expr (in-list body-exprs)])
|
||||
(pk1 (list pattern) body-expr)))])
|
||||
#'(parse:matrix ((x cx pr es)) matrix))
|
||||
#|
|
||||
(with-syntax ([(alternative ...)
|
||||
(for/list ([pattern (in-list patterns)]
|
||||
|
|
@ -430,368 +420,42 @@ Conventions:
|
|||
|
||||
;; ----
|
||||
|
||||
;; (parse:S* ((x cx pr es) ...) ((S-pattern ...) ...) (k ...)) : expr[Ans]
|
||||
;; In k: attrs(S-pattern) are bound.
|
||||
|
||||
;; (parse:S* (in1 ... inN) ((P11 ... P1N) ... (PM1 ... PMN)) (e1 ... eM))
|
||||
;; or equivalently (parse:S* (in1 ... inN) (row1 ... rowM) (e1 ... eM))
|
||||
;; (parse:matrix ((x cx pr es) ...) (PK ...)) : expr[Ans]
|
||||
;; (parse:matrix (in1 ... inN) (#s(pk1 (P11 ... P1N) e1) ... #s(pk1 (PM1 ... PMN) eM)))
|
||||
;; represents the matching matrix
|
||||
;; [_in1_..._inN_|____]
|
||||
;; [ P11 ... P1N | e1 ]
|
||||
;; [ ⋮ ⋮ | ⋮ ]
|
||||
;; [ PM1 ... PMN | eM ]
|
||||
|
||||
;; Can factor pattern P given clauses like
|
||||
;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
|
||||
;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ]
|
||||
; [ P PN ... | eN] [ | [PN ... | eN] ]
|
||||
;; if
|
||||
;; - P cannot cut
|
||||
;; - P must succeed at most once (otherwise may reorder backtracking)
|
||||
|
||||
;; Can unfold pair patterns as follows:
|
||||
;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
|
||||
;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ]
|
||||
;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
|
||||
|
||||
;; Can unfold ~and patterns similarly; ~and-patterns can hide
|
||||
;; factoring opportunities.
|
||||
|
||||
(define-syntax (parse:S* stx)
|
||||
(define-syntax (parse:matrix stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:S* () (() ...) (k ...))
|
||||
#'(try k ...)]
|
||||
[(parse:S* ins rows ks)
|
||||
;; Split into uniform sequences of rows according to pattern in column1
|
||||
(let ([ins (syntax->list #'ins)]
|
||||
[rows (map syntax->list (syntax->list #'rows))]
|
||||
[ks (syntax->list #'ks)])
|
||||
(let-values ([(ins rows) (unfold-and-patterns ins rows)])
|
||||
(with-syntax ([ins ins]
|
||||
[((parser sub-rows sub-ks) ...) (split-S* rows ks)])
|
||||
#'(try (parser ins sub-rows sub-ks) ...))))]))
|
||||
[(parse:matrix ins (pk ...))
|
||||
#'(try (parse:pk ins pk) ...)]))
|
||||
|
||||
(define-syntax (parse:S*/pairs stx)
|
||||
(define-syntax (parse:pk stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:S*/pairs ins rows ks)
|
||||
;; First pattern in each row is pat:pair
|
||||
(with-syntax ([((#s(pat:pair _ head tail) . row) ...) #'rows]
|
||||
[((x cx pr es) . ins) #'ins])
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(when (> (length (syntax->list #'rows)) 1)
|
||||
(eprintf "** pairs\n")))
|
||||
#'(let-values ([(datum tcx)
|
||||
(if (syntax? x)
|
||||
(values (syntax-e x) x)
|
||||
(values x cx))])
|
||||
(if (pair? datum)
|
||||
(let ([hx (car datum)]
|
||||
[hcx (car datum)]
|
||||
[hpr (ps-add-car pr)]
|
||||
[tx (cdr datum)]
|
||||
[tpr (ps-add-cdr pr)])
|
||||
(parse:S* ((hx hcx hpr es) (tx tcx tpr es) . ins)
|
||||
((head tail . row) ...)
|
||||
ks))
|
||||
(fail (failure pr es)))))]))
|
||||
|
||||
(define-syntax (parse:S*/same stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:S*/same ins rows ks)
|
||||
;; First pattern in each row is same
|
||||
(with-syntax ([((pat1 . row) ...) #'rows]
|
||||
[((x cx pr es) . ins) #'ins])
|
||||
(with-syntax ([pat1 (stx-car #'(pat1 ...))])
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(when (> (length (syntax->list #'rows)) 1)
|
||||
(eprintf "** same: ~e\n" (syntax->datum #'pat1))))
|
||||
#'(parse:S x cx pat1 pr es (parse:S* ins (row ...) ks))))]))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define (unfold-and-patterns ins rows)
|
||||
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
|
||||
(define (unfold-and p onto)
|
||||
(match (stx-e p)
|
||||
[(pat:and _as subpatterns)
|
||||
;; pat:and is worth unfolding if first subpattern is not pat:action
|
||||
(let* ([subpatterns (syntax->list subpatterns)]
|
||||
[first-sub (car subpatterns)]
|
||||
[rest-subs (cdr subpatterns)])
|
||||
(cond [(not (pat:action? (stx-e first-sub)))
|
||||
(when #f ;; DEBUG-OPT-SUCCEED
|
||||
(eprintf ">> unfolding: ~e\n" (syntax->datum p)))
|
||||
(unfold-and first-sub
|
||||
(*append rest-subs onto))]
|
||||
[else (values p onto)]))]
|
||||
[_ (values p onto)]))
|
||||
(define (*append a b) (if (null? b) a (append a b)))
|
||||
(define (make-and-pattern subs)
|
||||
(cond [(null? subs) (create-pat:any)] ;; shouldn't happen
|
||||
[(null? (cdr subs)) (car subs)]
|
||||
[else
|
||||
(let ([attrs 'unused]) ;; NOTE: attrs unused at this point, and it's a pain to recalc
|
||||
(make-pat:and attrs subs))]))
|
||||
(let-values ([(col1 col2)
|
||||
(for/lists (col1 col2) ([row (in-list rows)])
|
||||
(unfold-and (car row) null))])
|
||||
(cond [(ormap pair? col2)
|
||||
(values (cons (car ins) ins)
|
||||
(for/list ([row (in-list rows)]
|
||||
[col1 (in-list col1)]
|
||||
[col2 (in-list col2)])
|
||||
(list* col1 (make-and-pattern col2) (cdr row))))]
|
||||
[else (values ins rows)])))
|
||||
|
||||
(define (split-S* rows ks)
|
||||
(cond [(null? rows)
|
||||
null]
|
||||
[else
|
||||
(define row1 (stx->list (car rows)))
|
||||
(define pat1 (car row1))
|
||||
(define k1 (car ks))
|
||||
;; Now accumulate rows starting with patterns like pat1
|
||||
(define-values (parser keep?) (like-S-pattern? pat1))
|
||||
(let loop ([rows (cdr rows)] [ks (cdr ks)] [rrows (list row1)] [rks (list k1)])
|
||||
(cond [(null? rows)
|
||||
(cons (list parser (reverse rrows) (reverse rks))
|
||||
(split-S* rows ks))]
|
||||
[else
|
||||
(define row1 (stx->list (car rows)))
|
||||
(define pat1 (car row1))
|
||||
(define k1 (car ks))
|
||||
(cond [(keep? pat1)
|
||||
(loop (cdr rows) (cdr ks) (cons row1 rrows) (cons k1 rks))]
|
||||
[else
|
||||
(cons (list parser (reverse rrows) (reverse rks))
|
||||
(split-S* rows ks))])]))]))
|
||||
|
||||
(define (like-S-pattern? pat1)
|
||||
(syntax-case pat1 ()
|
||||
[#s(pat:pair attrs head tail)
|
||||
(values #'parse:S*/pairs
|
||||
(lambda (x) (syntax-case x ()
|
||||
[#s(pat:pair _ _ _) #t]
|
||||
[_ #f])))]
|
||||
;; FIXME: more?
|
||||
[_
|
||||
(values #'parse:S*/same
|
||||
;; Can collapse only if no cut, succeed once,
|
||||
;; otherwise cannot collapse.
|
||||
(if (pattern-factorable? pat1)
|
||||
(lambda (pat2)
|
||||
(pattern-equal? pat1 pat2))
|
||||
(lambda (pat2)
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (pattern-equal? pat1 pat2)
|
||||
(eprintf "** cannot factor out ~e\n" (syntax->datum pat2))))
|
||||
#f)))]))
|
||||
|
||||
(define (pattern-factorable? p)
|
||||
;; Can factor out p if p can succeed at most once, does not cut
|
||||
;; - if p can succeed multiple times, then factoring changes success order
|
||||
;; - if p can cut, then factoring changes which choice points are discarded (too few)
|
||||
(let ([p (stx-e p)])
|
||||
(match p
|
||||
[(pat:any _as) #t]
|
||||
[(pat:var _as _n _p _argu _na _ac commit? _r)
|
||||
;; commit? implies delimit-cut
|
||||
(eq? (stx-e commit?) #t)]
|
||||
[(? pat:integrated?) #t]
|
||||
[(pat:literal _as _lit _ip _lp) #t]
|
||||
[(pat:datum _as _datum) #t]
|
||||
[(pat:action _as _act _pat) #f]
|
||||
[(pat:head _as head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:dots _as heads tail)
|
||||
(let ([heads (syntax->list heads)])
|
||||
;; Conservative approximation for common case: one head pattern
|
||||
;; In general, check if heads don't overlap, don't overlap with tail.
|
||||
(and (= (length heads) 1)
|
||||
(let ([head (car heads)])
|
||||
(and (pattern-factorable? head)))
|
||||
(equal? (syntax->datum tail)
|
||||
(create-pat:datum '()))))]
|
||||
[(pat:and _as patterns)
|
||||
(andmap pattern-factorable?
|
||||
(syntax->list patterns))]
|
||||
[(pat:or _as patterns) #f]
|
||||
[(pat:not _as pattern) #f] ;; FIXME: ?
|
||||
[(pat:pair _as head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:vector _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:box _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:pstruct _as key pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:describe _as pattern _desc _trans _role)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:delimit _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:commit _as pattern) #t]
|
||||
[(? pat:reflect?) #f]
|
||||
[(pat:post _as pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
;; ----
|
||||
[(hpat:var _as _name _parser _argu _na _ac commit? _role)
|
||||
(eq? (stx-e commit?) #t)]
|
||||
[(hpat:seq _as inner)
|
||||
(pattern-factorable? inner)]
|
||||
[(hpat:commit _as inner) #t]
|
||||
;; ----
|
||||
[(ehpat _as head repc)
|
||||
(and (equal? (syntax->datum repc) #f)
|
||||
(pattern-factorable? head))]
|
||||
;; ----
|
||||
[else #f])))
|
||||
|
||||
(define (pattern-equal? a b)
|
||||
(define (subpatterns-equal? as bs)
|
||||
(let ([as (stx->list as)]
|
||||
[bs (stx->list bs)])
|
||||
(and (= (length as) (length bs))
|
||||
(for/and ([a (in-list as)]
|
||||
[b (in-list bs)])
|
||||
(pattern-equal? a b)))))
|
||||
(define result
|
||||
(let ([a (stx-e a)]
|
||||
[b (stx-e b)])
|
||||
(cond [(and (pat:any? a) (pat:any? b)) #t]
|
||||
[(and (pat:var? a) (pat:var? b))
|
||||
(and (free-id/f-equal? (pat:var-parser a) (pat:var-parser b))
|
||||
(equal-iattrs? (pat:var-attrs a) (pat:var-attrs b))
|
||||
(equal-argu? (pat:var-argu a) (pat:var-argu b))
|
||||
(expr-equal? (pat:var-role a) (pat:var-role b)))]
|
||||
[(and (pat:integrated? a) (pat:integrated? b))
|
||||
(and (free-identifier=? (pat:integrated-predicate a)
|
||||
(pat:integrated-predicate b))
|
||||
(equal-iattrs? (pat:integrated-attrs a)
|
||||
(pat:integrated-attrs b))
|
||||
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
|
||||
[(and (pat:literal? a) (pat:literal? b))
|
||||
;; literals are hard to compare, so compare gensyms attached to
|
||||
;; literal ids (see rep.rkt) instead
|
||||
(let ([ka (syntax-property (pat:literal-id a) 'literal)]
|
||||
[kb (syntax-property (pat:literal-id b) 'literal)])
|
||||
(and ka kb (eq? ka kb)))]
|
||||
[(and (pat:datum? a) (pat:datum? b))
|
||||
(equal? (syntax->datum (pat:datum-datum a))
|
||||
(syntax->datum (pat:datum-datum b)))]
|
||||
[(and (pat:head? a) (pat:head? b))
|
||||
(and (pattern-equal? (pat:head-head a) (pat:head-head b))
|
||||
(pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
|
||||
[(and (pat:dots? a) (pat:dots? b))
|
||||
(and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
|
||||
(pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
|
||||
[(and (pat:and? a) (pat:and? b))
|
||||
(subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
|
||||
[(and (pat:or? a) (pat:or? b))
|
||||
(subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
|
||||
[(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))
|
||||
(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))]
|
||||
[(and (pat:box? a) (pat:box? b))
|
||||
(pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
|
||||
[(and (pat:pstruct? a) (pat:pstruct? b))
|
||||
(and (equal? (syntax->datum (pat:pstruct-key a))
|
||||
(syntax->datum (pat:pstruct-key b)))
|
||||
(pattern-equal? (pat:pstruct-pattern a)
|
||||
(pat:pstruct-pattern b)))]
|
||||
[(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
|
||||
[(and (pat:delimit? a) (pat:delimit? b))
|
||||
(pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
|
||||
[(and (pat:commit? a) (pat:commit? b))
|
||||
(pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
|
||||
[(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
|
||||
[(and (pat:post? a) (pat:post? b))
|
||||
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
|
||||
;; ---
|
||||
[(and (hpat:var? a) (hpat:var? b))
|
||||
(and (free-id/f-equal? (hpat:var-parser a) (hpat:var-parser b))
|
||||
(equal-iattrs? (hpat:var-attrs a) (hpat:var-attrs b))
|
||||
(equal-argu? (hpat:var-argu a) (hpat:var-argu b))
|
||||
(expr-equal? (hpat:var-role a) (hpat:var-role b)))]
|
||||
[(and (hpat:seq? a) (hpat:seq? b))
|
||||
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
|
||||
;; ---
|
||||
[(and (ehpat? a) (ehpat? b))
|
||||
(and (equal? (syntax->datum (ehpat-repc a)) #f)
|
||||
(equal? (syntax->datum (ehpat-repc b)) #f)
|
||||
(pattern-equal? (ehpat-head a) (ehpat-head b)))]
|
||||
;; FIXME: more?
|
||||
[else #f])))
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (and (equal? (syntax->datum a) (syntax->datum b))
|
||||
(eq? result #f))
|
||||
(eprintf "** pattern-equal? failed on ~e\n" (syntax->datum a))))
|
||||
result)
|
||||
|
||||
(define (equal-iattrs? as bs)
|
||||
(let ([as (wash-iattrs as)]
|
||||
[bs (wash-iattrs bs)])
|
||||
(and (= (length as) (length bs))
|
||||
;; assumes attrs in same order
|
||||
(for/and ([aa (in-list (wash-iattrs as))]
|
||||
[ba (in-list (wash-iattrs bs))])
|
||||
(and (bound-identifier=? (attr-name aa) (attr-name ba))
|
||||
(equal? (attr-depth aa) (attr-depth ba))
|
||||
(equal? (attr-syntax? aa) (attr-syntax? ba)))))))
|
||||
|
||||
(define (expr-equal? a b)
|
||||
;; Expression equality is undecidable in general. Especially difficult for unexpanded
|
||||
;; code, but it would be very difficult to set up correct env for local-expand because of
|
||||
;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
|
||||
;; FIXME: any other common cases?
|
||||
(cond [(and (identifier? a) (identifier? b))
|
||||
;; note: "vars" might be identifier macros (unsafe to consider equal),
|
||||
;; so check var has no compile-time binding
|
||||
(and (free-identifier=? a b)
|
||||
(let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
|
||||
[(syntax-case (list a b) (quote)
|
||||
[((quote ad) (quote bd))
|
||||
(cons (syntax->datum #'ad) (syntax->datum #'bd))]
|
||||
[_ #f])
|
||||
=> (lambda (ad+bd)
|
||||
(equal? (car ad+bd) (cdr ad+bd)))]
|
||||
[else
|
||||
;; approx: equal? only if both simple data (bool, string, etc), no inner stx
|
||||
(let ([ad (syntax-e a)]
|
||||
[bd (syntax-e b)])
|
||||
(and (equal? ad bd)
|
||||
(free-identifier=? (datum->syntax a '#%datum) #'#%datum)
|
||||
(free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
|
||||
|
||||
(define (equal-argu? a b)
|
||||
(define (unwrap-arguments x)
|
||||
(match (stx-e x)
|
||||
[(arguments pargs kws kwargs)
|
||||
(values (syntax->list pargs)
|
||||
(syntax->datum kws)
|
||||
(syntax->list kwargs))]))
|
||||
(define (list-equal? as bs inner-equal?)
|
||||
(and (= (length as) (length bs))
|
||||
(andmap inner-equal? as bs)))
|
||||
(let-values ([(apargs akws akwargs) (unwrap-arguments a)]
|
||||
[(bpargs bkws bkwargs) (unwrap-arguments b)])
|
||||
(and (list-equal? apargs bpargs expr-equal?)
|
||||
(equal? akws bkws)
|
||||
(list-equal? akwargs bkwargs expr-equal?))))
|
||||
|
||||
(define (free-id/f-equal? a b)
|
||||
(or (and (eq? (syntax-e a) #f)
|
||||
(eq? (syntax-e b) #f))
|
||||
(and (identifier? a)
|
||||
(identifier? b)
|
||||
(free-identifier=? a b))))
|
||||
|
||||
(define (stx-e x) (if (syntax? x) (syntax-e x) x)))
|
||||
[(parse:pk () #s(pk1 () k))
|
||||
#'k]
|
||||
[(parse:pk ((x cx pr es) . ins) #s(pk1 (pat1 . 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:S x cx pat1 pr es (parse:matrix ins inner))]
|
||||
[(parse:pk ((x cx pr es) . ins) #s(pk/pair inner))
|
||||
#'(let-values ([(datum tcx)
|
||||
(if (syntax? x)
|
||||
(values (syntax-e x) x)
|
||||
(values x cx))])
|
||||
(if (pair? datum)
|
||||
(let ([hx (car datum)]
|
||||
[hcx (car datum)]
|
||||
[hpr (ps-add-car pr)]
|
||||
[tx (cdr datum)]
|
||||
[tpr (ps-add-cdr pr)])
|
||||
(parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner))
|
||||
(fail (failure pr es))))]
|
||||
[(parse:pk (in1 . ins) #s(pk/and inner))
|
||||
#'(parse:matrix (in1 in1 . ins) inner)]))
|
||||
|
||||
;; ----
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user