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