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