parse.rkt (57262B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 syntax/stx 4 syntax/private/id-table 5 syntax/keyword 6 racket/syntax 7 syntax/parse/private/minimatch 8 syntax/parse/private/rep-attrs 9 syntax/parse/private/rep-data 10 syntax/parse/private/rep-patterns 11 "rep.rkt" 12 syntax/parse/private/kws 13 "opt.rkt" 14 "txlift.rkt") 15 syntax/parse/private/keywords 16 racket/syntax 17 racket/stxparam 18 syntax/stx 19 stxparse-info/parse/private/residual ;; keep abs. path 20 "runtime.rkt" 21 stxparse-info/parse/private/runtime-reflect) ;; keep abs. path 22 23 ;; ============================================================ 24 25 (provide define-syntax-class 26 define-splicing-syntax-class 27 define-integrable-syntax-class 28 syntax-parse 29 syntax-parser 30 define/syntax-parse 31 syntax-parser/template 32 parser/rhs 33 define-eh-alternative-set 34 (for-syntax rhs->parser)) 35 36 (begin-for-syntax 37 ;; constant-desc : Syntax -> String/#f 38 (define (constant-desc stx) 39 (syntax-case stx (quote) 40 [(quote datum) 41 (let ([d (syntax-e #'datum)]) 42 (and (string? d) d))] 43 [expr 44 (let ([d (syntax-e #'expr)]) 45 (and (string? d) 46 (free-identifier=? #'#%datum (datum->syntax #'expr '#%datum)) 47 d))])) 48 49 (define (tx:define-*-syntax-class stx splicing?) 50 (syntax-case stx () 51 [(_ header . rhss) 52 (parameterize ((current-syntax-context stx)) 53 (let-values ([(name formals arity) 54 (let ([p (check-stxclass-header #'header stx)]) 55 (values (car p) (cadr p) (caddr p)))]) 56 (let ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)]) 57 (with-syntax ([name name] 58 [formals formals] 59 [desc (cond [(rhs-description the-rhs) => constant-desc] 60 [else (symbol->string (syntax-e name))])] 61 [parser (generate-temporary (format-symbol "parse-~a" name))] 62 [arity arity] 63 [attrs (rhs-attrs the-rhs)] 64 [commit? (rhs-commit? the-rhs)] 65 [delimit-cut? (rhs-delimit-cut? the-rhs)]) 66 #`(begin (define-syntax name 67 (stxclass 'name 'arity 68 'attrs 69 (quote-syntax parser) 70 '#,splicing? 71 (scopts (length 'attrs) 'commit? 'delimit-cut? desc) 72 #f)) 73 (define-values (parser) 74 (parser/rhs name formals attrs rhss #,splicing? #,stx)))))))]))) 75 76 (define-syntax define-syntax-class 77 (lambda (stx) (tx:define-*-syntax-class stx #f))) 78 (define-syntax define-splicing-syntax-class 79 (lambda (stx) (tx:define-*-syntax-class stx #t))) 80 81 (define-syntax (define-integrable-syntax-class stx) 82 (syntax-case stx (quote) 83 [(_ name (quote description) predicate) 84 (with-syntax ([parser (generate-temporary (format-symbol "parse-~a" (syntax-e #'name)))] 85 [no-arity no-arity]) 86 #'(begin (define-syntax name 87 (stxclass 'name no-arity '() 88 (quote-syntax parser) 89 #f 90 (scopts 0 #t #t 'description) 91 (quote-syntax predicate))) 92 (define (parser x cx pr es undos fh0 cp0 rl success) 93 (if (predicate x) 94 (success fh0 undos) 95 (let ([es (es-add-thing pr 'description #t rl es)]) 96 (fh0 undos (failure* pr es)))))))])) 97 98 (define-syntax (parser/rhs stx) 99 (syntax-case stx () 100 [(parser/rhs name formals relsattrs rhss splicing? ctx) 101 (with-disappeared-uses 102 (let () 103 (define the-rhs 104 (parameterize ((current-syntax-context #'ctx)) 105 (parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?) 106 #:context #'ctx))) 107 (rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?) #'ctx)))])) 108 109 (begin-for-syntax 110 (define (rhs->parser name formals relsattrs the-rhs splicing? [ctx #f]) 111 (define-values (transparent? description variants defs commit? delimit-cut?) 112 (match the-rhs 113 [(rhs _ transparent? description variants defs commit? delimit-cut?) 114 (values transparent? description variants defs commit? delimit-cut?)])) 115 (define vdefss (map variant-definitions variants)) 116 (define formals* (rewrite-formals formals #'x #'rl)) 117 (define patterns (map variant-pattern variants)) 118 (define no-fail? 119 (and (not splicing?) ;; FIXME: commit? needed? 120 (patterns-cannot-fail? patterns))) 121 (when no-fail? (log-syntax-parse-debug "(stxclass) cannot fail: ~e" ctx)) 122 (define body 123 (cond [(null? patterns) 124 #'(fail (failure* pr es))] 125 [splicing? 126 (with-syntax ([(alternative ...) 127 (for/list ([pattern (in-list patterns)]) 128 (with-syntax ([pattern pattern] 129 [relsattrs relsattrs] 130 [iattrs (pattern-attrs pattern)] 131 [commit? commit?] 132 [result-pr 133 (if transparent? 134 #'rest-pr 135 #'(ps-pop-opaque rest-pr))]) 136 #'(parse:H x cx rest-x rest-cx rest-pr pattern pr es 137 (variant-success relsattrs iattrs (rest-x rest-cx result-pr) 138 success cp0 commit?))))]) 139 #'(try alternative ...))] 140 [else 141 (with-syntax ([matrix 142 (optimize-matrix 143 (for/list ([pattern (in-list patterns)]) 144 (with-syntax ([iattrs (pattern-attrs pattern)] 145 [relsattrs relsattrs] 146 [commit? commit?]) 147 (pk1 (list pattern) 148 #'(variant-success relsattrs iattrs () 149 success cp0 commit?)))))]) 150 #'(parse:matrix ((x cx pr es)) matrix))])) 151 (with-syntax ([formals* formals*] 152 [(def ...) defs] 153 [((vdef ...) ...) vdefss] 154 [description (or description (symbol->string (syntax-e name)))] 155 [transparent? transparent?] 156 [delimit-cut? delimit-cut?] 157 [body body]) 158 #`(lambda (x cx pr es undos fh0 cp0 rl success . formals*) 159 (with ([this-syntax x] 160 [this-role rl]) 161 def ... 162 vdef ... ... 163 (#%expression 164 (syntax-parameterize ((this-context-syntax 165 (syntax-rules () 166 [(tbs) (ps-context-syntax pr)]))) 167 (let ([es (es-add-thing pr description 'transparent? rl 168 #,(if no-fail? #'#f #'es))] 169 [pr (if 'transparent? pr (ps-add-opaque pr))]) 170 (with ([fail-handler fh0] 171 [cut-prompt cp0] 172 [undo-stack undos]) 173 ;; Update the prompt, if required 174 ;; FIXME: can be optimized away if no cut exposed within variants 175 (with-maybe-delimit-cut delimit-cut? 176 body)))))))))) 177 178 (define-syntax (syntax-parse stx) 179 (syntax-case stx () 180 [(syntax-parse stx-expr . clauses) 181 (quasisyntax/loc stx 182 (let ([x (datum->syntax #f stx-expr)]) 183 (with ([this-syntax x]) 184 (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))])) 185 186 (define-syntax (syntax-parser stx) 187 (syntax-case stx () 188 [(syntax-parser . clauses) 189 (quasisyntax/loc stx 190 (lambda (x) 191 (let ([x (datum->syntax #f x)]) 192 (with ([this-syntax x]) 193 (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))))])) 194 195 (define-syntax (syntax-parser/template stx) 196 (syntax-case stx () 197 [(syntax-parser/template ctx . clauses) 198 (quasisyntax/loc stx 199 (lambda (x) 200 (let ([x (datum->syntax #f x)]) 201 (with ([this-syntax x]) 202 (parse:clauses x clauses one-template ctx)))))])) 203 204 (define-syntax (define/syntax-parse stx) 205 (syntax-case stx () 206 [(define/syntax-parse pattern . rest) 207 (with-disappeared-uses 208 (let-values ([(rest pattern defs) 209 (parse-pattern+sides #'pattern 210 #'rest 211 #:splicing? #f 212 #:decls (new-declenv null) 213 #:context stx)]) 214 (define no-fail? (patterns-cannot-fail? (list pattern))) 215 (let ([expr 216 (syntax-case rest () 217 [( expr ) #'expr] 218 [_ (raise-syntax-error #f "bad syntax" stx)])] 219 [attrs (pattern-attrs pattern)]) 220 (with-syntax ([(a ...) attrs] 221 [(#s(attr name _ _) ...) attrs] 222 [pattern pattern] 223 [es0 (if no-fail? #'#f #'#t)] 224 [(def ...) defs] 225 [expr expr]) 226 #'(defattrs/unpack (a ...) 227 (let* ([x (datum->syntax #f expr)] 228 [cx x] 229 [pr (ps-empty x x)] 230 [es es0] 231 [fh0 (syntax-patterns-fail 232 (normalize-context 'define/syntax-parse 233 '|define/syntax-parse pattern| 234 x))]) 235 (parameterize ((current-syntax-context x)) 236 def ... 237 (#%expression 238 (with ([fail-handler fh0] 239 [cut-prompt fh0] 240 [undo-stack null]) 241 (parse:S x cx pattern pr es 242 (list (attribute name) ...)))))))))))])) 243 244 ;; ============================================================ 245 246 #| 247 Parsing protocols: 248 249 (parse:<X> <X-args> pr es success-expr) : Ans 250 251 <S-args> : x cx 252 <H-args> : x cx rest-x rest-cx rest-pr 253 <EH-args> : x cx ??? 254 <A-args> : x cx 255 256 x is term to parse, usually syntax but can be pair/null (stx-list?) in cdr patterns 257 cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src 258 pr, es are progress and expectstack, respectively 259 rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr 260 261 (stxclass-parser x cx pr es undos fail-handler cut-prompt role success-proc arg ...) : Ans 262 263 success-proc: 264 for stxclass, is (fail-handler undos attr-value ... -> Ans) 265 for splicing-stxclass, is (undos fail-handler rest-x rest-cx rest-pr attr-value -> Ans) 266 fail-handler, cut-prompt : undos failure -> Ans 267 268 Fail-handler is normally represented with stxparam 'fail-handler', but must be 269 threaded through stxclass calls (in through stxclass-parser, out through 270 success-proc) to support backtracking. Cut-prompt is never changed within 271 stxclass or within alternative, so no threading needed. 272 273 The undo stack is normally represented with stxparam 'undo-stack', but must be 274 threaded through stxclass calls (like fail-handler). A failure handler closes 275 over a base undo stack and receives an extended current undo stack; the failure 276 handler unwinds effects by performing every action in the difference between 277 them and then restores the saved undo stack. 278 279 Usually sub-patterns processed in tail position, but *can* do non-tail calls for: 280 - ~commit 281 - var of stxclass with ~commit 282 It is also safe to keep normal tail-call protocol and just adjust fail-handler. 283 There is no real benefit to specializing ~commit, since it does not involve 284 creating a success closure. 285 286 Some optimizations: 287 - commit protocol for stxclasses (but not ~commit, no point) 288 - avoid continue-vs-end choice point in (EH ... . ()) by eager pair check 289 - integrable stxclasses, specialize ellipses of integrable stxclasses 290 - pattern lists that cannot fail set es=#f to disable ExpectStack allocation 291 |# 292 293 ;; ---- 294 295 (begin-for-syntax 296 (define (wash stx) 297 (syntax-e stx)) 298 (define (wash-list washer stx) 299 (let ([l (stx->list stx)]) 300 (unless l (raise-type-error 'wash-list "stx-list" stx)) 301 (map washer l))) 302 (define (wash-iattr stx) 303 (with-syntax ([#s(attr name depth syntax?) stx]) 304 (attr #'name (wash #'depth) (wash #'syntax?)))) 305 (define (wash-sattr stx) 306 (with-syntax ([#s(attr name depth syntax?) stx]) 307 (attr (wash #'name) (wash #'depth) (wash #'syntax?)))) 308 (define (wash-iattrs stx) 309 (wash-list wash-iattr stx)) 310 (define (wash-sattrs stx) 311 (wash-list wash-sattr stx)) 312 (define (generate-n-temporaries n) 313 (generate-temporaries 314 (for/list ([i (in-range n)]) 315 (string->symbol (format "g~sx" i)))))) 316 317 ;; ---- 318 319 #| 320 Conventions: 321 - rhs : RHS 322 - iattr : IAttr 323 - relsattr : SAttr 324 - splicing? : bool 325 - x : id (var) 326 - cx : id (var, may be shadowed) 327 - pr : id (var, may be shadowed) 328 - es : id (var, may be shadowed) 329 - success : var (bound to success procedure) 330 - k : expr 331 - rest-x, rest-cx, rest-pr : id (to be bound) 332 - fh, cp, rl : id (var) 333 |# 334 335 (begin-for-syntax 336 (define (rewrite-formals fstx x-id rl-id) 337 (with-syntax ([x x-id] 338 [rl rl-id]) 339 (let loop ([fstx fstx]) 340 (syntax-case fstx () 341 [([kw arg default] . more) 342 (keyword? (syntax-e #'kw)) 343 (cons #'(kw arg (with ([this-syntax x] [this-role rl]) default)) 344 (loop #'more))] 345 [([arg default] . more) 346 (not (keyword? (syntax-e #'kw))) 347 (cons #'(arg (with ([this-syntax x] [this-role rl]) default)) 348 (loop #'more))] 349 [(formal . more) 350 (cons #'formal (loop #'more))] 351 [_ fstx]))))) 352 353 ;; (with-maybe-delimit-cut bool expr) 354 (define-syntax with-maybe-delimit-cut 355 (syntax-rules () 356 [(wmdc #t k) 357 (with ([cut-prompt fail-handler]) k)] 358 [(wmdc #f k) 359 k])) 360 361 ;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans] 362 (define-syntax (variant-success stx) 363 (syntax-case stx () 364 [(variant-success relsattrs iattrs (also ...) success cp0 commit?) 365 #`(with-maybe-reset-fail commit? cp0 366 (base-success-expr iattrs relsattrs (also ...) success))])) 367 368 ;; (with-maybe-reset-fail bool id expr) 369 (define-syntax with-maybe-reset-fail 370 (syntax-rules () 371 [(wmrs #t cp0 k) 372 (with ([fail-handler cp0]) k)] 373 [(wmrs #f cp0 k) 374 k])) 375 376 ;; (base-success-expr iattrs relsattrs (also:id ...) success) : expr[Ans] 377 (define-syntax (base-success-expr stx) 378 (syntax-case stx () 379 [(base-success-expr iattrs relsattrs (also ...) success) 380 (let ([reliattrs 381 (reorder-iattrs (wash-sattrs #'relsattrs) 382 (wash-iattrs #'iattrs))]) 383 (with-syntax ([(#s(attr name _ _) ...) reliattrs]) 384 #'(success fail-handler undo-stack also ... (attribute name) ...)))])) 385 386 ;; ---- 387 388 ;; (parse:clauses x clauses ctx) 389 (define-syntax (parse:clauses stx) 390 (syntax-case stx () 391 [(parse:clauses x clauses body-mode ctx) 392 ;; if templates? is true, expect one form after kwargs in clause, wrap it with syntax 393 ;; otherwise, expect non-empty body sequence (defs and exprs) 394 (with-disappeared-uses 395 (with-txlifts 396 (lambda () 397 (define who 398 (syntax-case #'ctx () 399 [(m . _) (identifier? #'m) #'m] 400 [_ 'syntax-parse])) 401 (define-values (chunks clauses-stx) 402 (parse-keyword-options #'clauses parse-directive-table 403 #:context #'ctx 404 #:no-duplicates? #t)) 405 (define context 406 (options-select-value chunks '#:context #:default #'x)) 407 (define colon-notation? 408 (not (assq '#:disable-colon-notation chunks))) 409 (define track-literals? 410 (or (assq '#:track-literals chunks) 411 (eq? (syntax-e #'body-mode) 'one-template))) 412 (define-values (decls0 defs) 413 (get-decls+defs chunks #t #:context #'ctx)) 414 ;; for-clause : stx -> (values pattern stx (listof stx)) 415 (define (for-clause clause) 416 (syntax-case clause () 417 [[p . rest] 418 (let-values ([(rest pattern defs2) 419 (parameterize ((stxclass-colon-notation? colon-notation?)) 420 (parse-pattern+sides #'p #'rest 421 #:splicing? #f 422 #:decls decls0 423 #:context #'ctx))]) 424 (let ([body-expr 425 (case (syntax-e #'body-mode) 426 ((one-template) 427 (syntax-case rest () 428 [(template) 429 #'(syntax template)] 430 [_ (raise-syntax-error #f "expected exactly one template" #'ctx)])) 431 ((body-sequence) 432 (syntax-case rest () 433 [(e0 e ...) 434 ;; Should we use a shadower (works on the whole file, unhygienically), 435 ;; or use the context of the syntax-parse identifier? 436 (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)]) 437 (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro 438 #`(let () (#,the-#%intdef-begin e0 e ...)) 439 #'(let () e0 e ...)))] 440 [_ (raise-syntax-error #f "expected non-empty clause body" 441 #'ctx clause)])) 442 (else 443 (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))]) 444 (values pattern body-expr defs2)))] 445 [_ (raise-syntax-error #f "expected clause" #'ctx clause)])) 446 (define (wrap-track-literals stx) 447 (if track-literals? (quasisyntax/loc stx (track-literals '#,who #,stx)) stx)) 448 (unless (stx-list? clauses-stx) 449 (raise-syntax-error #f "expected sequence of clauses" #'ctx)) 450 (define-values (patterns body-exprs defs2s) 451 (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))]) 452 (for-clause clause))) 453 (define no-fail? (patterns-cannot-fail? patterns)) 454 (when no-fail? (log-syntax-parse-debug "cannot fail: ~e" #'ctx)) 455 (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)]) 456 #`(let* ([ctx0 (normalize-context '#,who #,context x)] 457 [pr (ps-empty x (cadr ctx0))] 458 [es #,(if no-fail? #'#f #'#t)] 459 [cx x] 460 [fh0 (syntax-patterns-fail ctx0)]) 461 def ... 462 (parameterize ((current-syntax-context (cadr ctx0)) 463 (current-state '#hasheq()) 464 (current-state-writable? #f)) 465 #,(wrap-track-literals 466 #`(with ([fail-handler fh0] 467 [cut-prompt fh0] 468 [undo-stack null]) 469 #,(cond [(pair? patterns) 470 (with-syntax ([matrix 471 (optimize-matrix 472 (for/list ([pattern (in-list patterns)] 473 [body-expr (in-list body-exprs)]) 474 (pk1 (list pattern) body-expr)))]) 475 #'(parse:matrix ((x cx pr es)) matrix)) 476 #| 477 (with-syntax ([(alternative ...) 478 (for/list ([pattern (in-list patterns)] 479 [body-expr (in-list body-exprs)]) 480 #`(parse:S x cx #,pattern pr es #,body-expr))]) 481 #`(try alternative ...)) 482 |#] 483 [else 484 #`(fail (failure* pr es))])))))))))])) 485 486 ;; ---- 487 488 ;; (parse:matrix ((x cx pr es) ...) (PK ...)) : expr[Ans] 489 ;; (parse:matrix (in1 ... inN) (#s(pk1 (P11 ... P1N) e1) ... #s(pk1 (PM1 ... PMN) eM))) 490 ;; represents the matching matrix 491 ;; [_in1_..._inN_|____] 492 ;; [ P11 ... P1N | e1 ] 493 ;; [ ⋮ ⋮ | ⋮ ] 494 ;; [ PM1 ... PMN | eM ] 495 496 (define-syntax (parse:matrix stx) 497 (syntax-case stx () 498 [(parse:matrix ins (pk ...)) 499 #'(try (parse:pk ins pk) ...)])) 500 501 (define-syntax (parse:pk stx) 502 (syntax-case stx () 503 [(parse:pk () #s(pk1 () k)) 504 #'k] 505 [(parse:pk ((x cx pr es) . ins) #s(pk1 (pat1 . pats) k)) 506 #'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))] 507 [(parse:pk ((x cx pr es) . ins) #s(pk/same pat1 inner)) 508 #'(parse:S x cx pat1 pr es (parse:matrix ins inner))] 509 [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner)) 510 #'(let-values ([(datum tcx) 511 (if (syntax? x) 512 (values (syntax-e x) x) 513 (values x cx))]) 514 (if (pair? datum) 515 (let ([hx (car datum)] 516 [hcx (car datum)] 517 [hpr (ps-add-car pr)] 518 [tx (cdr datum)] 519 [tpr (ps-add-cdr pr)]) 520 (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) 521 (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)]) 522 (fail (failure* pr es*)))))] 523 [(parse:pk (in1 . ins) #s(pk/and inner)) 524 #'(parse:matrix (in1 in1 . ins) inner)])) 525 526 (define-syntax (first-desc:matrix stx) 527 (syntax-case stx () 528 [(fdm (#s(pk1 (pat1 . pats) k))) 529 #'(first-desc:S pat1)] 530 [(fdm (#s(pk/same pat1 pks))) 531 #'(first-desc:S pat1)] 532 [(fdm (pk ...)) ;; FIXME 533 #'#f])) 534 535 ;; ---- 536 537 ;; (parse:S x cx S-pattern pr es k) : expr[Ans] 538 ;; In k: attrs(S-pattern) are bound. 539 (define-syntax (parse:S stx) 540 (syntax-case stx () 541 [(parse:S x cx pattern0 pr es k) 542 (syntax-case #'pattern0 () 543 [#s(internal-rest-pattern rest-x rest-cx rest-pr) 544 #`(let ([rest-x x] 545 [rest-cx cx] 546 [rest-pr pr]) 547 k)] 548 [#s(pat:any) 549 #'k] 550 [#s(pat:svar name) 551 #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) 552 k)] 553 [#s(pat:var/p name parser argu (nested-a ...) role 554 #s(scopts attr-count commit? _delimit? _desc)) 555 (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] 556 [(name-attr ...) 557 (if (identifier? #'name) 558 #'([#s(attr name 0 #t) (datum->syntax cx x cx)]) 559 #'())]) 560 (if (not (syntax-e #'commit?)) 561 ;; The normal protocol 562 #'(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role 563 (lambda (fh undos av ...) 564 (let-attributes (name-attr ...) 565 (let-attributes* ((nested-a ...) (av ...)) 566 (with ([fail-handler fh] [undo-stack undos]) 567 k)))) 568 argu) 569 ;; The commit protocol 570 ;; (Avoids putting k in procedure) 571 #'(let-values ([(fs undos av ...) 572 (with ([fail-handler 573 (lambda (undos fs) 574 (unwind-to undos undo-stack) 575 (values fs undo-stack (let ([av #f]) av) ...))]) 576 (with ([cut-prompt fail-handler]) 577 (app-argu parser x cx pr es undo-stack 578 fail-handler cut-prompt role 579 (lambda (fh undos av ...) (values #f undos av ...)) 580 argu)))]) 581 (if fs 582 (fail fs) 583 (let-attributes (name-attr ...) 584 (let-attributes* ((nested-a ...) (av ...)) 585 (with ([undo-stack undos]) 586 k)))))))] 587 [#s(pat:reflect obj argu attr-decls name (nested-a ...)) 588 (with-syntax ([(name-attr ...) 589 (if (identifier? #'name) 590 #'([#s(attr name 0 #t) (datum->syntax cx x cx)]) 591 #'())]) 592 (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) 593 #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)]) 594 (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f 595 (lambda (fh undos . result) 596 (let-attributes (name-attr ...) 597 (let/unpack ((nested-a ...) result) 598 (with ([fail-handler fh] [undo-stack undos]) 599 k)))) 600 argu))))] 601 [#s(pat:datum datum) 602 (with-syntax ([unwrap-x 603 (if (atomic-datum-stx? #'datum) 604 #'(if (syntax? x) (syntax-e x) x) 605 #'(syntax->datum (datum->syntax #f x)))]) 606 #`(let ([d unwrap-x]) 607 (if (equal? d (quote datum)) 608 k 609 (fail (failure* pr (es-add-atom 'datum es))))))] 610 [#s(pat:literal literal input-phase lit-phase) 611 #`(if (and (identifier? x) 612 (free-identifier=? x (quote-syntax literal) input-phase lit-phase)) 613 (with ([undo-stack (cons (current-state) undo-stack)]) 614 (state-cons! 'literals x) 615 k) 616 (fail (failure* pr (es-add-literal (quote-syntax literal) es))))] 617 [#s(pat:action action subpattern) 618 #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] 619 [#s(pat:head head tail) 620 #`(parse:H x cx rest-x rest-cx rest-pr head pr es 621 (parse:S rest-x rest-cx tail rest-pr es k))] 622 [#s(pat:dots head tail) 623 #`(parse:dots x cx head tail pr es k)] 624 [#s(pat:and subpatterns) 625 (for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))]) 626 #`(parse:S x cx #,subpattern pr es #,k))] 627 [#s(pat:or (a ...) (subpattern ...) (subattrs ...)) 628 (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) 629 #`(let ([success 630 (lambda (fh undos id ...) 631 (let-attributes ([a id] ...) 632 (with ([fail-handler fh] [undo-stack undos]) 633 k)))]) 634 (try (parse:S x cx subpattern pr es 635 (disjunct subattrs success () (id ...))) 636 ...)))] 637 [#s(pat:not subpattern) 638 #`(let* ([fh0 fail-handler] 639 [pr0 pr] 640 [es0 es] 641 [fail-to-succeed 642 (lambda (undos fs) (unwind-to undos undo-stack) k)]) 643 ;; ~not implicitly prompts to be safe, 644 ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) 645 ;; (statically checked!) 646 (with ([fail-handler fail-to-succeed] 647 [cut-prompt fail-to-succeed]) ;; to be safe 648 (parse:S x cx subpattern pr es 649 (fh0 undo-stack (failure* pr0 es0)))))] 650 [#s(pat:pair head tail) 651 #`(let ([datum (if (syntax? x) (syntax-e x) x)] 652 [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?! 653 (if (pair? datum) 654 (let ([hx (car datum)] 655 [hcx (car datum)] 656 [hpr (ps-add-car pr)] 657 [tx (cdr datum)] 658 [tpr (ps-add-cdr pr)]) 659 (parse:S hx hcx head hpr es 660 (parse:S tx cx tail tpr es k))) 661 (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)]) 662 (fail (failure* pr es*)))))] 663 [#s(pat:vector subpattern) 664 #`(let ([datum (if (syntax? x) (syntax-e x) x)]) 665 (if (vector? datum) 666 (let ([datum (vector->list datum)] 667 [vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ??? 668 [pr* (ps-add-unvector pr)]) 669 (parse:S datum vcx subpattern pr* es k)) 670 (fail (failure* pr es))))] 671 [#s(pat:box subpattern) 672 #`(let ([datum (if (syntax? x) (syntax-e x) x)]) 673 (if (box? datum) 674 (let ([datum (unbox datum)] 675 [bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ??? 676 [pr* (ps-add-unbox pr)]) 677 (parse:S datum bcx subpattern pr* es k)) 678 (fail (failure* pr es))))] 679 [#s(pat:pstruct key subpattern) 680 #`(let ([datum (if (syntax? x) (syntax-e x) x)]) 681 (if (let ([xkey (prefab-struct-key datum)]) 682 (and xkey (equal? xkey 'key))) 683 (let ([datum (cdr (vector->list (struct->vector datum)))] 684 [scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ??? 685 [pr* (ps-add-unpstruct pr)]) 686 (parse:S datum scx subpattern pr* es k)) 687 (fail (failure* pr es))))] 688 [#s(pat:describe pattern description transparent? role) 689 #`(let ([es* (es-add-thing pr description transparent? role es)] 690 [pr* (if 'transparent? pr (ps-add-opaque pr))]) 691 (parse:S x cx pattern pr* es* k))] 692 [#s(pat:delimit pattern) 693 #`(let ([cp0 cut-prompt]) 694 (with ([cut-prompt fail-handler]) 695 (parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))] 696 [#s(pat:commit pattern) 697 #`(let ([fh0 fail-handler] 698 [cp0 cut-prompt]) 699 (with ([cut-prompt fh0]) 700 (parse:S x cx pattern pr es 701 (with ([cut-prompt cp0] 702 [fail-handler fh0]) 703 k))))] 704 [#s(pat:ord pattern group index) 705 #`(let ([pr* (ps-add pr '#s(ord group index))]) 706 (parse:S x cx pattern pr* es k))] 707 [#s(pat:post pattern) 708 #`(let ([pr* (ps-add-post pr)]) 709 (parse:S x cx pattern pr* es k))] 710 [#s(pat:integrated name predicate description role) 711 (with-syntax ([(name-attr ...) 712 (if (identifier? #'name) 713 #'([#s(attr name 0 #t) x*]) 714 #'())]) 715 #'(let ([x* (datum->syntax cx x cx)]) 716 (if (predicate x*) 717 (let-attributes (name-attr ...) k) 718 (let ([es* (es-add-thing pr 'description #t role es)]) 719 (fail (failure* pr es*))))))])])) 720 721 ;; (first-desc:S S-pattern) : expr[FirstDesc] 722 (define-syntax (first-desc:S stx) 723 (syntax-case stx () 724 [(fds p) 725 (syntax-case #'p () 726 [#s(pat:any) 727 #''(any)] 728 [#s(pat:svar name) 729 #''(any)] 730 [#s(pat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) 731 #'(quote desc)] 732 [#s(pat:datum d) 733 #''(datum d)] 734 [#s(pat:literal id _ip _lp) 735 #''(literal id)] 736 [#s(pat:describe _p desc _t? _role) 737 #`(quote #,(or (constant-desc #'desc) #'#f))] 738 [#s(pat:delimit pattern) 739 #'(first-desc:S pattern)] 740 [#s(pat:commit pattern) 741 #'(first-desc:S pattern)] 742 [#s(pat:ord pattern _ _) 743 #'(first-desc:S pattern)] 744 [#s(pat:post pattern) 745 #'(first-desc:S pattern)] 746 [#s(pat:integrated _name _pred description _role) 747 #''description] 748 [_ #'#f])])) 749 750 ;; (first-desc:H HeadPattern) : Expr 751 (define-syntax (first-desc:H stx) 752 (syntax-case stx () 753 [(fdh hpat) 754 (syntax-case #'hpat () 755 [#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)] 756 [#s(hpat:seq lp) #'(first-desc:L lp)] 757 [#s(hpat:describe _hp desc _t? _r) 758 #`(quote #,(or (constant-desc #'desc) #'#f))] 759 [#s(hpat:delimit hp) #'(first-desc:H hp)] 760 [#s(hpat:commit hp) #'(first-desc:H hp)] 761 [#s(hpat:ord hp _ _) #'(first-desc:H hp)] 762 [#s(hpat:post hp) #'(first-desc:H hp)] 763 [_ #'(first-desc:S hpat)])])) 764 765 (define-syntax (first-desc:L stx) 766 (syntax-case stx () 767 [(fdl lpat) 768 (syntax-case #'lpat () 769 [#s(pat:pair sp lp) #'(first-desc:S sp)] 770 [_ #'#f])])) 771 772 ;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans] 773 (define-syntax (disjunct stx) 774 (syntax-case stx () 775 [(disjunct (#s(attr sub-id _ _) ...) success (pre ...) (id ...)) 776 (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) 777 #`(let ([alt-sub-id (attribute sub-id)] ...) 778 (let ([id #f] ...) 779 (let ([sub-id alt-sub-id] ...) 780 (success fail-handler undo-stack pre ... id ...)))))])) 781 782 ;; (parse:A x cx A-pattern pr es k) : expr[Ans] 783 ;; In k: attrs(A-pattern) are bound. 784 (define-syntax (parse:A stx) 785 (syntax-case stx () 786 [(parse:A x cx pattern0 pr es k) 787 (syntax-case #'pattern0 () 788 [#s(action:and (action ...)) 789 (for/fold ([k #'k]) ([action (in-list (reverse (syntax->list #'(action ...))))]) 790 #`(parse:A x cx #,action pr es #,k))] 791 [#s(action:cut) 792 #'(with ([fail-handler cut-prompt]) k)] 793 [#s(action:bind a expr) 794 #'(let-attributes ([a (wrap-user-code expr)]) k)] 795 [#s(action:fail condition message) 796 #`(let ([c (wrap-user-code condition)]) 797 (if c 798 (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)] 799 [es* (es-add-message message es)]) 800 (fail (failure* pr* es*))) 801 k))] 802 [#s(action:parse pattern expr) 803 #`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))] 804 [cy y] 805 [pr* (ps-add-stx pr y)]) 806 (parse:S y cy pattern pr* es k))] 807 [#s(action:do (stmt ...)) 808 #'(parameterize ((current-state-writable? #t)) 809 (let ([init-state (current-state)]) 810 (no-shadow stmt) ... 811 (parameterize ((current-state-writable? #f)) 812 (with ([undo-stack (maybe-add-state-undo init-state (current-state) undo-stack)]) 813 (#%expression k)))))] 814 [#s(action:undo (stmt ...)) 815 #'(with ([undo-stack (cons (lambda () stmt ... (void)) undo-stack)] 816 [cut-prompt illegal-cut-error]) 817 k)] 818 [#s(action:ord pattern group index) 819 #'(let ([pr* (ps-add pr '#s(ord group index))]) 820 (parse:A x cx pattern pr* es k))] 821 [#s(action:post pattern) 822 #'(let ([pr* (ps-add-post pr)]) 823 (parse:A x cx pattern pr* es k))])])) 824 825 (begin-for-syntax 826 ;; convert-list-pattern : ListPattern id -> SinglePattern 827 ;; Converts '() datum pattern at end of list to bind (cons stx index) 828 ;; to rest-var. 829 (define (convert-list-pattern pattern end-pattern) 830 (syntax-case pattern () 831 [#s(pat:datum ()) 832 end-pattern] 833 [#s(pat:action action tail) 834 (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) 835 #'#s(pat:action action tail))] 836 [#s(pat:head head tail) 837 (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) 838 #'#s(pat:head head tail))] 839 [#s(pat:dots head tail) 840 (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) 841 #'#s(pat:dots head tail))] 842 [#s(pat:pair head-part tail-part) 843 (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) 844 #'#s(pat:pair head-part tail-part))]))) 845 846 ;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k) 847 ;; In k: rest, rest-pr, attrs(H-pattern) are bound. 848 (define-syntax (parse:H stx) 849 (syntax-case stx () 850 [(parse:H x cx rest-x rest-cx rest-pr head pr es k) 851 (syntax-case #'head () 852 [#s(hpat:describe pattern description transparent? role) 853 #`(let ([es* (es-add-thing pr description transparent? role es)] 854 [pr* (if 'transparent? pr (ps-add-opaque pr))]) 855 (parse:H x cx rest-x rest-cx rest-pr pattern pr* es* 856 (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) 857 k)))] 858 [#s(hpat:var/p name parser argu (nested-a ...) role 859 #s(scopts attr-count commit? _delimit? _desc)) 860 (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] 861 [(name-attr ...) 862 (if (identifier? #'name) 863 #'([#s(attr name 0 #t) 864 (stx-list-take x (ps-difference pr rest-pr))]) 865 #'())]) 866 (if (not (syntax-e #'commit?)) 867 ;; The normal protocol 868 #`(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role 869 (lambda (fh undos rest-x rest-cx rest-pr av ...) 870 (let-attributes (name-attr ...) 871 (let-attributes* ((nested-a ...) (av ...)) 872 (with ([fail-handler fh] [undo-stack undos]) 873 k)))) 874 argu) 875 ;; The commit protocol 876 ;; (Avoids putting k in procedure) 877 #'(let-values ([(fs undos rest-x rest-cx rest-pr av ...) 878 (with ([fail-handler 879 (lambda (undos fs) 880 (unwind-to undos undo-stack) 881 (values fs undo-stack #f #f #f (let ([av #f]) av) ...))]) 882 (with ([cut-prompt fail-handler]) 883 (app-argu parser x cx pr es undo-stack 884 fail-handler cut-prompt role 885 (lambda (fh undos rest-x rest-cx rest-pr av ...) 886 (values #f undos rest-x rest-cx rest-pr av ...)) 887 argu)))]) 888 (if fs 889 (fail fs) 890 (let-attributes (name-attr ...) 891 (let-attributes* ((nested-a ...) (av ...)) 892 (with ([undo-stack undos]) 893 k)))))))] 894 [#s(hpat:reflect obj argu attr-decls name (nested-a ...)) 895 (with-syntax ([(name-attr ...) 896 (if (identifier? #'name) 897 #'([#s(attr name 0 #t) 898 (stx-list-take x (ps-difference pr rest-pr))]) 899 #'())]) 900 (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) 901 #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)]) 902 (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f 903 (lambda (fh undos rest-x rest-cx rest-pr . result) 904 (let-attributes (name-attr ...) 905 (let/unpack ((nested-a ...) result) 906 (with ([fail-handler fh] [undo-stack undos]) 907 k)))) 908 argu))))] 909 [#s(hpat:and head single) 910 #`(let ([cx0 cx]) 911 (parse:H x cx rest-x rest-cx rest-pr head pr es 912 (let ([lst (stx-list-take x (ps-difference pr rest-pr))]) 913 (parse:S lst cx0 single pr es k))))] 914 [#s(hpat:or (a ...) (subpattern ...) (subattrs ...)) 915 (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) 916 #`(let ([success 917 (lambda (fh undos rest-x rest-cx rest-pr id ...) 918 (let-attributes ([a id] ...) 919 (with ([fail-handler fh] [undo-stack undos]) 920 k)))]) 921 (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es 922 (disjunct subattrs success (rest-x rest-cx rest-pr) (id ...))) 923 ...)))] 924 [#s(hpat:seq pattern) 925 (with-syntax ([pattern 926 (convert-list-pattern 927 #'pattern 928 #'#s(internal-rest-pattern rest-x rest-cx rest-pr))]) 929 #'(parse:S x cx pattern pr es k))] 930 [#s(hpat:action action subpattern) 931 #'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))] 932 [#s(hpat:delimit pattern) 933 #'(let ([cp0 cut-prompt]) 934 (with ([cut-prompt fail-handler]) 935 (parse:H x cx rest-x rest-cx rest-pr pattern pr es 936 (with ([cut-prompt cp0]) k))))] 937 [#s(hpat:commit pattern) 938 #`(let ([fh0 fail-handler] 939 [cp0 cut-prompt]) 940 (with ([cut-prompt fh0]) 941 (parse:H x cx rest-x rest-cx rest-pr pattern pr es 942 (with ([cut-prompt cp0] 943 [fail-handler fh0]) 944 k))))] 945 [#s(hpat:ord pattern group index) 946 #`(let ([pr* (ps-add pr '#s(ord group index))]) 947 (parse:H x cx rest-x rest-cx rest-pr pattern pr* es 948 (let ([rest-pr (ps-pop-ord rest-pr)]) k)))] 949 [#s(hpat:post pattern) 950 #'(let ([pr* (ps-add-post pr)]) 951 (parse:H x cx rest-x rest-cx rest-pr pattern pr* es 952 (let ([rest-pr (ps-pop-post rest-pr)]) k)))] 953 [#s(hpat:peek pattern) 954 #`(let ([saved-x x] [saved-cx cx] [saved-pr pr]) 955 (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es 956 (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr]) 957 k)))] 958 [#s(hpat:peek-not subpattern) 959 #`(let* ([fh0 fail-handler] 960 [pr0 pr] 961 [es0 es] 962 [fail-to-succeed 963 (lambda (undos fs) 964 (unwind-to undos undo-stack) 965 (let ([rest-x x] 966 [rest-cx cx] 967 [rest-pr pr]) 968 k))]) 969 ;; ~not implicitly prompts to be safe, 970 ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) 971 ;; (statically checked!) 972 (with ([fail-handler fail-to-succeed] 973 [cut-prompt fail-to-succeed]) ;; to be safe 974 (parse:H x cx rest-x rest-cx rest-pr subpattern pr es 975 (fh0 undo-stack (failure* pr0 es0)))))] 976 [_ 977 #'(parse:S x cx 978 ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) 979 #s(pat:pair head #s(internal-rest-pattern rest-x rest-cx rest-pr)) 980 pr es k)])])) 981 982 ;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] 983 ;; In k: attrs(EH-pattern, S-pattern) are bound. 984 (define-syntax (parse:dots stx) 985 (syntax-case stx () 986 ;; == Specialized cases 987 ;; -- (x ... . ()) 988 [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f #f)) 989 #s(pat:datum ()) pr es k) 990 #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) 991 (case status 992 ((ok) (let-attributes ([attr0 result]) k)) 993 (else (fail result))))] 994 ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr 995 [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f #f)) 996 #s(pat:datum ()) pr es k) 997 #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)]) 998 (case status 999 ((ok) (let-attributes ([attr0 result]) k)) 1000 (else (fail result))))] 1001 ;; -- (x:sc ... . ()) where sc is a stxclass with commit 1002 ;; Since head pattern does commit, no need to thread fail-handler, cut-prompt through. 1003 ;; Microbenchmark suggests this isn't a useful specialization 1004 ;; (probably try-or-pair/null-check already does the useful part) 1005 ;; == General case 1006 [(parse:dots x cx (#s(ehpat head-attrs head head-repc check-null?) ...) tail pr es k) 1007 (let () 1008 (define repcs (wash-list wash #'(head-repc ...))) 1009 (define rep-ids (for/list ([repc (in-list repcs)]) 1010 (and repc (generate-temporary 'rep)))) 1011 (define rel-repcs (filter values repcs)) 1012 (define rel-rep-ids (filter values rep-ids)) 1013 (define rel-heads (for/list ([head (in-list (syntax->list #'(head ...)))] 1014 [repc (in-list repcs)] 1015 #:when repc) 1016 head)) 1017 (define aattrs 1018 (for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))] 1019 [repc (in-list repcs)] 1020 #:when #t 1021 [a (in-list (wash-iattrs head-attrs))]) 1022 (cons a repc))) 1023 (define attrs (map car aattrs)) 1024 (define attr-repcs (map cdr aattrs)) 1025 (define ids (map attr-name attrs)) 1026 (define tail-pattern-is-null? (equal? (syntax->datum #'tail) '#s(pat:datum ()))) 1027 (with-syntax ([(id ...) ids] 1028 [(alt-id ...) (generate-temporaries ids)] 1029 [reps rel-rep-ids] 1030 [(head-rep ...) rep-ids] 1031 [(rel-rep ...) rel-rep-ids] 1032 [(rel-repc ...) rel-repcs] 1033 [(rel-head ...) rel-heads] 1034 [(a ...) attrs] 1035 [(attr-repc ...) attr-repcs] 1036 [do-pair/null? 1037 ;; FIXME: do pair/null check only if no nullable head patterns 1038 ;; (and tail-pattern-is-null? (andmap not (syntax->datum #'(nullable? ...)))) 1039 tail-pattern-is-null?]) 1040 (define/with-syntax alt-map #'((id . alt-id) ...)) 1041 (define/with-syntax loop-k 1042 #'(dots-loop dx* dcx* loop-pr* undo-stack fail-handler rel-rep ... alt-id ...)) 1043 #`(let () 1044 ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans 1045 (define (dots-loop dx dcx loop-pr undos fh rel-rep ... alt-id ...) 1046 (with ([fail-handler fh] [undo-stack undos]) 1047 (try-or-pair/null-check do-pair/null? dx dcx loop-pr es 1048 (try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr* 1049 alt-map head-rep head es loop-k) 1050 ...) 1051 (cond [(< rel-rep (rep:min-number rel-repc)) 1052 (let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)]) 1053 (fail (failure* loop-pr es)))] 1054 ... 1055 [else 1056 (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...) 1057 (parse:S dx dcx tail loop-pr es k))])))) 1058 (let ([rel-rep 0] ... 1059 [alt-id (rep:initial-value attr-repc)] ...) 1060 (dots-loop x cx pr undo-stack fail-handler rel-rep ... alt-id ...)))))])) 1061 1062 ;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt) 1063 (define-syntax try-or-pair/null-check 1064 (syntax-rules () 1065 [(topc #t x cx pr es pair-alt null-alt) 1066 (cond [(stx-pair? x) pair-alt] 1067 [(stx-null? x) null-alt] 1068 [else (fail (failure* pr es))])] 1069 [(topc _ x cx pr es alt1 alt2) 1070 (try alt1 alt2)])) 1071 1072 ;; (parse:EH x cx pr repc x* cx* pr* alts rep H-pattern es k) : expr[Ans] 1073 ;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed. 1074 (define-syntax (parse:EH stx) 1075 (syntax-case stx () 1076 [(parse:EH x cx pr attrs check-null? repc x* cx* pr* alts rep head es k) 1077 (let () 1078 (define/with-syntax k* 1079 (let* ([main-attrs (wash-iattrs #'attrs)] 1080 [ids (map attr-name main-attrs)] 1081 [alt-ids 1082 (let ([table (make-bound-id-table)]) 1083 (for ([entry (in-list (syntax->list #'alts))]) 1084 (let ([entry (syntax-e entry)]) 1085 (bound-id-table-set! table (car entry) (cdr entry)))) 1086 (for/list ([id (in-list ids)]) (bound-id-table-ref table id)))]) 1087 (with-syntax ([(id ...) ids] 1088 [(alt-id ...) alt-ids]) 1089 #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) 1090 #,(if (syntax->datum #'check-null?) 1091 #'(if (zero? (ps-difference pr pr*)) (error/null-eh-match) k) 1092 #'k))))) 1093 (syntax-case #'repc () 1094 [#f #`(parse:H x cx x* cx* pr* head pr es k*)] 1095 [_ #`(parse:H x cx x* cx* pr* head pr es 1096 (if (< rep (rep:max-number repc)) 1097 (let ([rep (add1 rep)]) k*) 1098 (let ([es* (expectation-of-reps/too-many es rep repc)]) 1099 (fail (failure* pr* es*)))))]))])) 1100 1101 ;; (rep:initial-value RepConstraint) : expr 1102 (define-syntax (rep:initial-value stx) 1103 (syntax-case stx () 1104 [(_ #s(rep:once _ _ _)) #'#f] 1105 [(_ #s(rep:optional _ _ _)) #'#f] 1106 [(_ _) #'null])) 1107 1108 ;; (rep:finalize RepConstraint expr) : expr 1109 (define-syntax (rep:finalize stx) 1110 (syntax-case stx () 1111 [(_ a #s(rep:optional _ _ defaults) v) 1112 (with-syntax ([#s(attr name _ _) #'a] 1113 [(#s(action:bind da de) ...) #'defaults]) 1114 (let ([default 1115 (for/or ([da (in-list (syntax->list #'(da ...)))] 1116 [de (in-list (syntax->list #'(de ...)))]) 1117 (with-syntax ([#s(attr dname _ _) da]) 1118 (and (bound-identifier=? #'name #'dname) de)))]) 1119 (if default 1120 #`(or v #,default) 1121 #'v)))] 1122 [(_ a #s(rep:once _ _ _) v) #'v] 1123 [(_ a _ v) #'(reverse v)])) 1124 1125 ;; (rep:min-number RepConstraint) : expr 1126 (define-syntax (rep:min-number stx) 1127 (syntax-case stx () 1128 [(_ #s(rep:once _ _ _)) #'1] 1129 [(_ #s(rep:optional _ _ _)) #'0] 1130 [(_ #s(rep:bounds min max _ _ _)) #'min])) 1131 1132 ;; (rep:max-number RepConstraint) : expr 1133 (define-syntax (rep:max-number stx) 1134 (syntax-case stx () 1135 [(_ #s(rep:once _ _ _)) #'1] 1136 [(_ #s(rep:optional _ _ _)) #'1] 1137 [(_ #s(rep:bounds min max _ _ _)) #'max])) 1138 1139 ;; (rep:combine RepConstraint expr expr) : expr 1140 (define-syntax (rep:combine stx) 1141 (syntax-case stx () 1142 [(_ #s(rep:once _ _ _) a b) #'a] 1143 [(_ #s(rep:optional _ _ _) a b) #'a] 1144 [(_ _ a b) #'(cons a b)])) 1145 1146 ;; ---- 1147 1148 (define-syntax expectation-of-reps/too-few 1149 (syntax-rules () 1150 [(_ es rep #s(rep:once name too-few-msg too-many-msg) hpat) 1151 (cond [(or too-few-msg (name->too-few/once name)) 1152 => (lambda (msg) (es-add-message msg es))] 1153 [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))] 1154 [else es])] 1155 [(_ es rep #s(rep:optional name too-many-msg _) hpat) 1156 (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")] 1157 [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg) hpat) 1158 (cond [(or too-few-msg (name->too-few name)) 1159 => (lambda (msg) (es-add-message msg es))] 1160 [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))] 1161 [else es])])) 1162 1163 (define-syntax expectation-of-reps/too-many 1164 (syntax-rules () 1165 [(_ es rep #s(rep:once name too-few-msg too-many-msg)) 1166 (es-add-message (or too-many-msg (name->too-many name)) es)] 1167 [(_ es rep #s(rep:optional name too-many-msg _)) 1168 (es-add-message (or too-many-msg (name->too-many name)) es)] 1169 [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg)) 1170 (es-add-message (or too-many-msg (name->too-many name)) es)])) 1171 1172 ;; ==== 1173 1174 (define-syntax (define-eh-alternative-set stx) 1175 (define (parse-alt x) 1176 (syntax-case x (pattern) 1177 [(pattern alt) 1178 #'alt] 1179 [else 1180 (wrong-syntax x "expected eh-alternative-set alternative")])) 1181 (parameterize ((current-syntax-context stx)) 1182 (syntax-case stx () 1183 [(_ name a ...) 1184 (unless (identifier? #'name) 1185 (wrong-syntax #'name "expected identifier")) 1186 (let* ([alts (map parse-alt (syntax->list #'(a ...)))] 1187 [decls (new-declenv null #:conventions null)] 1188 [ehpat+hstx-list 1189 (apply append 1190 (for/list ([alt (in-list alts)]) 1191 (parse*-ellipsis-head-pattern alt decls #t #:context stx)))] 1192 [eh-alt+defs-list 1193 (for/list ([ehpat+hstx (in-list ehpat+hstx-list)]) 1194 (let ([ehpat (car ehpat+hstx)] 1195 [hstx (cadr ehpat+hstx)]) 1196 (cond [(syntax? hstx) 1197 (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))]) 1198 (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))]) 1199 (list (eh-alternative (ehpat-repc ehpat) attrs #'parser) 1200 (list #`(define parser 1201 (parser/rhs parser () #,attrs 1202 [#:description #f (pattern #,hstx)] 1203 #t 1204 #,stx))))))] 1205 [(eh-alternative? hstx) 1206 (list hstx null)] 1207 [else 1208 (error 'define-eh-alternative-set "internal error: unexpected ~e" 1209 hstx)])))] 1210 [eh-alts (map car eh-alt+defs-list)] 1211 [defs (apply append (map cadr eh-alt+defs-list))]) 1212 (with-syntax ([(def ...) defs] 1213 [(alt-expr ...) 1214 (for/list ([alt (in-list eh-alts)]) 1215 (with-syntax ([repc-expr 1216 ;; repc structs are prefab; recreate using prefab 1217 ;; quasiquote exprs to avoid moving constructors 1218 ;; to residual module 1219 (syntax-case (eh-alternative-repc alt) () 1220 [#f 1221 #''#f] 1222 [#s(rep:once n u o) 1223 #'`#s(rep:once ,(quote-syntax n) 1224 ,(quote-syntax u) 1225 ,(quote-syntax o))] 1226 [#s(rep:optional n o d) 1227 #'`#s(rep:optional ,(quote-syntax n) 1228 ,(quote-syntax o) 1229 ,(quote-syntax d))] 1230 [#s(rep:bounds min max n u o) 1231 #'`#s(rep:bounds ,(quote min) 1232 ,(quote max) 1233 ,(quote-syntax n) 1234 ,(quote-syntax u) 1235 ,(quote-syntax o))])] 1236 [attrs-expr 1237 #`(quote #,(eh-alternative-attrs alt))] 1238 [parser-expr 1239 #`(quote-syntax #,(eh-alternative-parser alt))]) 1240 #'(eh-alternative repc-expr attrs-expr parser-expr)))]) 1241 #'(begin def ... 1242 (define-syntax name 1243 (eh-alternative-set (list alt-expr ...))))))])))