rep.rkt (65058B)
1 #lang racket/base 2 (require (for-template racket/base 3 syntax/parse/private/keywords 4 stxparse-info/parse/private/residual ;; keep abs. path 5 stxparse-info/parse/private/runtime) 6 racket/list 7 racket/contract/base 8 "make.rkt" 9 syntax/parse/private/minimatch 10 syntax/apply-transformer 11 syntax/private/id-table 12 syntax/stx 13 syntax/keyword 14 racket/syntax 15 racket/struct 16 "txlift.rkt" 17 syntax/parse/private/rep-attrs 18 syntax/parse/private/rep-data 19 syntax/parse/private/rep-patterns 20 syntax/parse/private/residual-ct ;; keep abs. path 21 syntax/parse/private/kws) 22 23 ;; Error reporting 24 ;; All entry points should have explicit, mandatory #:context arg 25 ;; (mandatory from outside, at least) 26 27 (provide/contract 28 [atomic-datum-stx? 29 (-> syntax? 30 boolean?)] 31 [parse-rhs 32 (-> syntax? (or/c false/c (listof sattr?)) boolean? 33 #:context (or/c false/c syntax?) 34 rhs?)] 35 [parse-pattern+sides 36 (-> syntax? syntax? 37 #:splicing? boolean? 38 #:decls DeclEnv/c 39 #:context syntax? 40 any)] 41 [parse*-ellipsis-head-pattern 42 (-> syntax? DeclEnv/c boolean? 43 #:context syntax? 44 any)] 45 [parse-directive-table any/c] 46 [get-decls+defs 47 (-> list? boolean? #:context (or/c false/c syntax?) 48 (values DeclEnv/c (listof syntax?)))] 49 [create-aux-def 50 (-> DeclEntry/c 51 (values DeclEntry/c (listof syntax?)))] 52 [parse-argu 53 (-> (listof syntax?) 54 #:context syntax? 55 arguments?)] 56 [parse-kw-formals 57 (-> syntax? 58 #:context syntax? 59 arity?)] 60 [check-stxclass-header 61 (-> syntax? syntax? 62 (list/c identifier? syntax? arity?))] 63 [check-stxclass-application 64 (-> syntax? syntax? 65 (cons/c identifier? arguments?))] 66 [check-conventions-rules 67 (-> syntax? syntax? 68 (listof (list/c regexp? any/c)))] 69 [check-datum-literals-list 70 (-> syntax? syntax? 71 (listof den:datum-lit?))] 72 [check-attr-arity-list 73 (-> syntax? syntax? 74 (listof sattr?))]) 75 76 ;; ---- 77 78 (define (atomic-datum-stx? stx) 79 (let ([datum (syntax-e stx)]) 80 (or (null? datum) 81 (boolean? datum) 82 (string? datum) 83 (number? datum) 84 (keyword? datum) 85 (bytes? datum) 86 (char? datum) 87 (regexp? datum) 88 (byte-regexp? datum)))) 89 90 (define (id-predicate kw) 91 (lambda (stx) 92 (and (identifier? stx) 93 (free-identifier=? stx kw) 94 (begin (disappeared! stx) #t)))) 95 96 (define wildcard? (id-predicate (quote-syntax _))) 97 (define epsilon? (id-predicate (quote-syntax ||))) 98 (define dots? (id-predicate (quote-syntax ...))) 99 (define plus-dots? (id-predicate (quote-syntax ...+))) 100 101 (define keywords 102 (list (quote-syntax _) 103 (quote-syntax ||) 104 (quote-syntax ...) 105 (quote-syntax ~var) 106 (quote-syntax ~datum) 107 (quote-syntax ~literal) 108 (quote-syntax ~and) 109 (quote-syntax ~or) 110 (quote-syntax ~or*) 111 (quote-syntax ~alt) 112 (quote-syntax ~not) 113 (quote-syntax ~seq) 114 (quote-syntax ~rep) 115 (quote-syntax ~once) 116 (quote-syntax ~optional) 117 (quote-syntax ~between) 118 (quote-syntax ~rest) 119 (quote-syntax ~describe) 120 (quote-syntax ~!) 121 (quote-syntax ~bind) 122 (quote-syntax ~fail) 123 (quote-syntax ~parse) 124 (quote-syntax ~do) 125 (quote-syntax ~undo) 126 (quote-syntax ...+) 127 (quote-syntax ~delimit-cut) 128 (quote-syntax ~commit) 129 (quote-syntax ~reflect) 130 (quote-syntax ~splicing-reflect) 131 (quote-syntax ~eh-var) 132 (quote-syntax ~peek) 133 (quote-syntax ~peek-not))) 134 135 (define (reserved? stx) 136 (and (identifier? stx) 137 (for/or ([kw (in-list keywords)]) 138 (free-identifier=? stx kw)))) 139 140 (define (safe-name? stx) 141 (and (identifier? stx) 142 (not (regexp-match? #rx"^~" (symbol->string (syntax-e stx)))))) 143 144 ;; cut-allowed? : (paramter/c boolean?) 145 ;; Used to detect ~cut within ~not pattern. 146 ;; (Also #:no-delimit-cut stxclass within ~not) 147 (define cut-allowed? (make-parameter #t)) 148 149 ;; --- 150 151 (define (disappeared! x) 152 (cond [(identifier? x) 153 (record-disappeared-uses (list x))] 154 [(and (stx-pair? x) (identifier? (stx-car x))) 155 (record-disappeared-uses (list (stx-car x)))] 156 [else 157 (raise-type-error 'disappeared! 158 "identifier or syntax with leading identifier" 159 x)])) 160 161 ;; --- 162 163 ;; parse-rhs : stx boolean (or #f (listof SAttr)) stx -> RHS 164 ;; If expected-attrs is true, then referenced stxclasses must be defined and 165 ;; literals must be bound. Set to #f for pass1 (attr collection); 166 ;; parser requires stxclasses to be bound. 167 (define (parse-rhs stx expected-attrs splicing? #:context ctx) 168 (call/txlifts 169 (lambda () 170 (parameterize ((current-syntax-context ctx)) 171 (define-values (rest description transp? attributes auto-nested? colon-notation? 172 decls defs commit? delimit-cut?) 173 (parse-rhs/part1 stx splicing? (and expected-attrs #t))) 174 (define variants 175 (parameterize ((stxclass-lookup-config 176 (cond [expected-attrs 'yes] 177 [auto-nested? 'try] 178 [else 'no])) 179 (stxclass-colon-notation? colon-notation?)) 180 (parse-variants rest decls splicing? expected-attrs))) 181 (let ([sattrs 182 (or attributes 183 (intersect-sattrss (map variant-attrs variants)))]) 184 (make rhs sattrs transp? description variants 185 (append (get-txlifts-as-definitions) defs) 186 commit? delimit-cut?)))))) 187 188 (define (parse-rhs/part1 stx splicing? strict?) 189 (define-values (chunks rest) 190 (parse-keyword-options stx rhs-directive-table 191 #:context (current-syntax-context) 192 #:incompatible '((#:attributes #:auto-nested-attributes) 193 (#:commit #:no-delimit-cut)) 194 #:no-duplicates? #t)) 195 (define description (options-select-value chunks '#:description #:default #f)) 196 (define opaque? (and (assq '#:opaque chunks) #t)) 197 (define transparent? (not opaque?)) 198 (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t)) 199 (define colon-notation? (not (assq '#:disable-colon-notation chunks))) 200 (define commit? 201 (and (assq '#:commit chunks) #t)) 202 (define delimit-cut? 203 (not (assq '#:no-delimit-cut chunks))) 204 (define attributes (options-select-value chunks '#:attributes #:default #f)) 205 (define-values (decls defs) (get-decls+defs chunks strict?)) 206 (values rest description transparent? attributes auto-nested? colon-notation? 207 decls defs commit? delimit-cut?)) 208 209 ;; ---- 210 211 (define (parse-variants rest decls splicing? expected-attrs) 212 (define (gather-variants stx) 213 (syntax-case stx (pattern) 214 [((pattern . _) . rest) 215 (begin (disappeared! (stx-car stx)) 216 (cons (parse-variant (stx-car stx) splicing? decls expected-attrs) 217 (gather-variants #'rest)))] 218 [(bad-variant . rest) 219 (wrong-syntax #'bad-variant "expected syntax-class variant")] 220 [() 221 null])) 222 (gather-variants rest)) 223 224 ;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax)) 225 (define (get-decls+defs chunks strict? 226 #:context [ctx (current-syntax-context)]) 227 (parameterize ((current-syntax-context ctx)) 228 (let*-values ([(decls defs1) (get-decls chunks strict?)] 229 [(decls defs2) (decls-create-defs decls)]) 230 (values decls (append defs1 defs2))))) 231 232 ;; get-decls : chunks -> (values DeclEnv (listof syntax)) 233 (define (get-decls chunks strict?) 234 (define lits (options-select-value chunks '#:literals #:default null)) 235 (define datum-lits (options-select-value chunks '#:datum-literals #:default null)) 236 (define litsets (options-select-value chunks '#:literal-sets #:default null)) 237 (define convs (options-select-value chunks '#:conventions #:default null)) 238 (define localconvs (options-select-value chunks '#:local-conventions #:default null)) 239 (define literals 240 (append/check-lits+litsets lits datum-lits litsets)) 241 (define-values (convs-rules convs-defs) 242 (for/fold ([convs-rules null] [convs-defs null]) 243 ([conv-entry (in-list convs)]) 244 (let* ([c (car conv-entry)] 245 [argu (cdr conv-entry)] 246 [get-parser-id (conventions-get-procedures c)] 247 [rules ((conventions-get-rules c))]) 248 (values (append rules convs-rules) 249 (cons (make-conventions-def (map cadr rules) get-parser-id argu) 250 convs-defs))))) 251 (define convention-rules (append localconvs convs-rules)) 252 (values (new-declenv literals #:conventions convention-rules) 253 (reverse convs-defs))) 254 255 ;; make-conventions-def : (listof den:delay) id Argument -> syntax 256 (define (make-conventions-def dens get-parsers-id argu) 257 (with-syntax ([(parser ...) (map den:delayed-parser dens)] 258 [get-parsers get-parsers-id] 259 [argu argu]) 260 #'(define-values (parser ...) 261 (apply values (app-argu get-parsers argu))))) 262 263 ;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) 264 (define (decls-create-defs decls0) 265 (define (updater key value defs) 266 (let-values ([(value newdefs) (create-aux-def value)]) 267 (values value (append newdefs defs)))) 268 (declenv-update/fold decls0 updater null)) 269 270 ;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx)) 271 ;; FIXME: replace with txlift mechanism 272 (define (create-aux-def entry) 273 (match entry 274 [(? den:lit?) 275 (values entry null)] 276 [(? den:datum-lit?) 277 (values entry null)] 278 [(? den:magic-class?) 279 (values entry null)] 280 [(den:class name class argu) 281 ;; FIXME: integrable syntax classes? 282 ;; FIXME: what if no-arity, no-args? 283 (cond [(identifier? name) 284 (let* ([pos-count (length (arguments-pargs argu))] 285 [kws (arguments-kws argu)] 286 [sc (get-stxclass/check-arity class class pos-count kws)]) 287 (with-syntax ([sc-parser (stxclass-parser sc)]) 288 (with-syntax ([parser (generate-temporary class)]) 289 (values (make den:parser #'parser 290 (stxclass-attrs sc) (stxclass/h? sc) 291 (stxclass-opts sc)) 292 (list #`(define-values (parser) 293 (curried-stxclass-parser #,class #,argu)))))))] 294 [(regexp? name) 295 ;; Conventions rule; delay class lookup until module/intdefs pass2 296 ;; to allow forward references 297 (with-syntax ([parser (generate-temporary class)] 298 [description (generate-temporary class)]) 299 (values (make den:delayed #'parser class) 300 (list #`(define-values (parser) 301 (curried-stxclass-parser #,class #,argu)))))])] 302 [(? den:parser?) 303 (values entry null)] 304 [(? den:delayed?) 305 (values entry null)])) 306 307 ;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit)) 308 (define (append/check-lits+litsets lits datum-lits litsets) 309 (define seen (make-bound-id-table)) 310 (define (check-id id [blame-ctx id]) 311 (if (bound-id-table-ref seen id #f) 312 (wrong-syntax blame-ctx "duplicate literal declaration: ~s" (syntax-e id)) 313 (bound-id-table-set! seen id #t)) 314 id) 315 (let* ([litsets* 316 (for/list ([entry (in-list litsets)]) 317 (let ([litset-id (first entry)] 318 [litset (second entry)] 319 [lctx (third entry)] 320 [input-phase (fourth entry)]) 321 (define (get/check-id sym) 322 (check-id (datum->syntax lctx sym) litset-id)) 323 (for/list ([lse (in-list (literalset-literals litset))]) 324 (match lse 325 [(lse:lit internal external lit-phase) 326 (let ([internal (get/check-id internal)] 327 [external (syntax-property external 'literal (gensym))]) 328 (make den:lit internal external input-phase lit-phase))] 329 [(lse:datum-lit internal external) 330 (let ([internal (get/check-id internal)]) 331 (make den:datum-lit internal external))]))))] 332 [lits* 333 (for/list ([lit (in-list lits)]) 334 (check-id (den:lit-internal lit)) 335 lit)] 336 [datum-lits* 337 (for/list ([datum-lit (in-list datum-lits)]) 338 (check-id (den:datum-lit-internal datum-lit)) 339 datum-lit)]) 340 (apply append lits* datum-lits* litsets*))) 341 342 ;; parse-variant : stx boolean DeclEnv #f/(listof Sattr) -> RHS 343 (define (parse-variant stx splicing? decls0 expected-attrs) 344 (syntax-case stx (pattern) 345 [(pattern p . rest) 346 (let-values ([(rest pattern defs) 347 (parse-pattern+sides #'p #'rest 348 #:splicing? splicing? 349 #:decls decls0 350 #:context stx)]) 351 (disappeared! stx) 352 (unless (stx-null? rest) 353 (wrong-syntax (if (pair? rest) (car rest) rest) 354 "unexpected terms after pattern directives")) 355 (let* ([attrs (pattern-attrs pattern)] 356 [sattrs (iattrs->sattrs attrs)]) 357 (when expected-attrs 358 (parameterize ((current-syntax-context stx)) 359 ;; Called just for error-reporting 360 (reorder-iattrs expected-attrs attrs))) 361 (make variant stx sattrs pattern defs)))])) 362 363 ;; parse-pattern+sides : stx stx <options> -> (values stx Pattern (listof stx)) 364 ;; Parses pattern, side clauses; desugars side clauses & merges with pattern 365 (define (parse-pattern+sides p-stx s-stx 366 #:splicing? splicing? 367 #:decls decls0 368 #:context ctx) 369 (let-values ([(rest decls defs sides) 370 (parse-pattern-directives s-stx 371 #:allow-declare? #t 372 #:decls decls0 373 #:context ctx)]) 374 (let* ([pattern0 (parse-whole-pattern p-stx decls splicing? #:context ctx #:kind 'main)] 375 [pattern (combine-pattern+sides pattern0 sides splicing?)]) 376 (values rest pattern defs)))) 377 378 ;; parse-whole-pattern : stx DeclEnv boolean -> Pattern 379 ;; kind is either 'main or 'with, indicates what kind of pattern declare affects 380 (define (parse-whole-pattern stx decls [splicing? #f] 381 #:kind kind 382 #:context [ctx (current-syntax-context)]) 383 (parameterize ((current-syntax-context ctx)) 384 (define pattern 385 (if splicing? 386 (parse-head-pattern stx decls) 387 (parse-single-pattern stx decls))) 388 (define pvars (map attr-name (pattern-attrs pattern))) 389 (define excess-domain (declenv-domain-difference decls pvars)) 390 (when (pair? excess-domain) 391 (wrong-syntax (car excess-domain) 392 (string-append 393 "identifier in #:declare clause does not appear in pattern" 394 (case kind 395 [(main) ""] ;; ";\n this #:declare clause affects only the main pattern"] 396 [(with) ";\n this #:declare clause affects only the preceding #:with pattern"])))) 397 pattern)) 398 399 ;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern 400 (define (combine-pattern+sides pattern sides splicing?) 401 (check-pattern 402 (cond [(pair? sides) 403 (define actions-pattern 404 (create-action:and (ord-and-patterns sides (gensym*)))) 405 (define and-patterns 406 (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any))) 407 (gensym*))) 408 (cond [splicing? (apply hpat:and and-patterns)] 409 [else (pat:and and-patterns)])] 410 [else pattern]))) 411 412 ;; gensym* : -> UninternedSymbol 413 ;; Like gensym, but with deterministic name from compilation-local counter. 414 (define gensym*-counter 0) 415 (define (gensym*) 416 (set! gensym*-counter (add1 gensym*-counter)) 417 (string->uninterned-symbol (format "group~a" gensym*-counter))) 418 419 ;; ---- 420 421 ;; parse-single-pattern : stx DeclEnv -> SinglePattern 422 (define (parse-single-pattern stx decls) 423 (parse-*-pattern stx decls #f #f)) 424 425 ;; parse-head-pattern : stx DeclEnv -> HeadPattern 426 (define (parse-head-pattern stx decls) 427 (parse-*-pattern stx decls #t #f)) 428 429 ;; parse-action-pattern : Stx DeclEnv -> ActionPattern 430 (define (parse-action-pattern stx decls) 431 (define p (parse-*-pattern stx decls #f #t)) 432 (unless (action-pattern? p) 433 (wrong-syntax stx "expected action pattern")) 434 p) 435 436 (define ((make-not-shadowed? decls) id) 437 ;; Returns #f if id is in literals/datum-literals list. 438 ;; Conventions to not shadow pattern-form bindings, under the 439 ;; theory that conventions only apply to things already determined 440 ;; to be pattern variables. 441 (not (declenv-lookup decls id))) 442 ;; suitable as id=? argument to syntax-case* 443 (define ((make-not-shadowed-id=? decls) lit-id pat-id) 444 (and (free-identifier=? lit-id pat-id) 445 (not (declenv-lookup decls pat-id)))) 446 447 ;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern 448 (define (parse-*-pattern stx decls allow-head? allow-action?) 449 (define (recur stx) 450 (parse-*-pattern stx decls allow-head? allow-action?)) 451 (define (check-head! x) 452 (unless allow-head? 453 (wrong-syntax stx "head pattern not allowed here")) 454 x) 455 (define (check-action! x) 456 ;; Coerce to S-pattern IF only S-patterns allowed 457 (cond [allow-action? x] 458 [(not allow-head?) (action-pattern->single-pattern x)] 459 [else 460 (wrong-syntax stx "action pattern not allowed here")])) 461 (define not-shadowed? (make-not-shadowed? decls)) 462 (check-pattern 463 (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe 464 ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo 465 ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect 466 ~splicing-reflect) 467 (make-not-shadowed-id=? decls) 468 [id 469 (and (identifier? #'id) 470 (not-shadowed? #'id) 471 (pattern-expander? (syntax-local-value #'id (λ () #f)))) 472 (begin (disappeared! #'id) 473 (recur (expand-pattern (syntax-local-value #'id) stx)))] 474 [(id . rst) 475 (and (identifier? #'id) 476 (not-shadowed? #'id) 477 (pattern-expander? (syntax-local-value #'id (λ () #f)))) 478 (begin (disappeared! #'id) 479 (recur (expand-pattern (syntax-local-value #'id) stx)))] 480 [wildcard 481 (and (wildcard? #'wildcard) 482 (not-shadowed? #'wildcard)) 483 (begin (disappeared! stx) 484 (pat:any))] 485 [~! 486 (disappeared! stx) 487 (begin 488 (unless (cut-allowed?) 489 (wrong-syntax stx 490 "cut (~~!) not allowed within ~~not pattern")) 491 (check-action! 492 (action:cut)))] 493 [reserved 494 (and (reserved? #'reserved) 495 (not-shadowed? #'reserved)) 496 (wrong-syntax stx "pattern keyword not allowed here")] 497 [id 498 (identifier? #'id) 499 (parse-pat:id stx decls allow-head?)] 500 [datum 501 (atomic-datum-stx? #'datum) 502 (pat:datum (syntax->datum #'datum))] 503 [(~var . rest) 504 (disappeared! stx) 505 (parse-pat:var stx decls allow-head?)] 506 [(~datum . rest) 507 (disappeared! stx) 508 (syntax-case stx (~datum) 509 [(~datum d) 510 (pat:datum (syntax->datum #'d))] 511 [_ (wrong-syntax stx "bad ~~datum form")])] 512 [(~literal . rest) 513 (disappeared! stx) 514 (parse-pat:literal stx decls)] 515 [(~and . rest) 516 (disappeared! stx) 517 (parse-pat:and stx decls allow-head? allow-action?)] 518 [(~or . rest) 519 (disappeared! stx) 520 (parse-pat:or stx decls allow-head?)] 521 [(~or* . rest) 522 (disappeared! stx) 523 (parse-pat:or stx decls allow-head?)] 524 [(~alt . rest) 525 (wrong-syntax stx "ellipsis-head pattern allowed only before ellipsis")] 526 [(~not . rest) 527 (disappeared! stx) 528 (parse-pat:not stx decls)] 529 [(~rest . rest) 530 (disappeared! stx) 531 (parse-pat:rest stx decls)] 532 [(~describe . rest) 533 (disappeared! stx) 534 (parse-pat:describe stx decls allow-head?)] 535 [(~delimit-cut . rest) 536 (disappeared! stx) 537 (parse-pat:delimit stx decls allow-head?)] 538 [(~commit . rest) 539 (disappeared! stx) 540 (parse-pat:commit stx decls allow-head?)] 541 [(~reflect . rest) 542 (disappeared! stx) 543 (parse-pat:reflect stx decls #f)] 544 [(~seq . rest) 545 (disappeared! stx) 546 (check-head! 547 (parse-hpat:seq stx #'rest decls))] 548 [(~optional . rest) 549 (disappeared! stx) 550 (check-head! 551 (parse-hpat:optional stx decls))] 552 [(~splicing-reflect . rest) 553 (disappeared! stx) 554 (check-head! 555 (parse-pat:reflect stx decls #t))] 556 [(~bind . rest) 557 (disappeared! stx) 558 (check-action! 559 (parse-pat:bind stx decls))] 560 [(~fail . rest) 561 (disappeared! stx) 562 (check-action! 563 (parse-pat:fail stx decls))] 564 [(~post . rest) 565 (disappeared! stx) 566 (parse-pat:post stx decls allow-head? allow-action?)] 567 [(~peek . rest) 568 (disappeared! stx) 569 (check-head! 570 (parse-pat:peek stx decls))] 571 [(~peek-not . rest) 572 (disappeared! stx) 573 (check-head! 574 (parse-pat:peek-not stx decls))] 575 [(~parse . rest) 576 (disappeared! stx) 577 (check-action! 578 (parse-pat:parse stx decls))] 579 [(~do . rest) 580 (disappeared! stx) 581 (check-action! 582 (parse-pat:do stx decls))] 583 [(~undo . rest) 584 (disappeared! stx) 585 (check-action! 586 (parse-pat:undo stx decls))] 587 [(head dots . tail) 588 (and (dots? #'dots) (not-shadowed? #'dots)) 589 (begin (disappeared! #'dots) 590 (parse-pat:dots stx #'head #'tail decls))] 591 [(head plus-dots . tail) 592 (and (plus-dots? #'plus-dots) (not-shadowed? #'plus-dots)) 593 (begin (disappeared! #'plus-dots) 594 (parse-pat:plus-dots stx #'head #'tail decls))] 595 [(head . tail) 596 (let ([headp (parse-*-pattern #'head decls #t #t)] 597 [tailp (parse-single-pattern #'tail decls)]) 598 (cond [(action-pattern? headp) 599 (pat:action headp tailp)] 600 [(head-pattern? headp) 601 (pat:head headp tailp)] 602 [else (pat:pair headp tailp)]))] 603 [#(a ...) 604 (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) 605 (pat:vector lp))] 606 [b 607 (box? (syntax-e #'b)) 608 (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) 609 (pat:box bp))] 610 [s 611 (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s))) 612 (let* ([s (syntax-e #'s)] 613 [key (prefab-struct-key s)] 614 [contents (struct->list s)]) 615 (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) 616 (pat:pstruct key lp)))]))) 617 618 ;; expand-pattern : pattern-expander Syntax -> Syntax 619 (define (expand-pattern pe stx) 620 (let ([proc (pattern-expander-proc pe)]) 621 (local-apply-transformer proc stx 'expression))) 622 623 ;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) 624 (define (parse-ellipsis-head-pattern stx decls) 625 (for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))]) 626 (car ehpat+hstx))) 627 628 ;; parse*-ellipsis-head-pattern : stx DeclEnv bool 629 ;; -> (listof (list EllipsisHeadPattern stx/eh-alternative)) 630 (define (parse*-ellipsis-head-pattern stx decls allow-or? 631 #:context [ctx (current-syntax-context)]) 632 (define (recur stx) (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx)) 633 (define (recur-cdr-list stx) 634 (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) 635 (apply append (map recur (cdr (stx->list stx))))) 636 (define not-shadowed? (make-not-shadowed? decls)) 637 (syntax-case* stx (~eh-var ~or ~alt ~between ~optional ~once) 638 (make-not-shadowed-id=? decls) 639 [id 640 (and (identifier? #'id) 641 (not-shadowed? #'id) 642 (pattern-expander? (syntax-local-value #'id (lambda () #f)))) 643 (begin (disappeared! #'id) 644 (recur (expand-pattern (syntax-local-value #'id) stx)))] 645 [(id . rst) 646 (and (identifier? #'id) 647 (not-shadowed? #'id) 648 (pattern-expander? (syntax-local-value #'id (lambda () #f)))) 649 (begin (disappeared! #'id) 650 (recur (expand-pattern (syntax-local-value #'id) stx)))] 651 [(~eh-var name eh-alt-set-id) 652 (disappeared! stx) 653 (let () 654 (define prefix (name->prefix #'name ".")) 655 (define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id)) 656 (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))]) 657 (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] 658 [attr-count (length iattrs)]) 659 (list (create-ehpat 660 (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs #f 661 (scopts attr-count #f #t #f)) 662 (eh-alternative-repc alt) 663 #f) 664 (replace-eh-alternative-attrs 665 alt (iattrs->sattrs iattrs))))))] 666 [(~or . _) 667 (disappeared! stx) 668 (recur-cdr-list stx)] 669 [(~alt . _) 670 (disappeared! stx) 671 (recur-cdr-list stx)] 672 [(~optional . _) 673 (disappeared! stx) 674 (list (parse*-ehpat/optional stx decls))] 675 [(~once . _) 676 (disappeared! stx) 677 (list (parse*-ehpat/once stx decls))] 678 [(~between . _) 679 (disappeared! stx) 680 (list (parse*-ehpat/bounds stx decls))] 681 [_ 682 (let ([head (parse-head-pattern stx decls)]) 683 (list (list (create-ehpat head #f stx) stx)))])) 684 685 (define (replace-eh-alternative-attrs alt sattrs) 686 (match alt 687 [(eh-alternative repc _attrs parser) 688 (eh-alternative repc sattrs parser)])) 689 690 ;; ---- 691 692 (define (check-no-delimit-cut-in-not id delimit-cut?) 693 (unless (or delimit-cut? (cut-allowed?)) 694 (wrong-syntax id 695 (string-append "syntax class with #:no-delimit-cut option " 696 "not allowed within ~~not pattern")))) 697 698 (define (parse-pat:id id decls allow-head?) 699 (cond [(declenv-lookup decls id) 700 => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] 701 [(not (safe-name? id)) 702 (wrong-syntax id "expected identifier not starting with ~~ character")] 703 [else 704 (let-values ([(name suffix) (split-id/get-stxclass id decls)]) 705 (cond [(stxclass? suffix) 706 (parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)] 707 [(or (den:lit? suffix) (den:datum-lit? suffix)) 708 (pat:and 709 (list (pat:svar name) 710 (parse-pat:id/entry id allow-head? suffix)))] 711 [(declenv-apply-conventions decls id) 712 => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] 713 [else (pat:svar name)]))])) 714 715 ;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern 716 ;; Handle when meaning of identifier pattern is given by declenv entry. 717 (define (parse-pat:id/entry id allow-head? entry) 718 (match entry 719 [(den:lit internal literal input-phase lit-phase) 720 (pat:literal literal input-phase lit-phase)] 721 [(den:datum-lit internal sym) 722 (pat:datum sym)] 723 [(den:magic-class name class argu role) 724 (let* ([pos-count (length (arguments-pargs argu))] 725 [kws (arguments-kws argu)] 726 [sc (get-stxclass/check-arity class class pos-count kws)]) 727 (parse-pat:var/sc id allow-head? id sc argu "." role #f))] 728 [(den:class _n _c _a) 729 (error 'parse-pat:id 730 "(internal error) decls had leftover stxclass entry: ~s" 731 entry)] 732 [(den:parser parser attrs splicing? opts) 733 (check-no-delimit-cut-in-not id (scopts-delimit-cut? opts)) 734 (cond [splicing? 735 (unless allow-head? 736 (wrong-syntax id "splicing syntax class not allowed here")) 737 (parse-pat:id/h id parser no-arguments attrs "." #f opts)] 738 [else 739 (parse-pat:id/s id parser no-arguments attrs "." #f opts)])] 740 [(den:delayed parser class) 741 (let ([sc (get-stxclass class)]) 742 (parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))])) 743 744 (define (parse-pat:var stx decls allow-head?) 745 (define name0 746 (syntax-case stx () 747 [(_ name . _) 748 (unless (identifier? #'name) 749 (wrong-syntax #'name "expected identifier")) 750 #'name] 751 [_ 752 (wrong-syntax stx "bad ~~var form")])) 753 (define-values (scname sc+args-stx argu pfx role) 754 (syntax-case stx () 755 [(_ _name) 756 (values #f #f null #f #f)] 757 [(_ _name sc/sc+args . rest) 758 (let-values ([(sc argu) 759 (let ([p (check-stxclass-application #'sc/sc+args stx)]) 760 (values (car p) (cdr p)))]) 761 (define chunks 762 (parse-keyword-options/eol #'rest var-pattern-directive-table 763 #:no-duplicates? #t 764 #:context stx)) 765 (define sep 766 (options-select-value chunks '#:attr-name-separator #:default #f)) 767 (define role (options-select-value chunks '#:role #:default #'#f)) 768 (values sc #'sc/sc+args argu (if sep (syntax-e sep) ".") role))] 769 [_ 770 (wrong-syntax stx "bad ~~var form")])) 771 (cond [(and (epsilon? name0) (not scname)) 772 (wrong-syntax name0 "illegal pattern variable name")] 773 [(and (wildcard? name0) (not scname)) 774 (pat:any)] 775 [scname 776 (let ([sc (get-stxclass/check-arity scname sc+args-stx 777 (length (arguments-pargs argu)) 778 (arguments-kws argu))]) 779 (parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))] 780 [else ;; Just proper name 781 (pat:svar name0)])) 782 783 (define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*) 784 ;; if parser* not #f, overrides sc parser 785 (check-no-delimit-cut-in-not stx (scopts-delimit-cut? (stxclass-opts sc))) 786 (cond [(and (stxclass/s? sc) 787 (stxclass-inline sc) 788 (equal? argu no-arguments)) 789 (parse-pat:id/s/integrate name (stxclass-inline sc) (scopts-desc (stxclass-opts sc)) role)] 790 [(stxclass/s? sc) 791 (parse-pat:id/s name 792 (or parser* (stxclass-parser sc)) 793 argu 794 (stxclass-attrs sc) 795 pfx 796 role 797 (stxclass-opts sc))] 798 [(stxclass/h? sc) 799 (unless allow-head? 800 (wrong-syntax stx "splicing syntax class not allowed here")) 801 (parse-pat:id/h name 802 (or parser* (stxclass-parser sc)) 803 argu 804 (stxclass-attrs sc) 805 pfx 806 role 807 (stxclass-opts sc))])) 808 809 (define (parse-pat:id/s name parser argu attrs pfx role opts) 810 (define prefix (name->prefix name pfx)) 811 (define bind (name->bind name)) 812 (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts)) 813 814 (define (parse-pat:id/s/integrate name predicate description role) 815 (define bind (name->bind name)) 816 (pat:integrated bind predicate description role)) 817 818 (define (parse-pat:id/h name parser argu attrs pfx role opts) 819 (define prefix (name->prefix name pfx)) 820 (define bind (name->bind name)) 821 (hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts)) 822 823 (define (name->prefix id pfx) 824 (cond [(wildcard? id) #f] 825 [(epsilon? id) id] 826 [else (format-id id "~a~a" (syntax-e id) pfx #:source id)])) 827 828 (define (name->bind id) 829 (cond [(wildcard? id) #f] 830 [(epsilon? id) #f] 831 [else id])) 832 833 ;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr) 834 (define (id-pattern-attrs sattrs prefix) 835 (if prefix 836 (for/list ([a (in-list sattrs)]) 837 (prefix-attr a prefix)) 838 null)) 839 840 ;; prefix-attr : SAttr identifier -> IAttr 841 (define (prefix-attr a prefix) 842 (make attr (prefix-attr-name prefix (attr-name a)) 843 (attr-depth a) 844 (attr-syntax? a))) 845 846 ;; prefix-attr-name : id symbol -> id 847 (define (prefix-attr-name prefix name) 848 (orig (format-id prefix "~a~a" (syntax-e prefix) name #:source prefix))) 849 850 (define (orig stx) 851 (syntax-property stx 'original-for-check-syntax #t)) 852 853 ;; ---- 854 855 (define (parse-pat:reflect stx decls splicing?) 856 (syntax-case stx () 857 [(_ name (obj arg ...) . maybe-signature) 858 (let () 859 (unless (identifier? #'var) 860 (raise-syntax-error #f "expected identifier" stx #'name)) 861 (define attr-decls 862 (syntax-case #'maybe-signature () 863 [(#:attributes attr-decls) 864 (check-attr-arity-list #'attr-decls stx)] 865 [() null] 866 [_ (raise-syntax-error #f "bad syntax" stx)])) 867 (define prefix (name->prefix #'name ".")) 868 (define bind (name->bind #'name)) 869 (define ctor (if splicing? hpat:reflect pat:reflect)) 870 (ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind 871 (id-pattern-attrs attr-decls prefix)))])) 872 873 ;; --- 874 875 (define (parse-pat:literal stx decls) 876 (syntax-case stx () 877 [(_ lit . more) 878 (unless (identifier? #'lit) 879 (wrong-syntax #'lit "expected identifier")) 880 (let* ([chunks (parse-keyword-options/eol #'more phase-directive-table 881 #:no-duplicates? #t 882 #:context stx)] 883 [phase (options-select-value chunks '#:phase 884 #:default #'(syntax-local-phase-level))]) 885 ;; FIXME: Duplicates phase expr! 886 (pat:literal #'lit phase phase))] 887 [_ 888 (wrong-syntax stx "bad ~~literal pattern")])) 889 890 (define (parse-pat:describe stx decls allow-head?) 891 (syntax-case stx () 892 [(_ . rest) 893 (let-values ([(chunks rest) 894 (parse-keyword-options #'rest describe-option-table 895 #:no-duplicates? #t 896 #:context stx)]) 897 (define transparent? (not (assq '#:opaque chunks))) 898 (define role (options-select-value chunks '#:role #:default #'#f)) 899 (syntax-case rest () 900 [(description pattern) 901 (let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) 902 (if (head-pattern? p) 903 (hpat:describe p #'description transparent? role) 904 (pat:describe p #'description transparent? role)))]))])) 905 906 (define (parse-pat:delimit stx decls allow-head?) 907 (syntax-case stx () 908 [(_ pattern) 909 (let ([p (parameterize ((cut-allowed? #t)) 910 (parse-*-pattern #'pattern decls allow-head? #f))]) 911 (if (head-pattern? p) 912 (hpat:delimit p) 913 (pat:delimit p)))])) 914 915 (define (parse-pat:commit stx decls allow-head?) 916 (syntax-case stx () 917 [(_ pattern) 918 (let ([p (parameterize ((cut-allowed? #t)) 919 (parse-*-pattern #'pattern decls allow-head? #f))]) 920 (if (head-pattern? p) 921 (hpat:commit p) 922 (pat:commit p)))])) 923 924 (define (split-prefix xs pred) 925 (let loop ([xs xs] [rprefix null]) 926 (cond [(and (pair? xs) (pred (car xs))) 927 (loop (cdr xs) (cons (car xs) rprefix))] 928 [else 929 (values (reverse rprefix) xs)]))) 930 931 (define (parse-pat:and stx decls allow-head? allow-action?) 932 ;; allow-action? = allowed to *return* pure action pattern; 933 ;; all ~and patterns are allowed to *contain* action patterns 934 (define patterns0 (parse-cdr-patterns stx decls allow-head? #t)) 935 (define patterns1 (ord-and-patterns patterns0 (gensym*))) 936 (define-values (actions patterns) (split-prefix patterns1 action-pattern?)) 937 (cond [(null? patterns) 938 (cond [allow-action? 939 (action:and actions)] 940 [allow-head? 941 (wrong-syntax stx "expected at least one head pattern")] 942 [else 943 (wrong-syntax stx "expected at least one single-term pattern")])] 944 [else 945 (let ([p (parse-pat:and* stx patterns)]) 946 (if (head-pattern? p) 947 (for/fold ([p p]) ([action (in-list (reverse actions))]) 948 (hpat:action action p)) 949 (for/fold ([p p]) ([action (in-list (reverse actions))]) 950 (pat:action action p))))])) 951 952 (define (parse-pat:and* stx patterns) 953 ;; patterns is non-empty (empty case handled above) 954 (cond [(null? (cdr patterns)) 955 (car patterns)] 956 [(ormap head-pattern? patterns) 957 ;; Check to make sure *all* are head patterns 958 (for ([pattern (in-list patterns)] 959 [pattern-stx (in-list (stx->list (stx-cdr stx)))]) 960 (unless (or (action-pattern? pattern) (head-pattern? pattern)) 961 (wrong-syntax 962 pattern-stx 963 "single-term pattern not allowed after head pattern"))) 964 (let ([p0 (car patterns)] 965 [lps (map action/head-pattern->list-pattern (cdr patterns))]) 966 (hpat:and p0 (pat:and lps)))] 967 [else 968 (pat:and 969 (for/list ([p (in-list patterns)]) 970 (if (action-pattern? p) 971 (action-pattern->single-pattern p) 972 p)))])) 973 974 (define (parse-pat:or stx decls allow-head?) 975 (define patterns (parse-cdr-patterns stx decls allow-head? #f)) 976 (cond [(null? (cdr patterns)) 977 (car patterns)] 978 [else 979 (cond [(ormap head-pattern? patterns) 980 (create-hpat:or patterns)] 981 [else 982 (create-pat:or patterns)])])) 983 984 (define (parse-pat:not stx decls) 985 (syntax-case stx () 986 [(_ pattern) 987 (let ([p (parameterize ((cut-allowed? #f)) 988 (parse-single-pattern #'pattern decls))]) 989 (pat:not p))] 990 [_ 991 (wrong-syntax stx "expected a single subpattern")])) 992 993 (define (parse-hpat:seq stx list-stx decls) 994 (define pattern (parse-single-pattern list-stx decls)) 995 (unless (proper-list-pattern? pattern) 996 (wrong-syntax stx "expected proper list pattern")) 997 (hpat:seq pattern)) 998 999 (define (parse-cdr-patterns stx decls allow-head? allow-action?) 1000 (unless (stx-list? stx) 1001 (wrong-syntax stx "expected sequence of patterns")) 1002 (let ([result 1003 (for/list ([sub (in-list (cdr (stx->list stx)))]) 1004 (parse-*-pattern sub decls allow-head? allow-action?))]) 1005 (when (null? result) 1006 (wrong-syntax stx "expected at least one pattern")) 1007 result)) 1008 1009 (define (parse-pat:dots stx head tail decls) 1010 (define headps (parse-ellipsis-head-pattern head decls)) 1011 (define tailp (parse-single-pattern tail decls)) 1012 (unless (pair? headps) 1013 (wrong-syntax head "expected at least one pattern")) 1014 (pat:dots headps tailp)) 1015 1016 (define (parse-pat:plus-dots stx head tail decls) 1017 (define headp (parse-head-pattern head decls)) 1018 (define tailp (parse-single-pattern tail decls)) 1019 (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f) head)) 1020 (pat:dots (list head/rep) tailp)) 1021 1022 (define (parse-pat:bind stx decls) 1023 (syntax-case stx () 1024 [(_ clause ...) 1025 (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) 1026 (create-action:and clauses))])) 1027 1028 (define (parse-pat:fail stx decls) 1029 (syntax-case stx () 1030 [(_ . rest) 1031 (let-values ([(chunks rest) 1032 (parse-keyword-options #'rest fail-directive-table 1033 #:context stx 1034 #:incompatible '((#:when #:unless)) 1035 #:no-duplicates? #t)]) 1036 (let ([condition 1037 (if (null? chunks) 1038 #'#t 1039 (let ([chunk (car chunks)]) 1040 (if (eq? (car chunk) '#:when) 1041 (caddr chunk) 1042 #`(not #,(caddr chunk)))))]) 1043 (syntax-case rest () 1044 [(message) 1045 (action:fail condition #'message)] 1046 [() 1047 (action:fail condition #''#f)] 1048 [_ 1049 (wrong-syntax stx "bad ~~fail pattern")])))])) 1050 1051 (define (parse-pat:post stx decls allow-head? allow-action?) 1052 (syntax-case stx () 1053 [(_ pattern) 1054 (let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)]) 1055 (cond [(action-pattern? p) 1056 (cond [allow-action? (action:post p)] 1057 [(not allow-head?) (pat:post (action-pattern->single-pattern p))] 1058 [else (wrong-syntax stx "action pattern not allowed here")])] 1059 [(head-pattern? p) 1060 (cond [allow-head? (hpat:post p)] 1061 [else (wrong-syntax stx "head pattern now allowed here")])] 1062 [else (pat:post p)]))])) 1063 1064 (define (parse-pat:peek stx decls) 1065 (syntax-case stx () 1066 [(_ pattern) 1067 (let ([p (parse-head-pattern #'pattern decls)]) 1068 (hpat:peek p))])) 1069 1070 (define (parse-pat:peek-not stx decls) 1071 (syntax-case stx () 1072 [(_ pattern) 1073 (let ([p (parse-head-pattern #'pattern decls)]) 1074 (hpat:peek-not p))])) 1075 1076 (define (parse-pat:parse stx decls) 1077 (syntax-case stx () 1078 [(_ pattern expr) 1079 (let ([p (parse-single-pattern #'pattern decls)]) 1080 (action:parse p #'expr))] 1081 [_ 1082 (wrong-syntax stx "bad ~~parse pattern")])) 1083 1084 (define (parse-pat:do stx decls) 1085 (syntax-case stx () 1086 [(_ stmt ...) 1087 (action:do (syntax->list #'(stmt ...)))] 1088 [_ 1089 (wrong-syntax stx "bad ~~do pattern")])) 1090 1091 (define (parse-pat:undo stx decls) 1092 (syntax-case stx () 1093 [(_ stmt ...) 1094 (action:undo (syntax->list #'(stmt ...)))] 1095 [_ 1096 (wrong-syntax stx "bad ~~undo pattern")])) 1097 1098 (define (parse-pat:rest stx decls) 1099 (syntax-case stx () 1100 [(_ pattern) 1101 (parse-single-pattern #'pattern decls)])) 1102 1103 (define (parse-hpat:optional stx decls) 1104 (define-values (head-stx head iattrs _name _tmm defaults) 1105 (parse*-optional-pattern stx decls h-optional-directive-table)) 1106 (create-hpat:or 1107 (list head 1108 (hpat:action (create-action:and defaults) 1109 (hpat:seq (pat:datum '())))))) 1110 1111 ;; parse*-optional-pattern : stx DeclEnv table 1112 ;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause)) 1113 (define (parse*-optional-pattern stx decls optional-directive-table) 1114 (syntax-case stx () 1115 [(_ p . options) 1116 (let* ([head (parse-head-pattern #'p decls)] 1117 [chunks 1118 (parse-keyword-options/eol #'options optional-directive-table 1119 #:no-duplicates? #t 1120 #:context stx)] 1121 [too-many-msg 1122 (options-select-value chunks '#:too-many #:default #'#f)] 1123 [name 1124 (options-select-value chunks '#:name #:default #'#f)] 1125 [defaults 1126 (options-select-value chunks '#:defaults #:default '())] 1127 [pattern-iattrs (pattern-attrs head)] 1128 [defaults-iattrs 1129 (append-iattrs (map pattern-attrs defaults))] 1130 [all-iattrs 1131 (union-iattrs (list pattern-iattrs defaults-iattrs))]) 1132 (when (eq? (stxclass-lookup-config) 'yes) 1133 ;; Only check that attrs in defaults clause agree with attrs 1134 ;; in pattern when attrs in pattern are known to be complete. 1135 (check-iattrs-subset defaults-iattrs pattern-iattrs stx)) 1136 (values #'p head all-iattrs name too-many-msg defaults))])) 1137 1138 ;; -- EH patterns 1139 ;; Only parse the rep-constraint part; don't parse the head pattern within. 1140 ;; (To support eh-alternative-sets.) 1141 1142 ;; parse*-ehpat/optional : stx DeclEnv -> (list EllipsisHeadPattern stx) 1143 (define (parse*-ehpat/optional stx decls) 1144 (define-values (head-stx head iattrs name too-many-msg defaults) 1145 (parse*-optional-pattern stx decls eh-optional-directive-table)) 1146 (list (create-ehpat head (make rep:optional name too-many-msg defaults) head-stx) 1147 head-stx)) 1148 1149 ;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx) 1150 (define (parse*-ehpat/once stx decls) 1151 (syntax-case stx () 1152 [(_ p . options) 1153 (let* ([head (parse-head-pattern #'p decls)] 1154 [chunks 1155 (parse-keyword-options/eol #'options 1156 (list (list '#:too-few check-expression) 1157 (list '#:too-many check-expression) 1158 (list '#:name check-expression)) 1159 #:context stx)] 1160 [too-few-msg 1161 (options-select-value chunks '#:too-few #:default #'#f)] 1162 [too-many-msg 1163 (options-select-value chunks '#:too-many #:default #'#f)] 1164 [name 1165 (options-select-value chunks '#:name #:default #'#f)]) 1166 (list (create-ehpat head (make rep:once name too-few-msg too-many-msg) #'p) 1167 #'p))])) 1168 1169 ;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx) 1170 (define (parse*-ehpat/bounds stx decls) 1171 (syntax-case stx () 1172 [(_ p min max . options) 1173 (let () 1174 (define head (parse-head-pattern #'p decls)) 1175 (define minN (syntax-e #'min)) 1176 (define maxN (syntax-e #'max)) 1177 (unless (exact-nonnegative-integer? minN) 1178 (wrong-syntax #'min 1179 "expected exact nonnegative integer")) 1180 (unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0)) 1181 (wrong-syntax #'max 1182 "expected exact nonnegative integer or +inf.0")) 1183 (when (> minN maxN) 1184 (wrong-syntax stx "minimum larger than maximum repetition constraint")) 1185 (let* ([chunks (parse-keyword-options/eol 1186 #'options 1187 (list (list '#:too-few check-expression) 1188 (list '#:too-many check-expression) 1189 (list '#:name check-expression)) 1190 #:context stx)] 1191 [too-few-msg 1192 (options-select-value chunks '#:too-few #:default #'#f)] 1193 [too-many-msg 1194 (options-select-value chunks '#:too-many #:default #'#f)] 1195 [name 1196 (options-select-value chunks '#:name #:default #'#f)]) 1197 (list (create-ehpat head 1198 (make rep:bounds #'min #'max 1199 name too-few-msg too-many-msg) 1200 #'p) 1201 #'p)))])) 1202 1203 ;; ----- 1204 1205 ;; parse-pattern-directives : stxs(PatternDirective) <kw-args> 1206 ;; -> stx DeclEnv (listof stx) (listof SideClause) 1207 (define (parse-pattern-directives stx 1208 #:allow-declare? allow-declare? 1209 #:decls decls 1210 #:context ctx) 1211 (parameterize ((current-syntax-context ctx)) 1212 (define-values (chunks rest) 1213 (parse-keyword-options stx pattern-directive-table #:context ctx)) 1214 (define-values (decls2 chunks2) 1215 (if allow-declare? 1216 (grab-decls chunks decls) 1217 (values decls chunks))) 1218 (define sides 1219 ;; NOTE: use *original* decls 1220 ;; because decls2 has #:declares for *above* pattern 1221 (parse-pattern-sides chunks2 decls)) 1222 (define-values (decls3 defs) 1223 (decls-create-defs decls2)) 1224 (values rest decls3 defs sides))) 1225 1226 ;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause) 1227 ;; Invariant: decls contains only literals bindings 1228 (define (parse-pattern-sides chunks decls) 1229 (match chunks 1230 [(cons (list '#:declare declare-stx _ _) rest) 1231 (wrong-syntax declare-stx 1232 "#:declare can only appear immediately after pattern or #:with clause")] 1233 [(cons (list '#:role role-stx _) rest) 1234 (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")] 1235 [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest) 1236 (cons (create-post-pattern (action:fail when-expr msg-expr)) 1237 (parse-pattern-sides rest decls))] 1238 [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest) 1239 (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr)) 1240 (parse-pattern-sides rest decls))] 1241 [(cons (list '#:when w-stx unless-expr) rest) 1242 (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#f)) 1243 (parse-pattern-sides rest decls))] 1244 [(cons (list '#:with with-stx pattern expr) rest) 1245 (let-values ([(decls2 rest) (grab-decls rest decls)]) 1246 (let-values ([(decls2a defs) (decls-create-defs decls2)]) 1247 (list* (action:do defs) 1248 (create-post-pattern 1249 (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)) 1250 (parse-pattern-sides rest decls))))] 1251 [(cons (list '#:attr attr-stx a expr) rest) 1252 (cons (action:bind a expr) ;; no POST wrapper, cannot fail 1253 (parse-pattern-sides rest decls))] 1254 [(cons (list '#:post post-stx pattern) rest) 1255 (cons (create-post-pattern (parse-action-pattern pattern decls)) 1256 (parse-pattern-sides rest decls))] 1257 [(cons (list '#:and and-stx pattern) rest) 1258 (cons (parse-action-pattern pattern decls) ;; no POST wrapper 1259 (parse-pattern-sides rest decls))] 1260 [(cons (list '#:do do-stx stmts) rest) 1261 (cons (action:do stmts) 1262 (parse-pattern-sides rest decls))] 1263 [(cons (list '#:undo undo-stx stmts) rest) 1264 (cons (action:undo stmts) 1265 (parse-pattern-sides rest decls))] 1266 [(cons (list '#:cut cut-stx) rest) 1267 (cons (action:cut) 1268 (parse-pattern-sides rest decls))] 1269 ['() 1270 '()])) 1271 1272 ;; grab-decls : (listof chunk) DeclEnv 1273 ;; -> (values DeclEnv (listof chunk)) 1274 (define (grab-decls chunks decls0) 1275 (define (add-decl stx role-stx decls) 1276 (let ([role 1277 (and role-stx 1278 (syntax-case role-stx () 1279 [(#:role role) #'role]))]) 1280 (syntax-case stx () 1281 [(#:declare name sc) 1282 (identifier? #'sc) 1283 (add-decl* decls #'name #'sc (parse-argu null) role)] 1284 [(#:declare name (sc expr ...)) 1285 (identifier? #'sc) 1286 (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)] 1287 [(#:declare name bad-sc) 1288 (wrong-syntax #'bad-sc 1289 "expected syntax class name (possibly with parameters)")]))) 1290 (define (add-decl* decls id sc-name argu role) 1291 (declenv-put-stxclass decls id sc-name argu role)) 1292 (define (loop chunks decls) 1293 (match chunks 1294 [(cons (cons '#:declare decl-stx) 1295 (cons (cons '#:role role-stx) rest)) 1296 (loop rest (add-decl decl-stx role-stx decls))] 1297 [(cons (cons '#:declare decl-stx) rest) 1298 (loop rest (add-decl decl-stx #f decls))] 1299 [_ (values decls chunks)])) 1300 (loop chunks decls0)) 1301 1302 1303 ;; ---- 1304 1305 ;; Keyword Options & Checkers 1306 1307 ;; check-attr-arity-list : stx stx -> (listof SAttr) 1308 (define (check-attr-arity-list stx ctx) 1309 (unless (stx-list? stx) 1310 (raise-syntax-error #f "expected list of attribute declarations" ctx stx)) 1311 (let ([iattrs 1312 (for/list ([x (in-list (stx->list stx))]) 1313 (check-attr-arity x ctx))]) 1314 (iattrs->sattrs (append-iattrs (map list iattrs))))) 1315 1316 ;; check-attr-arity : stx stx -> IAttr 1317 (define (check-attr-arity stx ctx) 1318 (syntax-case stx () 1319 [attr 1320 (identifier? #'attr) 1321 (make-attr #'attr 0 #f)] 1322 [(attr depth) 1323 (begin (unless (identifier? #'attr) 1324 (raise-syntax-error #f "expected attribute name" ctx #'attr)) 1325 (unless (exact-nonnegative-integer? (syntax-e #'depth)) 1326 (raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth)) 1327 (make-attr #'attr (syntax-e #'depth) #f))] 1328 [_ 1329 (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)])) 1330 1331 ;; check-literals-list : stx stx -> (listof den:lit) 1332 ;; - txlifts defs of phase expressions 1333 ;; - txlifts checks that literals are bound 1334 (define (check-literals-list stx ctx) 1335 (unless (stx-list? stx) 1336 (raise-syntax-error #f "expected literals list" ctx stx)) 1337 (for/list ([x (in-list (stx->list stx))]) 1338 (check-literal-entry x ctx))) 1339 1340 ;; check-literal-entry : stx stx -> den:lit 1341 (define (check-literal-entry stx ctx) 1342 (define (go internal external phase) 1343 (txlift #`(check-literal #,external #,phase #,ctx)) 1344 (let ([external (syntax-property external 'literal (gensym))]) 1345 (make den:lit internal external phase phase))) 1346 (syntax-case stx () 1347 [(internal external #:phase phase) 1348 (and (identifier? #'internal) (identifier? #'external)) 1349 (go #'internal #'external (txlift #'phase))] 1350 [(internal external) 1351 (and (identifier? #'internal) (identifier? #'external)) 1352 (go #'internal #'external #'(syntax-local-phase-level))] 1353 [id 1354 (identifier? #'id) 1355 (go #'id #'id #'(syntax-local-phase-level))] 1356 [_ 1357 (raise-syntax-error #f "expected literal entry" ctx stx)])) 1358 1359 ;; check-datum-literals-list : stx stx -> (listof den:datum-lit) 1360 (define (check-datum-literals-list stx ctx) 1361 (unless (stx-list? stx) 1362 (raise-syntax-error #f "expected datum-literals list" ctx stx)) 1363 (for/list ([x (in-list (stx->list stx))]) 1364 (check-datum-literal-entry x ctx))) 1365 1366 ;; check-datum-literal-entry : stx stx -> den:datum-lit 1367 (define (check-datum-literal-entry stx ctx) 1368 (syntax-case stx () 1369 [(internal external) 1370 (and (identifier? #'internal) (identifier? #'external)) 1371 (make den:datum-lit #'internal (syntax-e #'external))] 1372 [id 1373 (identifier? #'id) 1374 (make den:datum-lit #'id (syntax-e #'id))] 1375 [_ 1376 (raise-syntax-error #f "expected datum-literal entry" ctx stx)])) 1377 1378 ;; Literal sets - Import 1379 1380 ;; check-literal-sets-list : stx stx -> (listof (list id literalset stx stx)) 1381 (define (check-literal-sets-list stx ctx) 1382 (unless (stx-list? stx) 1383 (raise-syntax-error #f "expected literal-set list" ctx stx)) 1384 (for/list ([x (in-list (stx->list stx))]) 1385 (check-literal-set-entry x ctx))) 1386 1387 ;; check-literal-set-entry : stx stx -> (list id literalset stx stx) 1388 (define (check-literal-set-entry stx ctx) 1389 (define (elaborate litset-id lctx phase) 1390 (let ([litset (syntax-local-value/record litset-id literalset?)]) 1391 (unless litset 1392 (raise-syntax-error #f "expected identifier defined as a literal-set" 1393 ctx litset-id)) 1394 (list litset-id litset lctx phase))) 1395 (syntax-case stx () 1396 [(litset . more) 1397 (and (identifier? #'litset)) 1398 (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table 1399 #:no-duplicates? #t 1400 #:context ctx)] 1401 [lctx (options-select-value chunks '#:at #:default #'litset)] 1402 [phase (options-select-value chunks '#:phase 1403 #:default #'(syntax-local-phase-level))]) 1404 (elaborate #'litset lctx (txlift phase)))] 1405 [litset 1406 (identifier? #'litset) 1407 (elaborate #'litset #'litset #'(syntax-local-phase-level))] 1408 [_ 1409 (raise-syntax-error #f "expected literal-set entry" ctx stx)])) 1410 1411 ;; Conventions 1412 1413 ;; returns (listof (cons Conventions (listof syntax))) 1414 (define (check-conventions-list stx ctx) 1415 (unless (stx-list? stx) 1416 (raise-syntax-error #f "expected conventions list" ctx stx)) 1417 (for/list ([x (in-list (stx->list stx))]) 1418 (check-conventions x ctx))) 1419 1420 ;; returns (cons Conventions (listof syntax)) 1421 (define (check-conventions stx ctx) 1422 (define (elaborate conventions-id argu) 1423 (let ([cs (syntax-local-value/record conventions-id conventions?)]) 1424 (unless cs 1425 (raise-syntax-error #f "expected identifier defined as a conventions" 1426 ctx conventions-id)) 1427 (cons cs argu))) 1428 (syntax-case stx () 1429 [(conventions arg ...) 1430 (identifier? #'conventions) 1431 (elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))] 1432 [conventions 1433 (identifier? #'conventions) 1434 (elaborate #'conventions no-arguments)] 1435 [_ 1436 (raise-syntax-error "expected conventions entry" ctx stx)])) 1437 1438 ;; returns (listof (list regexp DeclEntry)) 1439 (define (check-conventions-rules stx ctx) 1440 (unless (stx-list? stx) 1441 (raise-syntax-error #f "expected convention rule list" ctx stx)) 1442 (for/list ([x (in-list (stx->list stx))]) 1443 (check-conventions-rule x ctx))) 1444 1445 ;; returns (list regexp DeclEntry) 1446 (define (check-conventions-rule stx ctx) 1447 (define (check-conventions-pattern x blame) 1448 (cond [(symbol? x) 1449 (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] 1450 [(regexp? x) x] 1451 [else 1452 (raise-syntax-error #f "expected identifier convention pattern" 1453 ctx blame)])) 1454 (define (check-sc-expr x rx) 1455 (let ([x (check-stxclass-application x ctx)]) 1456 (make den:class rx (car x) (cdr x)))) 1457 (syntax-case stx () 1458 [(rx sc) 1459 (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)]) 1460 (list name-pattern (check-sc-expr #'sc name-pattern)))])) 1461 1462 (define (check-stxclass-header stx ctx) 1463 (syntax-case stx () 1464 [name 1465 (identifier? #'name) 1466 (list #'name #'() no-arity)] 1467 [(name . formals) 1468 (identifier? #'name) 1469 (list #'name #'formals (parse-kw-formals #'formals #:context ctx))] 1470 [_ (raise-syntax-error #f "expected syntax class header" stx ctx)])) 1471 1472 (define (check-stxclass-application stx ctx) 1473 ;; Doesn't check "operator" is actually a stxclass 1474 (syntax-case stx () 1475 [op 1476 (identifier? #'op) 1477 (cons #'op no-arguments)] 1478 [(op arg ...) 1479 (identifier? #'op) 1480 (cons #'op (parse-argu (syntax->list #'(arg ...))))] 1481 [_ (raise-syntax-error #f "expected syntax class use" ctx stx)])) 1482 1483 ;; bind clauses 1484 (define (check-bind-clause-list stx ctx) 1485 (unless (stx-list? stx) 1486 (raise-syntax-error #f "expected sequence of bind clauses" ctx stx)) 1487 (for/list ([clause (in-list (stx->list stx))]) 1488 (check-bind-clause clause ctx))) 1489 1490 (define (check-bind-clause clause ctx) 1491 (syntax-case clause () 1492 [(attr-decl expr) 1493 (action:bind (check-attr-arity #'attr-decl ctx) #'expr)] 1494 [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) 1495 1496 (define (check-stmt-list stx ctx) 1497 (syntax-case stx () 1498 [(e ...) 1499 (syntax->list #'(e ...))] 1500 [_ 1501 (raise-syntax-error #f "expected list of expressions and definitions" ctx stx)])) 1502 1503 ;; Arguments and Arities 1504 1505 ;; parse-argu : (listof stx) -> Arguments 1506 (define (parse-argu args #:context [ctx (current-syntax-context)]) 1507 (parameterize ((current-syntax-context ctx)) 1508 (define (loop args rpargs rkws rkwargs) 1509 (cond [(null? args) 1510 (arguments (reverse rpargs) (reverse rkws) (reverse rkwargs))] 1511 [(keyword? (syntax-e (car args))) 1512 (let ([kw (syntax-e (car args))] 1513 [rest (cdr args)]) 1514 (cond [(memq kw rkws) 1515 (wrong-syntax (car args) "duplicate keyword")] 1516 [(null? rest) 1517 (wrong-syntax (car args) 1518 "missing argument expression after keyword")] 1519 #| Overzealous, perhaps? 1520 [(keyword? (syntax-e (car rest))) 1521 (wrong-syntax (car rest) "expected expression following keyword")] 1522 |# 1523 [else 1524 (loop (cdr rest) rpargs (cons kw rkws) (cons (car rest) rkwargs))]))] 1525 [else 1526 (loop (cdr args) (cons (car args) rpargs) rkws rkwargs)])) 1527 (loop args null null null))) 1528 1529 ;; parse-kw-formals : stx -> Arity 1530 (define (parse-kw-formals formals #:context [ctx (current-syntax-context)]) 1531 (parameterize ((current-syntax-context ctx)) 1532 (define id-h (make-bound-id-table)) 1533 (define kw-h (make-hasheq)) ;; keyword => 'mandatory or 'optional 1534 (define pos 0) 1535 (define opts 0) 1536 (define (add-id! id) 1537 (when (bound-id-table-ref id-h id #f) 1538 (wrong-syntax id "duplicate formal parameter" )) 1539 (bound-id-table-set! id-h id #t)) 1540 (define (loop formals) 1541 (cond [(and (stx-pair? formals) (keyword? (syntax-e (stx-car formals)))) 1542 (let* ([kw-stx (stx-car formals)] 1543 [kw (syntax-e kw-stx)] 1544 [rest (stx-cdr formals)]) 1545 (cond [(hash-ref kw-h kw #f) 1546 (wrong-syntax kw-stx "duplicate keyword")] 1547 [(stx-null? rest) 1548 (wrong-syntax kw-stx "missing formal parameter after keyword")] 1549 [else 1550 (let-values ([(formal opt?) (parse-formal (stx-car rest))]) 1551 (add-id! formal) 1552 (hash-set! kw-h kw (if opt? 'optional 'mandatory))) 1553 (loop (stx-cdr rest))]))] 1554 [(stx-pair? formals) 1555 (let-values ([(formal opt?) (parse-formal (stx-car formals))]) 1556 (when (and (positive? opts) (not opt?)) 1557 (wrong-syntax (stx-car formals) 1558 "mandatory argument may not follow optional argument")) 1559 (add-id! formal) 1560 (set! pos (add1 pos)) 1561 (when opt? (set! opts (add1 opts))) 1562 (loop (stx-cdr formals)))] 1563 [(identifier? formals) 1564 (add-id! formals) 1565 (finish #t)] 1566 [(stx-null? formals) 1567 (finish #f)] 1568 [else 1569 (wrong-syntax formals "bad argument sequence")])) 1570 (define (finish has-rest?) 1571 (arity (- pos opts) 1572 (if has-rest? +inf.0 pos) 1573 (sort (for/list ([(k v) (in-hash kw-h)] 1574 #:when (eq? v 'mandatory)) 1575 k) 1576 keyword<?) 1577 (sort (hash-map kw-h (lambda (k v) k)) 1578 keyword<?))) 1579 (loop formals))) 1580 1581 ;; parse-formal : stx -> (values id bool) 1582 (define (parse-formal formal) 1583 (syntax-case formal () 1584 [param 1585 (identifier? #'param) 1586 (values #'param #f)] 1587 [(param default) 1588 (identifier? #'param) 1589 (values #'param #t)] 1590 [_ 1591 (wrong-syntax formal 1592 "expected formal parameter with optional default")])) 1593 1594 1595 ;; Directive tables 1596 1597 ;; common-parse-directive-table 1598 (define common-parse-directive-table 1599 (list (list '#:disable-colon-notation) 1600 (list '#:literals check-literals-list) 1601 (list '#:datum-literals check-datum-literals-list) 1602 (list '#:literal-sets check-literal-sets-list) 1603 (list '#:conventions check-conventions-list) 1604 (list '#:local-conventions check-conventions-rules))) 1605 1606 ;; parse-directive-table 1607 (define parse-directive-table 1608 (list* (list '#:context check-expression) 1609 (list '#:track-literals) 1610 common-parse-directive-table)) 1611 1612 ;; rhs-directive-table 1613 (define rhs-directive-table 1614 (list* (list '#:description check-expression) 1615 (list '#:transparent) 1616 (list '#:opaque) 1617 (list '#:attributes check-attr-arity-list) 1618 (list '#:auto-nested-attributes) 1619 (list '#:commit) 1620 (list '#:no-delimit-cut) 1621 common-parse-directive-table)) 1622 1623 ;; pattern-directive-table 1624 (define pattern-directive-table 1625 (list (list '#:declare check-identifier check-expression) 1626 (list '#:role check-expression) ;; attached to preceding #:declare 1627 (list '#:fail-when check-expression check-expression) 1628 (list '#:fail-unless check-expression check-expression) 1629 (list '#:when check-expression) 1630 (list '#:with check-expression check-expression) 1631 (list '#:attr check-attr-arity check-expression) 1632 (list '#:and check-expression) 1633 (list '#:post check-expression) 1634 (list '#:do check-stmt-list) 1635 (list '#:undo check-stmt-list) 1636 (list '#:cut))) 1637 1638 ;; fail-directive-table 1639 (define fail-directive-table 1640 (list (list '#:when check-expression) 1641 (list '#:unless check-expression))) 1642 1643 ;; describe-option-table 1644 (define describe-option-table 1645 (list (list '#:opaque) 1646 (list '#:role check-expression))) 1647 1648 ;; eh-optional-directive-table 1649 (define eh-optional-directive-table 1650 (list (list '#:too-many check-expression) 1651 (list '#:name check-expression) 1652 (list '#:defaults check-bind-clause-list))) 1653 1654 ;; h-optional-directive-table 1655 (define h-optional-directive-table 1656 (list (list '#:defaults check-bind-clause-list))) 1657 1658 ;; phase-directive-table 1659 (define phase-directive-table 1660 (list (list '#:phase check-expression))) 1661 1662 ;; litset-directive-table 1663 (define litset-directive-table 1664 (cons (list '#:at (lambda (stx ctx) stx)) 1665 phase-directive-table)) 1666 1667 ;; var-pattern-directive-table 1668 (define var-pattern-directive-table 1669 (list (list '#:attr-name-separator check-stx-string) 1670 (list '#:role check-expression)))