1#lang racket/base 2(require syntax/parse/private/residual-ct ;; keep abs. path 3 "rep-attrs.rkt" 4 "minimatch.rkt" 5 "tree-util.rkt" 6 racket/syntax) 7(provide (all-defined-out)) 8 9;; Uses Arguments from kws.rkt 10 11;; ------------------------------------------------------------ 12;; Stage 1: Parsing, first pass 13 14;; Pattern parsing is done (in rep.rkt) in two passes. In pass 1, stxclass refs 15;; are not required to be bound, and so patterns like `x:sc` and `(~var x sc)` 16;; are left as "fixup" patterns to be resolved in pass 2. 17 18;; SinglePattern ::= 19;; | (pat:any) 20;; | (pat:svar id) -- "simple" var, no stxclass 21;; | (pat:var/p Id Id Arguments (Listof IAttr) Syntax SCOpts) -- var with parser 22;; | (pat:literal Id Syntax Syntax) 23;; | (pat:datum Datum) 24;; | (pat:action ActionPattern SinglePattern) 25;; | (pat:head HeadPattern SinglePattern) 26;; | (pat:dots (listof EllipsisHeadPattern) SinglePattern) 27;; | (pat:andu (Listof (U SinglePattern ActionPattern))) 28;; | (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr))) 29;; | (pat:not SinglePattern) 30;; | (pat:vector SinglePattern) 31;; | (pat:box SinglePattern) 32;; | (pat:pstruct key SinglePattern) 33;; | (pat:describe SinglePattern Syntax Boolean Syntax) 34;; | (pat:delimit SinglePattern) 35;; | (pat:commit SinglePattern) 36;; | (pat:reflect stx Arguments (listof SAttr) id (listof IAttr)) 37;; | (pat:post SinglePattern) 38;; | (pat:integrated Id/#f Id String Syntax) 39;; | (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f) 40;; | (pat:and/fixup Syntax (Listof (U {S,H,A}Pattern))) 41 42;; ListPattern ::= 43;; | (pat:datum '()) 44;; | (pat:action ActionPattern ListPattern) 45;; | (pat:head HeadPattern ListPattern) 46;; | (pat:pair SinglePattern ListPattern) 47;; | (pat:dots EllipsisHeadPattern ListPattern) 48 49;; ActionPattern ::= 50;; | (action:cut) 51;; | (action:fail Syntax Syntax) 52;; | (action:bind IAttr Syntax) 53;; | (action:and (Listof ActionPattern)) 54;; | (action:parse SinglePattern Syntax) 55;; | (action:do (Listof Syntax)) 56;; | (action:undo (Listof Syntax)) 57;; | (action:post ActionPattern) 58 59;; HeadPattern ::= 60;; | (hpat:single SinglePattern) 61;; | (hpat:var/p Id Id Arguments (Listof IAttr) Syntax SCOpts) 62;; | (hpat:seq ListPattern) 63;; | (hpat:action ActionPattern HeadPattern) 64;; | (hpat:andu (Listof (U Headpattern ActionPattern))) -- at least one HeadPattern 65;; | (hpat:or (Listof IAttr) (Listof HeadPattern) (Listof (Listof IAttr))) 66;; | (hpat:describe HeadPattern Syntax/#f Boolean Syntax) 67;; | (hpat:delimit HeadPattern) 68;; | (hpat:commit HeadPattern) 69;; | (hpat:reflect Syntax Arguments (Listof SAttr) Id (Listof IAttr)) 70;; | (hpat:post HeadPattern) 71;; | (hpat:peek HeadPattern) 72;; | (hpat:peek-not HeadPattern) 73 74;; EllipsisHeadPattern ::= 75;; | (ehpat (Listof IAttr) HeadPattern RepConstraint Boolean) 76 77;; RepConstraint ::= 78;; | (rep:once Syntax Syntax Syntax) 79;; | (rep:optional Syntax Syntax (Listof BindAction)) 80;; | (rep:bounds Nat PosInt/+inf.0 Syntax Syntax Syntax) 81;; | #f 82 83;; BindAction ::= (action:bind IAttr Syntax) 84;; SideClause ::= ActionPattern 85 86;; ------------------------------------------------------------ 87;; Stage 2: Parsing, pass 2 88 89;; SinglePattern ::= .... 90;; X (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f) 91;; X (pat:and/fixup Syntax (Listof (U {S,H,A}Pattern))) 92 93;; Note: pat:action can change to hpat:action; pat:andu cannot change. 94 95;; ------------------------------------------------------------ 96;; Stage 3: Specialize pair patterns 97 98;; Rewrite (pat:head (hpat:single headp) tailp) => (pat:pair headp tailp). 99;; Rewrite (pat:head (hpat:seq lp[end]) tailp) -> lp[tailp]. 100 101;; FIXME/TODO: also do the following: 102;; - add pat:seq-end 103;; - rewrite (pat:head (hpat:seq (pat:head h1 t1)) t2) => (pat:head h1 (pat:head (hpat:seq t1) t2)) 104 105;; SinglePattern ::= .... 106;; + (pat:pair SinglePattern SinglePattern) 107 108;; ListPattern ::= 109;; + (pat:pair SinglePattern ListPattern) 110 111;; ------------------------------------------------------------ 112;; Stage 4a: Normalize and patterns 113 114;; SinglePattern ::= .... 115;; X (pat:action ActionPattern SinglePattern) 116 117;; ActionPattern ::= .... 118;; X (action:and (Listof ActionPattern)) 119 120;; HeadPattern ::= 121;; X (hpat:action ActionPattern HeadPattern) 122 123;; ------------------------------------------------------------ 124;; Stage 4b: Add *:ord wrappers for *:and components 125 126;; SinglePattern ::= .... 127;; X (pat:andu (Listof (U SinglePattern ActionPattern))) 128;; + (pat:action ActionPattern SinglePattern) 129;; + (pat:and (Listof SinglePattern)) 130;; + (pat:ord SinglePattern UninternedSymbol Nat) 131 132;; ActionPattern ::= .... 133;; + (action:ord ActionPattern UninternedSymbol Nat) 134;; + (action:and (Listof ActionPattern)) 135 136;; HeadPattern ::= .... 137;; X (hpat:andu (Listof (U HeadPattern ActionPattern))) 138;; + (hpat:action ActionPattern HeadPattern) 139;; + (hpat:and HeadPattern SinglePattern) 140;; + (hpat:ord HeadPattern UninternedSymbol Nat) 141 142;; ------------------------------------------------------------ 143;; Stage 5: Switch to pat:seq-end in list patterns 144 145;; ListPattern ::= ... 146;; X (pat:datum '()) 147;; + (pat:seq-end) 148 149;; ------------------------------------------------------------ 150 151(define-struct pat:any () #:prefab) 152(define-struct pat:svar (name) #:prefab) 153(define-struct pat:var/p (name parser argu nested-attrs role opts) #:prefab) 154(define-struct pat:literal (id input-phase lit-phase) #:prefab) 155(define-struct pat:datum (datum) #:prefab) 156(define-struct pat:action (action inner) #:prefab) 157(define-struct pat:head (head tail) #:prefab) 158(define-struct pat:dots (heads tail) #:prefab) 159(define-struct pat:andu (patterns) #:prefab) 160(define-struct pat:and (patterns) #:prefab) 161(define-struct pat:or (attrs patterns attrss) #:prefab) 162(define-struct pat:not (pattern) #:prefab) 163(define-struct pat:pair (head tail) #:prefab) 164(define-struct pat:vector (pattern) #:prefab) 165(define-struct pat:box (pattern) #:prefab) 166(define-struct pat:pstruct (key pattern) #:prefab) 167(define-struct pat:describe (pattern description transparent? role) #:prefab) 168(define-struct pat:delimit (pattern) #:prefab) 169(define-struct pat:commit (pattern) #:prefab) 170(define-struct pat:reflect (obj argu attr-decls name nested-attrs) #:prefab) 171(define-struct pat:ord (pattern group index) #:prefab) 172(define-struct pat:post (pattern) #:prefab) 173(define-struct pat:integrated (name predicate description role) #:prefab) 174(define-struct pat:fixup (stx bind varname scname argu sep role parser*) #:prefab) 175(define-struct pat:and/fixup (stx patterns) #:prefab) 176(define-struct pat:seq-end () #:prefab) 177 178(define-struct action:cut () #:prefab) 179(define-struct action:fail (when message) #:prefab) 180(define-struct action:bind (attr expr) #:prefab) 181(define-struct action:and (patterns) #:prefab) 182(define-struct action:parse (pattern expr) #:prefab) 183(define-struct action:do (stmts) #:prefab) 184(define-struct action:undo (stmts) #:prefab) 185(define-struct action:ord (pattern group index) #:prefab) 186(define-struct action:post (pattern) #:prefab) 187 188(define-struct hpat:single (pattern) #:prefab) 189(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab) 190(define-struct hpat:seq (inner) #:prefab) 191(define-struct hpat:action (action inner) #:prefab) 192(define-struct hpat:andu (patterns) #:prefab) 193(define-struct hpat:and (head single) #:prefab) 194(define-struct hpat:or (attrs patterns attrss) #:prefab) 195(define-struct hpat:describe (pattern description transparent? role) #:prefab) 196(define-struct hpat:delimit (pattern) #:prefab) 197(define-struct hpat:commit (pattern) #:prefab) 198(define-struct hpat:reflect (obj argu attr-decls name nested-attrs) #:prefab) 199(define-struct hpat:ord (pattern group index) #:prefab) 200(define-struct hpat:post (pattern) #:prefab) 201(define-struct hpat:peek (pattern) #:prefab) 202(define-struct hpat:peek-not (pattern) #:prefab) 203 204(define-struct ehpat (attrs head repc check-null?) #:prefab) 205(define-struct rep:once (name under-message over-message) #:prefab) 206(define-struct rep:optional (name over-message defaults) #:prefab) 207(define-struct rep:bounds (min max name under-message over-message) #:prefab) 208 209;; ============================================================ 210 211(define (single-pattern? x) 212 (or (pat:any? x) 213 (pat:svar? x) 214 (pat:var/p? x) 215 (pat:literal? x) 216 (pat:datum? x) 217 (pat:action? x) 218 (pat:head? x) 219 (pat:dots? x) 220 (pat:andu? x) 221 (pat:and? x) 222 (pat:or? x) 223 (pat:not? x) 224 (pat:pair? x) 225 (pat:vector? x) 226 (pat:box? x) 227 (pat:pstruct? x) 228 (pat:describe? x) 229 (pat:delimit? x) 230 (pat:commit? x) 231 (pat:reflect? x) 232 (pat:ord? x) 233 (pat:post? x) 234 (pat:integrated? x) 235 (pat:fixup? x) 236 (pat:and/fixup? x) 237 (pat:seq-end? x))) 238 239(define (action-pattern? x) 240 (or (action:cut? x) 241 (action:bind? x) 242 (action:fail? x) 243 (action:and? x) 244 (action:parse? x) 245 (action:do? x) 246 (action:undo? x) 247 (action:ord? x) 248 (action:post? x))) 249 250(define (head-pattern? x) 251 (or (hpat:single? x) 252 (hpat:var/p? x) 253 (hpat:seq? x) 254 (hpat:action? x) 255 (hpat:andu? x) 256 (hpat:and? x) 257 (hpat:or? x) 258 (hpat:describe? x) 259 (hpat:delimit? x) 260 (hpat:commit? x) 261 (hpat:reflect? x) 262 (hpat:ord? x) 263 (hpat:post? x) 264 (hpat:peek? x) 265 (hpat:peek-not? x))) 266 267(define (ellipsis-head-pattern? x) 268 (ehpat? x)) 269 270(define (single-or-head-pattern? x) 271 (or (single-pattern? x) 272 (head-pattern? x))) 273 274(define (*pattern? x) 275 (and (struct? x) 276 (or (single-pattern? x) 277 (action-pattern? x) 278 (head-pattern? x) 279 (ellipsis-head-pattern? x)))) 280 281;; ============================================================ 282 283(define (wf-S? x) 284 (match x 285 [(pat:any) #t] 286 [(pat:svar name) #t] 287 [(pat:var/p name parser argu nested-attrs role opts) #t] 288 [(pat:literal id input-phase lit-phase) #t] 289 [(pat:datum datum) #t] 290 [(pat:action ap sp) (and (wf-A? ap) (wf-S? sp))] 291 [(pat:head headp tailp) (and (wf-H? headp) (wf-S? tailp))] 292 [(pat:dots heads tailp) (and (andmap wf-EH? heads) (wf-S? tailp))] 293 [(pat:andu ps) (andmap wf-A/S? ps)] 294 [(pat:and ps) (andmap wf-S? ps)] 295 [(pat:or attrs ps attrss) (andmap wf-S? ps)] 296 [(pat:not sp) (wf-S? sp)] 297 [(pat:pair headp tailp) (and (wf-S? headp) (wf-S? tailp))] 298 [(pat:vector sp) (wf-S? sp)] 299 [(pat:box sp) (wf-S? sp)] 300 [(pat:pstruct key sp) (wf-S? sp)] 301 [(pat:describe sp description transparent? role) (wf-S? sp)] 302 [(pat:delimit sp) (wf-S? sp)] 303 [(pat:commit sp) (wf-S? sp)] 304 [(pat:reflect obj argu attr-decls name nested-attrs) #t] 305 [(pat:ord sp group index) (wf-S? sp)] 306 [(pat:post sp) (wf-S? sp)] 307 [(pat:integrated name predicate description role) #t] 308 [(pat:fixup stx bind varname scname argu sep role parser*) #t] 309 [(pat:and/fixup stx ps) (andmap wf-A/S/H? ps)] 310 [(pat:seq-end) #f] ;; Should only occur in ListPattern! 311 [_ #f])) 312 313(define (wf-L? x) 314 (match x 315 [(pat:datum '()) #t] 316 [(pat:seq-end) #t] 317 [(pat:action ap sp) (and (wf-A? ap) (wf-L? sp))] 318 [(pat:head headp tailp) (and (wf-H? headp) (wf-L? tailp))] 319 [(pat:dots heads tailp) (and (andmap wf-EH? heads) (wf-L? tailp))] 320 [(pat:pair headp tailp) (and (wf-S? headp) (wf-L? tailp))] 321 [_ #f])) 322 323(define (wf-A? x) 324 (match x 325 [(action:cut) #t] 326 [(action:fail cnd msg) #t] 327 [(action:bind attr expr) #t] 328 [(action:and ps) (andmap wf-A? ps)] 329 [(action:parse sp expr) (wf-S? sp)] 330 [(action:do stmts) #t] 331 [(action:undo stmts) #t] 332 [(action:ord sp group index) (wf-A? sp)] 333 [(action:post sp) (wf-A? sp)] 334 [_ #f])) 335 336(define (wf-H? x) 337 (match x 338 [(hpat:single sp) (wf-S? sp)] 339 [(hpat:var/p name parser argu nested-attrs role scopts) #t] 340 [(hpat:seq sp) (wf-L? sp)] 341 [(hpat:action ap sp) (and (wf-A? ap) (wf-H? sp))] 342 [(hpat:andu ps) (andmap wf-A/H? ps)] 343 [(hpat:and hp sp) (and (wf-H? hp) (wf-S? sp))] 344 [(hpat:or attrs ps attrss) (andmap wf-H? ps)] 345 [(hpat:describe sp description transparent? role) (wf-H? sp)] 346 [(hpat:delimit sp) (wf-H? sp)] 347 [(hpat:commit sp) (wf-H? sp)] 348 [(hpat:reflect obj argu attr-decls name nested-attrs) #t] 349 [(hpat:ord sp group index) (wf-H? sp)] 350 [(hpat:post sp) (wf-H? sp)] 351 [(hpat:peek sp) (wf-H? sp)] 352 [(hpat:peek-not sp) (wf-H? sp)] 353 [_ #f])) 354 355(define (wf-EH? x) 356 (match x 357 [(ehpat _ hp _ _) (wf-H? hp)] 358 [_ #f])) 359 360(define (wf-A/S? p) 361 (cond [(action-pattern? p) (wf-A? p)] 362 [(single-pattern? p) (wf-S? p)] 363 [else #f])) 364 365(define (wf-A/H? p) 366 (cond [(action-pattern? p) (wf-A? p)] 367 [(head-pattern? p) (wf-H? p)] 368 [else #f])) 369 370(define (wf-A/S/H? p) 371 (cond [(action-pattern? p) (wf-A? p)] 372 [(single-pattern? p) (wf-S? p)] 373 [(head-pattern? p) (wf-H? p)] 374 [else #f])) 375 376;; ============================================================ 377 378;; pattern-transform : *Pattern (*Pattern -> *Pattern) -> *Pattern 379(define (pattern-transform p for-pattern [root? #t]) 380 (define (for-node x) (if (*pattern? x) (for-pattern x) x)) 381 (tree-transform p for-node root?)) 382 383;; pattern-transform-preorder : *Pattern (*Pattern (X -> X) -> *Pattern) -> *Pattern 384(define (pattern-transform-preorder p for-pattern [root? #t]) 385 (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur))) 386 (tree-transform-preorder p for-node root?)) 387 388;; pattern-reduce{,-left} : *Pattern (*Pattern -> X) (X ... -> X) -> X 389(define (pattern-reduce p for-pattern reduce [root? #t]) 390 (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur))) 391 (tree-reduce p for-node reduce root?)) 392(define (pattern-reduce-left p for-pattern reduce [root? #t]) 393 (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur))) 394 (tree-reduce-left p for-node reduce root?)) 395 396;; pattern-ormap : *Pattern (*Pattern -> X/#f) -> X/#f 397(define (pattern-ormap p for-pattern [root? #t]) 398 (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur))) 399 (tree-ormap p for-node root?)) 400 401;; ============================================================ 402 403(define pattern? single-pattern?) 404 405(define (coerce-head-pattern p) 406 (if (head-pattern? p) p (hpat:single p))) 407 408(define (head-pattern-not-single? hp) 409 (and (head-pattern? hp) (not (hpat:single? hp)))) 410 411;; check-pattern : *Pattern -> *Pattern 412;; Does attr computation to catch errors, but returns same pattern. 413(define (check-pattern p) 414 (void (pattern-attrs p)) 415 p) 416 417;; pattern-attrs-table : Hasheq[*Pattern => (Listof IAttr)] 418(define pattern-attrs-table (make-weak-hasheq)) 419 420;; pattern-attrs : *Pattern -> (Listof IAttr) 421(define (pattern-attrs p) 422 (define (for-pattern p recur) 423 (hash-ref! pattern-attrs-table p (lambda () (for-pattern* p recur)))) 424 (define (for-pattern* p recur) 425 (match p 426 ;; -- S patterns 427 [(pat:svar name) 428 (list (attr name 0 #t))] 429 [(pat:var/p name _ _ nested-attrs _ _) 430 (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] 431 [(pat:reflect _ _ _ name nested-attrs) 432 (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] 433 [(pat:or iattrs ps _) 434 iattrs] 435 [(pat:not _) 436 null] 437 [(pat:integrated name _ _ _) 438 (if name (list (attr name 0 #t)) null)] 439 [(pat:fixup _ bind _ _ _ _ _ _) 440 (if bind (list (attr bind 0 #t)) null)] 441 ;; -- A patterns 442 [(action:bind attr expr) 443 (list attr)] 444 ;; -- H patterns 445 [(hpat:var/p name _ _ nested-attrs _ _) 446 (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] 447 [(hpat:reflect _ _ _ name nested-attrs) 448 (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] 449 [(hpat:or iattrs ps _) 450 iattrs] 451 [(hpat:peek-not _) 452 null] 453 ;; EH patterns 454 [(ehpat iattrs _ _ _) 455 iattrs] 456 [_ (recur)])) 457 (pattern-reduce p for-pattern (lambda iattrss (append-iattrs iattrss)))) 458 459;; ------------------------------------------------------------ 460 461;; pattern-has-cut? : *Pattern -> Boolean 462;; Returns #t if p *might* cut (~!, not within ~delimit-cut). 463(define (pattern-has-cut? p) 464 (define (for-pattern p recur) 465 (match p 466 [(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))] 467 [(pat:not _) #f] 468 [(pat:delimit _) #f] 469 [(pat:commit _) #f] 470 [(pat:fixup _ _ _ _ _ _ _ _) #t] 471 [(action:cut) #t] 472 [(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))] 473 [(hpat:delimit _) #f] 474 [(hpat:commit _) #f] 475 [_ (recur)])) 476 (pattern-reduce p for-pattern (lambda xs (ormap values xs)))) 477 478;; ============================================================ 479 480(define (create-pat:or ps) 481 (define attrss (map pattern-attrs ps)) 482 (pat:or (union-iattrs attrss) ps attrss)) 483 484(define (create-hpat:or ps) 485 (define attrss (map pattern-attrs ps)) 486 (hpat:or (union-iattrs attrss) ps attrss)) 487 488;; create-ehpat : HeadPattern RepConstraint Syntax -> EllipsisHeadPattern 489(define (create-ehpat head repc head-stx) 490 (let* ([iattrs0 (pattern-attrs head)] 491 [iattrs (repc-adjust-attrs iattrs0 repc)]) 492 (define nullable (hpat-nullable head)) 493 (define unbounded-iterations? 494 (cond [(rep:once? repc) #f] 495 [(rep:optional? repc) #f] 496 [(rep:bounds? repc) (eq? (rep:bounds-max repc) +inf.0)] 497 [else #t])) 498 (when (and (eq? nullable 'yes) unbounded-iterations?) 499 (when #f (wrong-syntax head-stx "nullable ellipsis-head pattern")) 500 (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" head-stx))) 501 (ehpat iattrs head repc (case nullable [(yes unknown) unbounded-iterations?] [(no) #f])))) 502 503(define (repc-adjust-attrs iattrs repc) 504 (cond [(rep:once? repc) 505 iattrs] 506 [(rep:optional? repc) 507 (map attr-make-uncertain iattrs)] 508 [(or (rep:bounds? repc) (eq? #f repc)) 509 (map increase-depth iattrs)] 510 [else 511 (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)])) 512 513;; ---- 514 515(define (action/head-pattern->list-pattern p) 516 (cond [(action-pattern? p) 517 (pat:action p (pat:any))] 518 [(hpat:seq? p) 519 ;; simplification: just extract list pattern from hpat:seq 520 (hpat:seq-inner p)] 521 [else 522 (pat:head p (pat:datum '()))])) 523 524(define (action-pattern->single-pattern a) 525 (pat:action a (pat:any))) 526 527(define (proper-list-pattern? p) 528 (or (and (pat:datum? p) (eq? (pat:datum-datum p) '())) 529 (and (pat:pair? p) (proper-list-pattern? (pat:pair-tail p))) 530 (and (pat:head? p) (proper-list-pattern? (pat:head-tail p))) 531 (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p))) 532 (and (pat:action? p) (proper-list-pattern? (pat:action-inner p))))) 533 534;; ---- 535 536(define-syntax-rule (define/memo (f x) body ...) 537 (define f 538 (let ([memo-table (make-weak-hasheq)]) 539 (lambda (x) 540 (hash-ref! memo-table x (lambda () body ...)))))) 541 542;; ============================================================ 543 544;; An AbsFail is a Nat encoding the bitvector { sub? : 1, post? : 1 } 545;; Finite abstraction of failuresets based on progress bins. That is: 546(define AF-NONE 0) ;; cannot fail 547(define AF-SUB 1) ;; can fail with progress < POST 548(define AF-POST 2) ;; can fail with progress >= POST 549(define AF-ANY 3) ;; can fail with progress either < or >= POST 550 551;; AF-nz? : AbsFail -> Boolean 552(define (AF-nz? af) (not (= af AF-NONE))) 553 554;; AF<? : AbsFail AbsFail -> Boolean 555;; True if every failure in af1 has strictly less progress than any failure in af2. 556;; Note: trivially satisfied if either side cannot fail. 557(define (AF<? af1 af2) 558 ;; (0, *), (*, 0), (1, 2) 559 (or (= af1 AF-NONE) 560 (= af2 AF-NONE) 561 (and (= af1 AF-SUB) (= af2 AF-POST)))) 562 563;; pattern-AF-table : Hasheq[*Pattern => AbsFail] 564(define pattern-AF-table (make-weak-hasheq)) 565 566;; pattern-AF : *Pattern -> AbsFail 567(define (pattern-AF p) 568 (define (for-pattern p recur) 569 (hash-ref pattern-AF-table p (lambda () (for-pattern* p recur)))) 570 (define (for-pattern* p recur) 571 (cond [(pat:var/p? p) AF-ANY] 572 [(pat:literal? p) AF-SUB] 573 [(pat:datum? p) AF-SUB] 574 [(pat:head? p) AF-ANY] 575 [(pat:dots? p) AF-ANY] 576 [(pat:not? p) AF-SUB] 577 [(pat:pair? p) AF-SUB] 578 [(pat:vector? p) AF-SUB] 579 [(pat:box? p) AF-SUB] 580 [(pat:pstruct? p) AF-SUB] 581 [(pat:reflect? p) AF-ANY] 582 [(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)] 583 [(pat:integrated? p) AF-SUB] 584 [(action:fail? p) AF-SUB] 585 [(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)] 586 [(action:ord? p) (pattern-AF (action:ord-pattern p))] 587 [(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)] 588 [(head-pattern? p) AF-ANY] ;; this case should not be reachable 589 [else (recur)])) 590 (pattern-reduce-left p for-pattern bitwise-ior)) 591 592;; pattern-cannot-fail? : *Pattern -> Boolean 593(define (pattern-cannot-fail? p) 594 (= (pattern-AF p) AF-NONE)) 595 596;; pattern-can-fail? : *Pattern -> Boolean 597(define (pattern-can-fail? p) 598 (not (pattern-cannot-fail? p))) 599 600;; patterns-AF-sorted? : (Listof *Pattern) -> AF/#f 601;; Returns AbsFail (true) if any failure from pattern N+1 has strictly 602;; greater progress than any failure from patterns 0 through N. 603(define (patterns-AF-sorted? ps) 604 (for/fold ([af AF-NONE]) ([p (in-list ps)]) 605 (define afp (pattern-AF p)) 606 (and af (AF<? af afp) (bitwise-ior af afp)))) 607 608;; ---- 609 610;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean 611;; Returns true if the disjunction of the patterns always succeeds---and thus no 612;; failure-tracking needed. Note: beware cut! 613(define (patterns-cannot-fail? patterns) 614 (and (not (ormap pattern-has-cut? patterns)) 615 (ormap pattern-cannot-fail? patterns))) 616 617;; ============================================================ 618 619;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic) 620 621(define (3and a b) 622 (case a 623 [(yes) b] 624 [(no) 'no] 625 [(unknown) (case b [(yes unknown) 'unknown] [(no) 'no])])) 626 627(define (3or a b) 628 (case a 629 [(yes) 'yes] 630 [(no) b] 631 [(unknown) (case b [(yes) 'yes] [(no unknown) 'unknown])])) 632 633(define (3andmap f xs) (foldl 3and 'yes (map f xs))) 634(define (3ormap f xs) (foldl 3or 'no (map f xs))) 635 636;; lpat-nullable : ListPattern -> AbsNullable 637(define/memo (lpat-nullable lp) 638 (match lp 639 [(pat:datum '()) 'yes] 640 [(pat:action ap lp) (lpat-nullable lp)] 641 [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))] 642 [(pat:pair sp lp) 'no] 643 [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))] 644 ;; For hpat:and, handle the following which are not ListPatterns 645 [(pat:andu lps) (3andmap lpat-nullable (filter single-pattern? lps))] 646 [(pat:and lps) (3andmap lpat-nullable lps)] 647 [(pat:any) #t] 648 [_ 'unknown])) 649 650;; hpat-nullable : HeadPattern -> AbsNullable 651(define/memo (hpat-nullable hp) 652 (match hp 653 [(hpat:single sp) 'no] 654 [(hpat:seq lp) (lpat-nullable lp)] 655 [(hpat:action ap hp) (hpat-nullable hp)] 656 [(hpat:andu ps) (3andmap hpat-nullable (filter head-pattern? ps))] 657 [(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))] 658 [(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)] 659 [(hpat:describe hp _ _ _) (hpat-nullable hp)] 660 [(hpat:delimit hp) (hpat-nullable hp)] 661 [(hpat:commit hp) (hpat-nullable hp)] 662 [(hpat:ord hp _ _) (hpat-nullable hp)] 663 [(hpat:post hp) (hpat-nullable hp)] 664 [_ 'unknown])) 665 666;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable 667(define (ehpat-nullable ehp) 668 (match ehp 669 [(ehpat _ hp repc _) 670 (3or (repc-nullable repc) (hpat-nullable hp))])) 671 672;; repc-nullable : RepConstraint -> AbsNullable 673(define (repc-nullable repc) 674 (cond [(rep:once? repc) 'no] 675 [(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no] 676 [else 'yes])) 677 678;; ============================================================ 679 680;; create-post-pattern : *Pattern -> *Pattern 681(define (create-post-pattern p) 682 (cond [(pattern-cannot-fail? p) 683 p] 684 [(pattern? p) 685 (pat:post p)] 686 [(head-pattern? p) 687 (hpat:post p)] 688 [(action-pattern? p) 689 (action:post p)] 690 [else (error 'syntax-parse "INTERNAL ERROR: create-post-pattern ~e" p)])) 691 692;; create-ord-pattern : *Pattern UninternedSymbol Nat -> *Pattern 693(define (create-ord-pattern p group index) 694 (cond [(pattern-cannot-fail? p) 695 p] 696 [(single-pattern? p) 697 (pat:ord p group index)] 698 [(head-pattern? p) 699 (hpat:ord p group index)] 700 [(action-pattern? p) 701 (action:ord p group index)] 702 [else (error 'syntax-parse "INTERNAL ERROR: create-ord-pattern ~e" p)])) 703 704;; ord-and-patterns : (Listof *Pattern) UninternedSymbol -> (Listof *Pattern) 705;; If at most one subpattern can fail, no need to wrap. More 706;; generally, if possible failures are already consistent with and 707;; ordering, no need to wrap. 708(define (ord-and-patterns patterns group) 709 (cond [(patterns-AF-sorted? patterns) patterns] 710 [else 711 (for/list ([p (in-list patterns)] [index (in-naturals)]) 712 (create-ord-pattern p group index))])) 713