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