617 lines
20 KiB
Racket
617 lines
20 KiB
Racket
#lang racket/base
|
|
(require stxparse-info/parse/private/residual-ct ;; keep abs. path
|
|
"rep-attrs.rkt"
|
|
"minimatch.rkt"
|
|
racket/syntax)
|
|
(provide (all-defined-out))
|
|
|
|
#|
|
|
Uses Arguments from kws.rkt
|
|
|#
|
|
|
|
#|
|
|
A SinglePattern is one of
|
|
(pat:any)
|
|
(pat:svar id) -- "simple" var, no stxclass
|
|
(pat:var/p Id Id Arguments (Listof IAttr) Stx scopts) -- var with parser
|
|
(pat:literal identifier Stx Stx)
|
|
(pat:datum datum)
|
|
(pat:action ActionPattern SinglePattern)
|
|
(pat:head HeadPattern SinglePattern)
|
|
(pat:dots (listof EllipsisHeadPattern) SinglePattern)
|
|
(pat:and (listof SinglePattern))
|
|
(pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
|
|
(pat:not SinglePattern)
|
|
(pat:pair SinglePattern SinglePattern)
|
|
(pat:vector SinglePattern)
|
|
(pat:box SinglePattern)
|
|
(pat:pstruct key SinglePattern)
|
|
(pat:describe SinglePattern stx boolean stx)
|
|
(pat:delimit SinglePattern)
|
|
(pat:commit SinglePattern)
|
|
(pat:reflect stx Arguments (listof SAttr) id (listof IAttr))
|
|
(pat:ord SinglePattern UninternedSymbol Nat)
|
|
(pat:post SinglePattern)
|
|
(pat:integrated id/#f id string stx)
|
|
|
|
A ListPattern is a subtype of SinglePattern; one of
|
|
(pat:datum '())
|
|
(pat:action ActionPattern ListPattern)
|
|
(pat:head HeadPattern ListPattern)
|
|
(pat:pair SinglePattern ListPattern)
|
|
(pat:dots EllipsisHeadPattern ListPattern)
|
|
|#
|
|
|
|
(define-struct pat:any () #:prefab)
|
|
(define-struct pat:svar (name) #:prefab)
|
|
(define-struct pat:var/p (name parser argu nested-attrs role opts) #:prefab)
|
|
(define-struct pat:literal (id input-phase lit-phase) #:prefab)
|
|
(define-struct pat:datum (datum) #:prefab)
|
|
(define-struct pat:action (action inner) #:prefab)
|
|
(define-struct pat:head (head tail) #:prefab)
|
|
(define-struct pat:dots (heads tail) #:prefab)
|
|
(define-struct pat:and (patterns) #:prefab)
|
|
(define-struct pat:or (attrs patterns attrss) #:prefab)
|
|
(define-struct pat:not (pattern) #: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)
|
|
(define-struct pat:describe (pattern description transparent? role) #:prefab)
|
|
(define-struct pat:delimit (pattern) #:prefab)
|
|
(define-struct pat:commit (pattern) #:prefab)
|
|
(define-struct pat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
|
|
(define-struct pat:ord (pattern group index) #:prefab)
|
|
(define-struct pat:post (pattern) #:prefab)
|
|
(define-struct pat:integrated (name predicate description role) #:prefab)
|
|
|
|
#|
|
|
A ActionPattern is one of
|
|
(action:cut)
|
|
(action:fail stx stx)
|
|
(action:bind IAttr Stx)
|
|
(action:and (listof ActionPattern))
|
|
(action:parse SinglePattern stx)
|
|
(action:do (listof stx))
|
|
(action:ord ActionPattern UninternedSymbol Nat)
|
|
(action:post ActionPattern)
|
|
|
|
A BindAction is (action:bind IAttr Stx)
|
|
A SideClause is just an ActionPattern
|
|
|#
|
|
|
|
(define-struct action:cut () #:prefab)
|
|
(define-struct action:fail (when message) #:prefab)
|
|
(define-struct action:bind (attr expr) #:prefab)
|
|
(define-struct action:and (patterns) #:prefab)
|
|
(define-struct action:parse (pattern expr) #:prefab)
|
|
(define-struct action:do (stmts) #:prefab)
|
|
(define-struct action:ord (pattern group index) #:prefab)
|
|
(define-struct action:post (pattern) #:prefab)
|
|
|
|
#|
|
|
A HeadPattern is one of
|
|
(hpat:var/p Id Id Arguments (Listof IAttr) Stx scopts)
|
|
(hpat:seq ListPattern)
|
|
(hpat:action ActionPattern HeadPattern)
|
|
(hpat:and HeadPattern SinglePattern)
|
|
(hpat:or (listof IAttr) (listof HeadPattern) (listof (listof IAttr)))
|
|
(hpat:describe HeadPattern stx/#f boolean stx)
|
|
(hpat:delimit HeadPattern)
|
|
(hpat:commit HeadPattern)
|
|
(hpat:reflect stx Arguments (listof SAttr) id (listof IAttr))
|
|
(hpat:ord HeadPattern UninternedSymbol Nat)
|
|
(hpat:post HeadPattern)
|
|
(hpat:peek HeadPattern)
|
|
(hpat:peek-not HeadPattern)
|
|
|#
|
|
|
|
(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab)
|
|
(define-struct hpat:seq (inner) #:prefab)
|
|
(define-struct hpat:action (action inner) #:prefab)
|
|
(define-struct hpat:and (head single) #:prefab)
|
|
(define-struct hpat:or (attrs patterns attrss) #:prefab)
|
|
(define-struct hpat:describe (pattern description transparent? role) #:prefab)
|
|
(define-struct hpat:delimit (pattern) #:prefab)
|
|
(define-struct hpat:commit (pattern) #:prefab)
|
|
(define-struct hpat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
|
|
(define-struct hpat:ord (pattern group index) #:prefab)
|
|
(define-struct hpat:post (pattern) #:prefab)
|
|
(define-struct hpat:peek (pattern) #:prefab)
|
|
(define-struct hpat:peek-not (pattern) #:prefab)
|
|
|
|
#|
|
|
An EllipsisHeadPattern is
|
|
(ehpat (Listof IAttr) HeadPattern RepConstraint Boolean)
|
|
|
|
A RepConstraint is one of
|
|
(rep:once stx stx stx)
|
|
(rep:optional stx stx (listof BindAction))
|
|
(rep:bounds nat posint/+inf.0 stx stx stx)
|
|
#f
|
|
|#
|
|
|
|
(define-struct ehpat (attrs head repc check-null?) #:prefab)
|
|
(define-struct rep:once (name under-message over-message) #:prefab)
|
|
(define-struct rep:optional (name over-message defaults) #:prefab)
|
|
(define-struct rep:bounds (min max name under-message over-message) #:prefab)
|
|
|
|
(define (pattern? x)
|
|
(or (pat:any? x)
|
|
(pat:svar? x)
|
|
(pat:var/p? x)
|
|
(pat:literal? x)
|
|
(pat:datum? x)
|
|
(pat:action? x)
|
|
(pat:head? x)
|
|
(pat:dots? x)
|
|
(pat:and? x)
|
|
(pat:or? x)
|
|
(pat:not? x)
|
|
(pat:pair? x)
|
|
(pat:vector? x)
|
|
(pat:box? x)
|
|
(pat:pstruct? x)
|
|
(pat:describe? x)
|
|
(pat:delimit? x)
|
|
(pat:commit? x)
|
|
(pat:reflect? x)
|
|
(pat:ord? x)
|
|
(pat:post? x)
|
|
(pat:integrated? x)))
|
|
|
|
(define (action-pattern? x)
|
|
(or (action:cut? x)
|
|
(action:bind? x)
|
|
(action:fail? x)
|
|
(action:and? x)
|
|
(action:parse? x)
|
|
(action:do? x)
|
|
(action:ord? x)
|
|
(action:post? x)))
|
|
|
|
(define (head-pattern? x)
|
|
(or (hpat:var/p? x)
|
|
(hpat:seq? x)
|
|
(hpat:action? x)
|
|
(hpat:and? x)
|
|
(hpat:or? x)
|
|
(hpat:describe? x)
|
|
(hpat:delimit? x)
|
|
(hpat:commit? x)
|
|
(hpat:reflect? x)
|
|
(hpat:ord? x)
|
|
(hpat:post? x)
|
|
(hpat:peek? x)
|
|
(hpat:peek-not? x)))
|
|
|
|
(define (ellipsis-head-pattern? x)
|
|
(ehpat? x))
|
|
|
|
(define single-pattern? pattern?)
|
|
|
|
(define (single-or-head-pattern? x)
|
|
(or (single-pattern? x)
|
|
(head-pattern? x)))
|
|
|
|
;; check-pattern : *Pattern -> *Pattern
|
|
;; Does attr computation to catch errors, but returns same pattern.
|
|
(define (check-pattern p)
|
|
(void (pattern-attrs p))
|
|
p)
|
|
|
|
;; pattern-attrs-table : Hasheq[*Pattern => (Listof IAttr)]
|
|
(define pattern-attrs-table (make-weak-hasheq))
|
|
|
|
;; pattern-attrs : *Pattern -> (Listof IAttr)
|
|
(define (pattern-attrs p)
|
|
(hash-ref! pattern-attrs-table p (lambda () (pattern-attrs* p))))
|
|
|
|
(define (pattern-attrs* p)
|
|
(match p
|
|
;; -- S patterns
|
|
[(pat:any)
|
|
null]
|
|
[(pat:svar name)
|
|
(list (attr name 0 #t))]
|
|
[(pat:var/p name _ _ nested-attrs _ _)
|
|
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
|
|
[(pat:reflect _ _ _ name nested-attrs)
|
|
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
|
|
[(pat:datum _)
|
|
null]
|
|
[(pat:literal _ _ _)
|
|
null]
|
|
[(pat:action a sp)
|
|
(append-iattrs (map pattern-attrs (list a sp)))]
|
|
[(pat:head headp tailp)
|
|
(append-iattrs (map pattern-attrs (list headp tailp)))]
|
|
[(pat:pair headp tailp)
|
|
(append-iattrs (map pattern-attrs (list headp tailp)))]
|
|
[(pat:vector sp)
|
|
(pattern-attrs sp)]
|
|
[(pat:box sp)
|
|
(pattern-attrs sp)]
|
|
[(pat:pstruct key sp)
|
|
(pattern-attrs sp)]
|
|
[(pat:describe sp _ _ _)
|
|
(pattern-attrs sp)]
|
|
[(pat:and ps)
|
|
(append-iattrs (map pattern-attrs ps))]
|
|
[(pat:or _ ps _)
|
|
(union-iattrs (map pattern-attrs ps))]
|
|
[(pat:not _)
|
|
null]
|
|
[(pat:dots headps tailp)
|
|
(append-iattrs (map pattern-attrs (append headps (list tailp))))]
|
|
[(pat:delimit sp)
|
|
(pattern-attrs sp)]
|
|
[(pat:commit sp)
|
|
(pattern-attrs sp)]
|
|
[(pat:ord sp _ _)
|
|
(pattern-attrs sp)]
|
|
[(pat:post sp)
|
|
(pattern-attrs sp)]
|
|
[(pat:integrated name _ _ _)
|
|
(if name (list (attr name 0 #t)) null)]
|
|
|
|
;; -- A patterns
|
|
[(action:cut)
|
|
null]
|
|
[(action:fail _ _)
|
|
null]
|
|
[(action:bind attr expr)
|
|
(list attr)]
|
|
[(action:and ps)
|
|
(append-iattrs (map pattern-attrs ps))]
|
|
[(action:parse sp _)
|
|
(pattern-attrs sp)]
|
|
[(action:do _)
|
|
null]
|
|
[(action:ord sp _ _)
|
|
(pattern-attrs sp)]
|
|
[(action:post sp)
|
|
(pattern-attrs sp)]
|
|
|
|
;; -- H patterns
|
|
[(hpat:var/p name _ _ nested-attrs _ _)
|
|
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
|
|
[(hpat:reflect _ _ _ name nested-attrs)
|
|
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
|
|
[(hpat:seq lp)
|
|
(pattern-attrs lp)]
|
|
[(hpat:action a hp)
|
|
(append-iattrs (map pattern-attrs (list a hp)))]
|
|
[(hpat:describe hp _ _ _)
|
|
(pattern-attrs hp)]
|
|
[(hpat:and hp sp)
|
|
(append-iattrs (map pattern-attrs (list hp sp)))]
|
|
[(hpat:or _ ps _)
|
|
(union-iattrs (map pattern-attrs ps))]
|
|
[(hpat:delimit hp)
|
|
(pattern-attrs hp)]
|
|
[(hpat:commit hp)
|
|
(pattern-attrs hp)]
|
|
[(hpat:ord hp _ _)
|
|
(pattern-attrs hp)]
|
|
[(hpat:post hp)
|
|
(pattern-attrs hp)]
|
|
[(hpat:peek hp)
|
|
(pattern-attrs hp)]
|
|
[(hpat:peek-not hp)
|
|
null]
|
|
|
|
;; EH patterns
|
|
[(ehpat iattrs _ _ _)
|
|
iattrs]
|
|
))
|
|
|
|
;; ----
|
|
|
|
;; pattern-has-cut? : *Pattern -> Boolean
|
|
;; Returns #t if p *might* cut (~!, not within ~delimit-cut).
|
|
(define (pattern-has-cut? p)
|
|
(match p
|
|
;; -- S patterns
|
|
[(pat:any) #f]
|
|
[(pat:svar name) #f]
|
|
[(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
|
|
[(pat:reflect _ _ _ name nested-attrs) #f]
|
|
[(pat:datum _) #f]
|
|
[(pat:literal _ _ _) #f]
|
|
[(pat:action a sp) (or (pattern-has-cut? a) (pattern-has-cut? sp))]
|
|
[(pat:head headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))]
|
|
[(pat:pair headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))]
|
|
[(pat:vector sp) (pattern-has-cut? sp)]
|
|
[(pat:box sp) (pattern-has-cut? sp)]
|
|
[(pat:pstruct key sp) (pattern-has-cut? sp)]
|
|
[(pat:describe sp _ _ _) (pattern-has-cut? sp)]
|
|
[(pat:and ps) (ormap pattern-has-cut? ps)]
|
|
[(pat:or _ ps _) (ormap pattern-has-cut? ps)]
|
|
[(pat:not _) #f]
|
|
[(pat:dots headps tailp) (or (ormap pattern-has-cut? headps) (pattern-has-cut? tailp))]
|
|
[(pat:delimit sp) #f]
|
|
[(pat:commit sp) #f]
|
|
[(pat:ord sp _ _) (pattern-has-cut? sp)]
|
|
[(pat:post sp) (pattern-has-cut? sp)]
|
|
[(pat:integrated name _ _ _) #f]
|
|
|
|
;; -- A patterns
|
|
[(action:cut) #t]
|
|
[(action:fail _ _) #f]
|
|
[(action:bind attr expr) #f]
|
|
[(action:and ps) (ormap pattern-has-cut? ps)]
|
|
[(action:parse sp _) (pattern-has-cut? sp)]
|
|
[(action:do _) #f]
|
|
[(action:ord sp _ _) (pattern-has-cut? sp)]
|
|
[(action:post sp) (pattern-has-cut? sp)]
|
|
|
|
;; -- H patterns
|
|
[(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
|
|
[(hpat:reflect _ _ _ name nested-attrs) #f]
|
|
[(hpat:seq lp) (pattern-has-cut? lp)]
|
|
[(hpat:action a hp) (or (pattern-has-cut? a) (pattern-has-cut? hp))]
|
|
[(hpat:describe hp _ _ _) (pattern-has-cut? hp)]
|
|
[(hpat:and hp sp) (or (pattern-has-cut? hp) (pattern-has-cut? sp))]
|
|
[(hpat:or _ ps _) (ormap pattern-has-cut? ps)]
|
|
[(hpat:delimit hp) #f]
|
|
[(hpat:commit hp) #f]
|
|
[(hpat:ord hp _ _) (pattern-has-cut? hp)]
|
|
[(hpat:post hp) (pattern-has-cut? hp)]
|
|
[(hpat:peek hp) (pattern-has-cut? hp)]
|
|
[(hpat:peek-not hp) (pattern-has-cut? hp)]
|
|
|
|
;; EH patterns
|
|
[(ehpat _ hp _ _) (pattern-has-cut? hp)]
|
|
))
|
|
|
|
;; ----
|
|
|
|
(define (create-pat:or ps)
|
|
(define attrss (map pattern-attrs ps))
|
|
(pat:or (union-iattrs attrss) ps attrss))
|
|
|
|
(define (create-hpat:or ps)
|
|
(define attrss (map pattern-attrs ps))
|
|
(hpat:or (union-iattrs attrss) ps attrss))
|
|
|
|
;; create-ehpat : HeadPattern RepConstraint Syntax -> EllipsisHeadPattern
|
|
(define (create-ehpat head repc head-stx)
|
|
(let* ([iattrs0 (pattern-attrs head)]
|
|
[iattrs (repc-adjust-attrs iattrs0 repc)])
|
|
(define nullable (hpat-nullable head))
|
|
(define unbounded-iterations?
|
|
(cond [(rep:once? repc) #f]
|
|
[(rep:optional? repc) #f]
|
|
[(rep:bounds? repc) (eq? (rep:bounds-max repc) +inf.0)]
|
|
[else #t]))
|
|
(when (and (eq? nullable 'yes) unbounded-iterations?)
|
|
(when #f (wrong-syntax head-stx "nullable ellipsis-head pattern"))
|
|
(when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" head-stx)))
|
|
(ehpat iattrs head repc (case nullable [(yes unknown) unbounded-iterations?] [(no) #f]))))
|
|
|
|
(define (repc-adjust-attrs iattrs repc)
|
|
(cond [(rep:once? repc)
|
|
iattrs]
|
|
[(rep:optional? repc)
|
|
(map attr-make-uncertain iattrs)]
|
|
[(or (rep:bounds? repc) (eq? #f repc))
|
|
(map increase-depth iattrs)]
|
|
[else
|
|
(error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
|
|
|
|
;; ----
|
|
|
|
(define (action/head-pattern->list-pattern p)
|
|
(cond [(action-pattern? p)
|
|
(pat:action p (pat:any))]
|
|
[(hpat:seq? p)
|
|
;; simplification: just extract list pattern from hpat:seq
|
|
(hpat:seq-inner p)]
|
|
[else
|
|
(pat:head p (pat:datum '()))]))
|
|
|
|
(define (action-pattern->single-pattern a)
|
|
(pat:action a (pat:any)))
|
|
|
|
(define (proper-list-pattern? p)
|
|
(or (and (pat:datum? p) (eq? (pat:datum-datum p) '()))
|
|
(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)))))
|
|
|
|
;; ----
|
|
|
|
(define-syntax-rule (define/memo (f x) body ...)
|
|
(define f
|
|
(let ([memo-table (make-weak-hasheq)])
|
|
(lambda (x)
|
|
(hash-ref! memo-table x (lambda () body ...))))))
|
|
|
|
;; ----
|
|
|
|
;; An AbsFail is a Nat encoding the bitvector { sub? : 1, post? : 1 }
|
|
;; Finite abstraction of failuresets based on progress bins. That is:
|
|
(define AF-NONE 0) ;; cannot fail
|
|
(define AF-SUB 1) ;; can fail with progress < POST
|
|
(define AF-POST 2) ;; can fail with progress >= POST
|
|
(define AF-ANY 3) ;; can fail with progress either < or >= POST
|
|
|
|
;; AF-nz? : AbsFail -> {0, 1}
|
|
(define (AF-nz? af) (if (= af AF-NONE) 0 1))
|
|
|
|
;; AF<? : AbsFail AbsFail -> Boolean
|
|
;; True if every failure in af1 has strictly less progress than any failure in af2.
|
|
;; Note: trivially satisfied if either side cannot fail.
|
|
(define (AF<? af1 af2)
|
|
;; (0, *), (*, 0), (1, 2)
|
|
(or (= af1 AF-NONE)
|
|
(= af2 AF-NONE)
|
|
(and (= af1 AF-SUB) (= af2 AF-POST))))
|
|
|
|
;; pattern-absfail : *Pattern -> AbsFail
|
|
(define/memo (pattern-AF p)
|
|
(define (patterns-AF ps)
|
|
(for/fold ([af 0]) ([p (in-list ps)]) (bitwise-ior af (pattern-AF p))))
|
|
(cond [(pat:any? p) AF-NONE]
|
|
[(pat:svar? p) AF-NONE]
|
|
[(pat:var/p? p) AF-ANY]
|
|
[(pat:literal? p) AF-SUB]
|
|
[(pat:datum? p) AF-SUB]
|
|
[(pat:action? p) (bitwise-ior (pattern-AF (pat:action-action p))
|
|
(pattern-AF (pat:action-inner p)))]
|
|
[(pat:head? p) AF-ANY]
|
|
[(pat:dots? p) AF-ANY]
|
|
[(pat:and? p) (patterns-AF (pat:and-patterns p))]
|
|
[(pat:or? p) (patterns-AF (pat:or-patterns p))]
|
|
[(pat:not? p) AF-SUB]
|
|
[(pat:pair? p) AF-SUB]
|
|
[(pat:vector? p) AF-SUB]
|
|
[(pat:box? p) AF-SUB]
|
|
[(pat:pstruct? p) AF-SUB]
|
|
[(pat:describe? p) (pattern-AF (pat:describe-pattern p))]
|
|
[(pat:delimit? p) (pattern-AF (pat:delimit-pattern p))]
|
|
[(pat:commit? p) (pattern-AF (pat:commit-pattern p))]
|
|
[(pat:reflect? p) AF-ANY]
|
|
[(pat:ord? p) (pattern-AF (pat:ord-pattern p))]
|
|
[(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)]
|
|
[(pat:integrated? p) AF-SUB]
|
|
;; Action patterns
|
|
[(action:cut? p) AF-NONE]
|
|
[(action:fail? p) AF-SUB]
|
|
[(action:bind? p) AF-NONE]
|
|
[(action:and? p) (patterns-AF (action:and-patterns p))]
|
|
[(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)]
|
|
[(action:do? p) AF-NONE]
|
|
[(action:ord? p) (pattern-AF (action:ord-pattern p))]
|
|
[(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)]
|
|
;; Head patterns, eh patterns, etc
|
|
[else AF-ANY]))
|
|
|
|
;; pattern-cannot-fail? : *Pattern -> Boolean
|
|
(define (pattern-cannot-fail? p)
|
|
(= (pattern-AF p) AF-NONE))
|
|
|
|
;; pattern-can-fail? : *Pattern -> Boolean
|
|
(define (pattern-can-fail? p)
|
|
(not (pattern-cannot-fail? p)))
|
|
|
|
;; patterns-AF-sorted? : (Listof *Pattern) -> AF/#f
|
|
;; Returns AbsFail (true) if any failure from pattern N+1 has strictly
|
|
;; greater progress than any failure from patterns 0 through N.
|
|
(define (patterns-AF-sorted? ps)
|
|
(for/fold ([af AF-NONE]) ([p (in-list ps)])
|
|
(define afp (pattern-AF p))
|
|
(and af (AF<? af afp) (bitwise-ior af afp))))
|
|
|
|
;; ----
|
|
|
|
;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean
|
|
;; Returns true if the disjunction of the patterns always succeeds---and thus no
|
|
;; failure-tracking needed. Note: beware cut!
|
|
(define (patterns-cannot-fail? patterns)
|
|
(and (not (ormap pattern-has-cut? patterns))
|
|
(ormap pattern-cannot-fail? patterns)))
|
|
|
|
;; ----
|
|
|
|
;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic)
|
|
|
|
(define (3and a b)
|
|
(case a
|
|
[(yes) b]
|
|
[(no) 'no]
|
|
[(unknown) (case b [(yes unknown) 'unknown] [(no) 'no])]))
|
|
|
|
(define (3or a b)
|
|
(case a
|
|
[(yes) 'yes]
|
|
[(no) b]
|
|
[(unknown) (case b [(yes) 'yes] [(no unknown) 'unknown])]))
|
|
|
|
(define (3andmap f xs) (foldl 3and 'yes (map f xs)))
|
|
(define (3ormap f xs) (foldl 3or 'no (map f xs)))
|
|
|
|
;; lpat-nullable : ListPattern -> AbsNullable
|
|
(define/memo (lpat-nullable lp)
|
|
(match lp
|
|
[(pat:datum '()) 'yes]
|
|
[(pat:action ap lp) (lpat-nullable lp)]
|
|
[(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))]
|
|
[(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)]
|
|
[(pat:any) #t]
|
|
[_ 'unknown]))
|
|
|
|
;; hpat-nullable : HeadPattern -> AbsNullable
|
|
(define/memo (hpat-nullable hp)
|
|
(match hp
|
|
[(hpat:seq lp) (lpat-nullable lp)]
|
|
[(hpat:action ap hp) (hpat-nullable hp)]
|
|
[(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))]
|
|
[(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)]
|
|
[(hpat:describe hp _ _ _) (hpat-nullable hp)]
|
|
[(hpat:delimit hp) (hpat-nullable hp)]
|
|
[(hpat:commit hp) (hpat-nullable hp)]
|
|
[(hpat:ord hp _ _) (hpat-nullable hp)]
|
|
[(hpat:post hp) (hpat-nullable hp)]
|
|
[(? pattern? hp) 'no]
|
|
[_ 'unknown]))
|
|
|
|
;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable
|
|
(define (ehpat-nullable ehp)
|
|
(match ehp
|
|
[(ehpat _ hp repc _)
|
|
(3or (repc-nullable repc) (hpat-nullable hp))]))
|
|
|
|
;; repc-nullable : RepConstraint -> AbsNullable
|
|
(define (repc-nullable repc)
|
|
(cond [(rep:once? repc) 'no]
|
|
[(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no]
|
|
[else 'yes]))
|
|
|
|
;; ----
|
|
|
|
;; create-post-pattern : *Pattern -> *Pattern
|
|
(define (create-post-pattern p)
|
|
(cond [(pattern-cannot-fail? p)
|
|
p]
|
|
[(pattern? p)
|
|
(pat:post p)]
|
|
[(head-pattern? p)
|
|
(hpat:post p)]
|
|
[(action-pattern? p)
|
|
(action:post p)]
|
|
[else (error 'syntax-parse "INTERNAL ERROR: create-post-pattern ~e" p)]))
|
|
|
|
;; create-ord-pattern : *Pattern UninternedSymbol Nat -> *Pattern
|
|
(define (create-ord-pattern p group index)
|
|
(cond [(pattern-cannot-fail? p)
|
|
p]
|
|
[(pattern? p)
|
|
(pat:ord p group index)]
|
|
[(head-pattern? p)
|
|
(hpat:ord p group index)]
|
|
[(action-pattern? p)
|
|
(action:ord p group index)]
|
|
[else (error 'syntax-parse "INTERNAL ERROR: create-ord-pattern ~e" p)]))
|
|
|
|
;; ord-and-patterns : (Listof *Pattern) UninternedSymbol -> (Listof *Pattern)
|
|
;; If at most one subpattern can fail, no need to wrap. More
|
|
;; generally, if possible failures are already consistent with and
|
|
;; ordering, no need to wrap.
|
|
(define (ord-and-patterns patterns group)
|
|
(cond [(patterns-AF-sorted? patterns) patterns]
|
|
[else
|
|
(for/list ([p (in-list patterns)] [index (in-naturals)])
|
|
(create-ord-pattern p group index))]))
|
|
|
|
;; create-action:and : (Listof ActionPattern) -> ActionPattern
|
|
(define (create-action:and actions)
|
|
(match actions
|
|
[(list action) action]
|
|
[_ (action:and actions)]))
|