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