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