1#lang racket/base 2(require (for-template racket/base 3 syntax/parse/private/keywords 4 syntax/parse/private/residual ;; keep abs. path 5 syntax/parse/private/runtime) 6 racket/list 7 racket/contract/base 8 "make.rkt" 9 "minimatch.rkt" 10 syntax/private/id-table 11 syntax/stx 12 syntax/keyword 13 racket/syntax 14 racket/struct 15 "txlift.rkt" 16 "rep-attrs.rkt" 17 "rep-data.rkt" 18 "rep-patterns.rkt" 19 syntax/parse/private/residual-ct ;; keep abs. path 20 "kws.rkt") 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? boolean? #:context (or/c false/c syntax?)] 32 [#:default-description (or/c #f string?)] 33 rhs?)] 34 [parse-pattern+sides 35 (-> syntax? syntax? 36 #:splicing? boolean? 37 #:decls DeclEnv/c 38 #:context syntax? 39 any)] 40 [parse-EH-variant 41 (-> syntax? DeclEnv/c boolean? 42 #:context syntax? 43 any)] 44 [parse-directive-table any/c] 45 [get-decls+defs 46 (-> list? #: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 [stxclass-colon-notation? 75 (parameter/c boolean?)] 76 [fixup-rhs 77 (-> rhs? boolean? (listof sattr?) rhs?)]) 78 79;; ---- 80 81(define (atomic-datum-stx? stx) 82 (let ([datum (syntax-e stx)]) 83 (or (null? datum) 84 (boolean? datum) 85 (string? datum) 86 (number? datum) 87 (keyword? datum) 88 (bytes? datum) 89 (char? datum) 90 (regexp? datum) 91 (byte-regexp? datum)))) 92 93(define (id-predicate kw) 94 (lambda (stx) 95 (and (identifier? stx) 96 (free-identifier=? stx kw) 97 (begin (disappeared! stx) #t)))) 98 99(define wildcard? (id-predicate (quote-syntax _))) 100(define epsilon? (id-predicate (quote-syntax ||))) 101(define dots? (id-predicate (quote-syntax ...))) 102(define plus-dots? (id-predicate (quote-syntax ...+))) 103 104(define keywords 105 (list (quote-syntax _) 106 (quote-syntax ||) 107 (quote-syntax ...) 108 (quote-syntax ~var) 109 (quote-syntax ~datum) 110 (quote-syntax ~literal) 111 (quote-syntax ~and) 112 (quote-syntax ~or) 113 (quote-syntax ~or*) 114 (quote-syntax ~alt) 115 (quote-syntax ~not) 116 (quote-syntax ~seq) 117 (quote-syntax ~rep) 118 (quote-syntax ~once) 119 (quote-syntax ~optional) 120 (quote-syntax ~between) 121 (quote-syntax ~rest) 122 (quote-syntax ~describe) 123 (quote-syntax ~!) 124 (quote-syntax ~bind) 125 (quote-syntax ~fail) 126 (quote-syntax ~parse) 127 (quote-syntax ~do) 128 (quote-syntax ~undo) 129 (quote-syntax ...+) 130 (quote-syntax ~delimit-cut) 131 (quote-syntax ~commit) 132 (quote-syntax ~reflect) 133 (quote-syntax ~splicing-reflect) 134 (quote-syntax ~eh-var) 135 (quote-syntax ~peek) 136 (quote-syntax ~peek-not))) 137 138(define (reserved? stx) 139 (and (identifier? stx) 140 (for/or ([kw (in-list keywords)]) 141 (free-identifier=? stx kw)))) 142 143(define (safe-name? stx) 144 (and (identifier? stx) 145 (not (regexp-match? #rx"^~" (symbol->string (syntax-e stx)))))) 146 147;; cut-allowed? : (paramter/c boolean?) 148;; Used to detect ~cut within ~not pattern. 149;; (Also #:no-delimit-cut stxclass within ~not) 150(define cut-allowed? (make-parameter #t)) 151 152;; A LookupConfig is one of 'no, 'try, 'yes 153;; 'no means don't lookup, always use dummy (no nested attrs) 154;; 'try means lookup, but on failure use dummy (-> nested attrs only from prev.) 155;; 'yes means lookup, raise error on failure 156 157;; stxclass-lookup-config : parameterof LookupConfig 158(define stxclass-lookup-config (make-parameter 'yes)) 159 160;; stxclass-colon-notation? : (parameterof boolean) 161;; if #t, then x:sc notation means (~var x sc) 162;; otherwise, just a var 163(define stxclass-colon-notation? (make-parameter #t)) 164 165;; disappeared! : (U Identifier (Stxpair Identifier Any)) -> Void 166(define (disappeared! x) 167 (cond [(identifier? x) 168 (record-disappeared-uses (list x))] 169 [(and (stx-pair? x) (identifier? (stx-car x))) 170 (record-disappeared-uses (list (stx-car x)))] 171 [else 172 (raise-type-error 'disappeared! 173 "identifier or syntax with leading identifier" 174 x)])) 175 176(define (propagate-disappeared! stx) 177 (cond [(and (syntax? stx) (syntax-property stx 'disappeared-use)) 178 => (lambda (xs) (record-disappeared-uses (filter identifier? (flatten xs)) #f))])) 179 180 181;; ============================================================ 182;; Entry points to pattern/rhs parsing 183 184;; parse-rhs : Syntax Boolean #:context Syntax #:default-description (U String #f) -> RHS 185(define (parse-rhs stx splicing? #:context ctx #:default-description [default-description #f]) 186 (call/txlifts 187 (lambda () 188 (parameterize ((current-syntax-context ctx)) 189 (define-values (rest description transp? attributes auto-nested? colon-notation? 190 decls defs commit? delimit-cut?) 191 (parse-rhs/part1 stx splicing?)) 192 (define variants 193 (parameterize ((stxclass-lookup-config (if auto-nested? 'try 'no)) 194 (stxclass-colon-notation? colon-notation?)) 195 (parse-variants rest decls splicing?))) 196 (define sattrs 197 (or attributes 198 (filter (lambda (a) (symbol-interned? (attr-name a))) 199 (intersect-sattrss (map variant-attrs variants))))) 200 (make rhs sattrs transp? (or description #`(quote #,default-description)) variants 201 (append (get-txlifts-as-definitions) defs) 202 commit? delimit-cut?))))) 203 204(define (parse-rhs/part1 stx splicing?) 205 (define-values (chunks rest) 206 (parse-keyword-options stx rhs-directive-table 207 #:context (current-syntax-context) 208 #:incompatible '((#:attributes #:auto-nested-attributes) 209 (#:commit #:no-delimit-cut)) 210 #:no-duplicates? #t)) 211 (define description (options-select-value chunks '#:description #:default #f)) 212 (define opaque? (and (assq '#:opaque chunks) #t)) 213 (define transparent? (not opaque?)) 214 (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t)) 215 (define colon-notation? (not (assq '#:disable-colon-notation chunks))) 216 (define commit? 217 (and (assq '#:commit chunks) #t)) 218 (define delimit-cut? 219 (not (assq '#:no-delimit-cut chunks))) 220 (define attributes (options-select-value chunks '#:attributes #:default #f)) 221 (define-values (decls defs) (get-decls+defs chunks)) 222 (values rest description transparent? attributes auto-nested? colon-notation? 223 decls defs commit? delimit-cut?)) 224 225(define (parse-variants rest decls splicing?) 226 (define (gather-variants stx) 227 (syntax-case stx (pattern) 228 [((pattern . _) . rest) 229 (begin (disappeared! (stx-car stx)) 230 (cons (parse-variant (stx-car stx) splicing? decls) 231 (gather-variants #'rest)))] 232 [(bad-variant . rest) 233 (wrong-syntax #'bad-variant "expected syntax-class variant")] 234 [() 235 null])) 236 (gather-variants rest)) 237 238;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax)) 239(define (get-decls+defs chunks #:context [ctx (current-syntax-context)]) 240 (parameterize ((current-syntax-context ctx)) 241 (let*-values ([(decls defs1) (get-decls chunks)] 242 [(decls defs2) (decls-create-defs decls)]) 243 (values decls (append defs1 defs2))))) 244 245;; get-decls : chunks -> (values DeclEnv (listof syntax)) 246(define (get-decls chunks) 247 (define lits (options-select-value chunks '#:literals #:default null)) 248 (define datum-lits (options-select-value chunks '#:datum-literals #:default null)) 249 (define litsets (options-select-value chunks '#:literal-sets #:default null)) 250 (define convs (options-select-value chunks '#:conventions #:default null)) 251 (define localconvs (options-select-value chunks '#:local-conventions #:default null)) 252 (define literals 253 (append/check-lits+litsets lits datum-lits litsets)) 254 (define-values (convs-rules convs-defs) 255 (for/fold ([convs-rules null] [convs-defs null]) 256 ([conv-entry (in-list convs)]) 257 (let* ([c (car conv-entry)] 258 [argu (cdr conv-entry)] 259 [get-parser-id (conventions-get-procedures c)] 260 [rules ((conventions-get-rules c))]) 261 (values (append rules convs-rules) 262 (cons (make-conventions-def (map cadr rules) get-parser-id argu) 263 convs-defs))))) 264 (define convention-rules (append localconvs convs-rules)) 265 (values (new-declenv literals #:conventions convention-rules) 266 (reverse convs-defs))) 267 268;; make-conventions-def : (listof den:delay) id Argument -> syntax 269(define (make-conventions-def dens get-parsers-id argu) 270 (with-syntax ([(parser ...) (map den:delayed-parser dens)] 271 [get-parsers get-parsers-id] 272 [argu argu]) 273 #'(define-values (parser ...) 274 (apply values (app-argu get-parsers argu))))) 275 276;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) 277(define (decls-create-defs decls0) 278 (define (updater key value defs) 279 (let-values ([(value newdefs) (create-aux-def value)]) 280 (values value (append newdefs defs)))) 281 (declenv-update/fold decls0 updater null)) 282 283;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx)) 284;; FIXME: replace with txlift mechanism 285(define (create-aux-def entry) 286 (match entry 287 [(? den:lit?) 288 (values entry null)] 289 [(? den:datum-lit?) 290 (values entry null)] 291 [(? den:magic-class?) 292 (values entry null)] 293 [(den:class name scname argu) 294 (with-syntax ([parser (generate-temporary scname)]) 295 (values (make den:delayed #'parser scname) 296 (list #`(define-values (parser) (curried-stxclass-parser #,scname #,argu)))))] 297 [(? den:delayed?) 298 (values entry null)])) 299 300;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit)) 301(define (append/check-lits+litsets lits datum-lits litsets) 302 (define seen (make-bound-id-table)) 303 (define (check-id id [blame-ctx id]) 304 (if (bound-id-table-ref seen id #f) 305 (wrong-syntax blame-ctx "duplicate literal declaration: ~s" (syntax-e id)) 306 (bound-id-table-set! seen id #t)) 307 id) 308 (let* ([litsets* 309 (for/list ([entry (in-list litsets)]) 310 (let ([litset-id (first entry)] 311 [litset (second entry)] 312 [lctx (third entry)] 313 [input-phase (fourth entry)]) 314 (define (get/check-id sym) 315 (check-id (datum->syntax lctx sym) litset-id)) 316 (for/list ([lse (in-list (literalset-literals litset))]) 317 (match lse 318 [(lse:lit internal external lit-phase) 319 (let ([internal (get/check-id internal)] 320 [external (syntax-property external 'literal (gensym))]) 321 (make den:lit internal external input-phase lit-phase))] 322 [(lse:datum-lit internal external) 323 (let ([internal (get/check-id internal)]) 324 (make den:datum-lit internal external))]))))] 325 [lits* 326 (for/list ([lit (in-list lits)]) 327 (check-id (den:lit-internal lit)) 328 lit)] 329 [datum-lits* 330 (for/list ([datum-lit (in-list datum-lits)]) 331 (check-id (den:datum-lit-internal datum-lit)) 332 datum-lit)]) 333 (apply append lits* datum-lits* litsets*))) 334 335;; parse-variant : stx boolean DeclEnv -> RHS 336(define (parse-variant stx splicing? decls0) 337 (syntax-case stx (pattern) 338 [(pattern p . rest) 339 (let-values ([(rest pattern defs) 340 (parse-pattern+sides #'p #'rest 341 #:simplify? #f 342 #:splicing? splicing? 343 #:decls decls0 344 #:context stx)]) 345 (disappeared! stx) 346 (unless (stx-null? rest) 347 (wrong-syntax (if (pair? rest) (car rest) rest) 348 "unexpected terms after pattern directives")) 349 (let* ([attrs (pattern-attrs pattern)] 350 [sattrs (iattrs->sattrs attrs)]) 351 (make variant stx sattrs pattern defs)))])) 352 353;; parse-EH-variant : Syntax DeclEnv Boolean 354;; -> (Listof (list EllipsisHeadPattern Syntax/EH-Alternative)) 355(define (parse-EH-variant stx decls allow-or? #:context [ctx (current-syntax-context)]) 356 (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx)) 357 358;; parse-pattern+sides : stx stx <options> -> (values stx Pattern (listof stx)) 359;; Parses pattern, side clauses; desugars side clauses & merges with pattern 360(define (parse-pattern+sides p-stx s-stx 361 #:splicing? splicing? 362 #:decls decls0 363 #:context ctx 364 #:simplify? [simplify? #t]) 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 [pattern (if simplify? (simplify-pattern pattern) pattern)]) 373 (values rest pattern defs)))) 374 375;; parse-whole-pattern : stx DeclEnv boolean -> Pattern 376;; kind is either 'main or 'with, indicates what kind of pattern declare affects 377(define (parse-whole-pattern stx decls [splicing? #f] 378 #:kind kind 379 #:context [ctx (current-syntax-context)]) 380 (parameterize ((current-syntax-context ctx)) 381 (define pattern 382 (if splicing? 383 (parse-head-pattern stx decls) 384 (parse-single-pattern stx decls))) 385 (define pvars (map attr-name (pattern-attrs pattern))) 386 (define excess-domain (declenv-domain-difference decls pvars)) 387 (when (pair? excess-domain) 388 (wrong-syntax (car excess-domain) 389 (string-append 390 "identifier in #:declare clause does not appear in pattern" 391 (case kind 392 [(main) ""] ;; ";\n this #:declare clause affects only the main pattern"] 393 [(with) ";\n this #:declare clause affects only the preceding #:with pattern"])))) 394 pattern)) 395 396;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern 397(define (combine-pattern+sides pattern sides splicing?) 398 (check-pattern 399 (cond [splicing? (hpat:andu (cons pattern sides))] 400 [else (pat:andu (cons pattern sides))]))) 401 402;; gensym* : -> UninternedSymbol 403;; Like gensym, but with deterministic name from compilation-local counter. 404(define gensym*-counter 0) 405(define (gensym*) 406 (set! gensym*-counter (add1 gensym*-counter)) 407 (string->uninterned-symbol (format "group~a" gensym*-counter))) 408 409 410;; ============================================================ 411;; Parsing patterns 412 413;; parse-single-pattern : stx DeclEnv -> SinglePattern 414(define (parse-single-pattern stx decls) 415 (parse-*-pattern stx decls #f #f)) 416 417;; parse-head-pattern : stx DeclEnv -> HeadPattern 418(define (parse-head-pattern stx decls) 419 (coerce-head-pattern (parse-*-pattern stx decls #t #f))) 420 421;; parse-action-pattern : Stx DeclEnv -> ActionPattern 422(define (parse-action-pattern stx decls) 423 (define p (parse-*-pattern stx decls #f #t)) 424 (unless (action-pattern? p) 425 (wrong-syntax stx "expected action pattern")) 426 p) 427 428(define ((make-not-shadowed? decls) id) 429 ;; Returns #f if id is in literals/datum-literals list. 430 ;; Conventions to not shadow pattern-form bindings, under the 431 ;; theory that conventions only apply to things already determined 432 ;; to be pattern variables. 433 (not (declenv-lookup decls id))) 434;; suitable as id=? argument to syntax-case* 435(define ((make-not-shadowed-id=? decls) lit-id pat-id) 436 (and (free-identifier=? lit-id pat-id) 437 (not (declenv-lookup decls pat-id)))) 438 439;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern 440(define (parse-*-pattern stx decls allow-head? allow-action?) 441 (define (recur stx) 442 (parse-*-pattern stx decls allow-head? allow-action?)) 443 (define (check-head! x) 444 (unless allow-head? 445 (wrong-syntax stx "head pattern not allowed here")) 446 x) 447 (define (check-action! x) 448 ;; Coerce to S-pattern IF only S-patterns allowed 449 (cond [allow-action? x] 450 [(not allow-head?) (action-pattern->single-pattern x)] 451 [else 452 (wrong-syntax stx "action pattern not allowed here")])) 453 (define not-shadowed? (make-not-shadowed? decls)) 454 (propagate-disappeared! stx) 455 (check-pattern 456 (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe 457 ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo 458 ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect 459 ~splicing-reflect) 460 (make-not-shadowed-id=? decls) 461 [id 462 (and (identifier? #'id) 463 (not-shadowed? #'id) 464 (pattern-expander? (syntax-local-value #'id (λ () #f)))) 465 (begin (disappeared! #'id) 466 (recur (expand-pattern (syntax-local-value #'id) #'id stx)))] 467 [(id . rst) 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) #'id stx)))] 473 [wildcard 474 (and (wildcard? #'wildcard) 475 (not-shadowed? #'wildcard)) 476 (begin (disappeared! stx) 477 (pat:any))] 478 [~! 479 (disappeared! stx) 480 (begin 481 (unless (cut-allowed?) 482 (wrong-syntax stx 483 "cut (~~!) not allowed within ~~not pattern")) 484 (check-action! 485 (action:cut)))] 486 [reserved 487 (and (reserved? #'reserved) 488 (not-shadowed? #'reserved)) 489 (wrong-syntax stx "pattern keyword not allowed here")] 490 [id 491 (identifier? #'id) 492 (parse-pat:id stx decls allow-head?)] 493 [datum 494 (atomic-datum-stx? #'datum) 495 (pat:datum (syntax->datum #'datum))] 496 [(~var . rest) 497 (disappeared! stx) 498 (parse-pat:var stx decls allow-head?)] 499 [(~datum . rest) 500 (disappeared! stx) 501 (syntax-case stx (~datum) 502 [(~datum d) 503 (pat:datum (syntax->datum #'d))] 504 [_ (wrong-syntax stx "bad ~~datum form")])] 505 [(~literal . rest) 506 (disappeared! stx) 507 (parse-pat:literal stx decls)] 508 [(~and . rest) 509 (disappeared! stx) 510 (parse-pat:and stx decls allow-head? allow-action?)] 511 [(~or . rest) 512 (disappeared! stx) 513 (parse-pat:or stx decls allow-head?)] 514 [(~or* . rest) 515 (disappeared! stx) 516 (parse-pat:or stx decls allow-head?)] 517 [(~alt . rest) 518 (wrong-syntax stx "ellipsis-head pattern allowed only before ellipsis")] 519 [(~not . rest) 520 (disappeared! stx) 521 (parse-pat:not stx decls)] 522 [(~rest . rest) 523 (disappeared! stx) 524 (parse-pat:rest stx decls)] 525 [(~describe . rest) 526 (disappeared! stx) 527 (parse-pat:describe stx decls allow-head?)] 528 [(~delimit-cut . rest) 529 (disappeared! stx) 530 (parse-pat:delimit stx decls allow-head?)] 531 [(~commit . rest) 532 (disappeared! stx) 533 (parse-pat:commit stx decls allow-head?)] 534 [(~reflect . rest) 535 (disappeared! stx) 536 (parse-pat:reflect stx decls #f)] 537 [(~seq . rest) 538 (disappeared! stx) 539 (check-head! 540 (parse-hpat:seq stx #'rest decls))] 541 [(~optional . rest) 542 (disappeared! stx) 543 (check-head! 544 (parse-hpat:optional stx decls))] 545 [(~splicing-reflect . rest) 546 (disappeared! stx) 547 (check-head! 548 (parse-pat:reflect stx decls #t))] 549 [(~bind . rest) 550 (disappeared! stx) 551 (check-action! 552 (parse-pat:bind stx decls))] 553 [(~fail . rest) 554 (disappeared! stx) 555 (check-action! 556 (parse-pat:fail stx decls))] 557 [(~post . rest) 558 (disappeared! stx) 559 (parse-pat:post stx decls allow-head? allow-action?)] 560 [(~peek . rest) 561 (disappeared! stx) 562 (check-head! 563 (parse-pat:peek stx decls))] 564 [(~peek-not . rest) 565 (disappeared! stx) 566 (check-head! 567 (parse-pat:peek-not stx decls))] 568 [(~parse . rest) 569 (disappeared! stx) 570 (check-action! 571 (parse-pat:parse stx decls))] 572 [(~do . rest) 573 (disappeared! stx) 574 (check-action! 575 (parse-pat:do stx decls))] 576 [(~undo . rest) 577 (disappeared! stx) 578 (check-action! 579 (parse-pat:undo stx decls))] 580 [(head dots . tail) 581 (and (dots? #'dots) (not-shadowed? #'dots)) 582 (begin (disappeared! #'dots) 583 (parse-pat:dots stx #'head #'tail decls))] 584 [(head plus-dots . tail) 585 (and (plus-dots? #'plus-dots) (not-shadowed? #'plus-dots)) 586 (begin (disappeared! #'plus-dots) 587 (parse-pat:plus-dots stx #'head #'tail decls))] 588 [(head . tail) 589 (let ([headp (parse-*-pattern #'head decls #t #t)] 590 [tailp (parse-single-pattern #'tail decls)]) 591 (cond [(action-pattern? headp) 592 (pat:action headp tailp)] 593 [else (pat:head (coerce-head-pattern headp) tailp)]))] 594 [#(a ...) 595 (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) 596 (pat:vector lp))] 597 [b 598 (box? (syntax-e #'b)) 599 (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) 600 (pat:box bp))] 601 [s 602 (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s))) 603 (let* ([s (syntax-e #'s)] 604 [key (prefab-struct-key s)] 605 [contents (struct->list s)]) 606 (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) 607 (pat:pstruct key lp)))]))) 608 609;; expand-pattern : pattern-expander Syntax -> Syntax 610(define (expand-pattern pe pe-binding-id stx) 611 (let ([proc (pattern-expander-proc pe)]) 612 (syntax-local-apply-transformer proc pe-binding-id 'expression #f stx))) 613 614;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) 615(define (parse-ellipsis-head-pattern stx decls) 616 (for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))]) 617 (car ehpat+hstx))) 618 619;; parse*-ellipsis-head-pattern : stx DeclEnv bool 620;; -> (listof (list EllipsisHeadPattern stx/eh-alternative)) 621(define (parse*-ellipsis-head-pattern stx decls allow-or? 622 #:context [ctx (current-syntax-context)]) 623 (define (recur stx) (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx)) 624 (define (recur-cdr-list stx) 625 (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) 626 (apply append (map recur (cdr (stx->list stx))))) 627 (define not-shadowed? (make-not-shadowed? decls)) 628 (propagate-disappeared! stx) 629 (syntax-case* stx (~eh-var ~or ~alt ~between ~optional ~once) 630 (make-not-shadowed-id=? decls) 631 [id 632 (and (identifier? #'id) 633 (not-shadowed? #'id) 634 (pattern-expander? (syntax-local-value #'id (lambda () #f)))) 635 (begin (disappeared! #'id) 636 (recur (expand-pattern (syntax-local-value #'id) #'id stx)))] 637 [(id . rst) 638 (and (identifier? #'id) 639 (not-shadowed? #'id) 640 (pattern-expander? (syntax-local-value #'id (lambda () #f)))) 641 (begin (disappeared! #'id) 642 (recur (expand-pattern (syntax-local-value #'id) #'id stx)))] 643 [(~eh-var name eh-alt-set-id) 644 (disappeared! stx) 645 (let () 646 (define prefix (name->prefix #'name ".")) 647 (define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id)) 648 (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))]) 649 (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] 650 [attr-count (length iattrs)]) 651 (list (create-ehpat 652 (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs #f 653 (scopts attr-count #f #t #f)) 654 (eh-alternative-repc alt) 655 #f) 656 (replace-eh-alternative-attrs 657 alt (iattrs->sattrs iattrs))))))] 658 [(~or . _) 659 (disappeared! stx) 660 (recur-cdr-list stx)] 661 [(~alt . _) 662 (disappeared! stx) 663 (recur-cdr-list stx)] 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;; Identifiers, ~var, and stxclasses 684 685(define (check-no-delimit-cut-in-not id delimit-cut?) 686 (unless (or delimit-cut? (cut-allowed?)) 687 (wrong-syntax id 688 (string-append "syntax class with #:no-delimit-cut option " 689 "not allowed within ~~not pattern")))) 690 691(define (parse-pat:id id decls allow-head?) 692 (cond [(declenv-lookup decls id) 693 => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] 694 [(not (safe-name? id)) 695 (wrong-syntax id "expected identifier not starting with ~~ character")] 696 [(and (stxclass-colon-notation?) (split-id id)) 697 => (match-lambda 698 [(cons name suffix) 699 (declenv-check-unbound decls name (syntax-e suffix) #:blame-declare? #t) 700 (define entry (declenv-lookup decls suffix)) 701 (cond [(or (den:lit? entry) (den:datum-lit? entry)) 702 (pat:andu (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))] 703 [else (parse-stxclass-use id allow-head? name suffix no-arguments "." #f)])])] 704 [(declenv-apply-conventions decls id) 705 => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] 706 [else (pat:svar id)])) 707 708(define (split-id id0) 709 (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) 710 => (lambda (m) 711 (define src (syntax-source id0)) 712 (define ln (syntax-line id0)) 713 (define col (syntax-column id0)) 714 (define pos (syntax-position id0)) 715 (define span (syntax-span id0)) 716 (define id-str (cadr m)) 717 (define id-len (string-length id-str)) 718 (define suffix-str (caddr m)) 719 (define suffix-len (string-length suffix-str)) 720 (define id 721 (datum->syntax id0 (string->symbol id-str) 722 (list src ln col pos id-len) 723 id0)) 724 (define suffix 725 (datum->syntax id0 (string->symbol suffix-str) 726 (list src ln (and col (+ col id-len 1)) (and pos (+ pos id-len 1)) suffix-len) 727 id0)) 728 (cons id suffix))] 729 [else #f])) 730 731;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern 732;; Handle when meaning of identifier pattern is given by declenv entry. 733(define (parse-pat:id/entry id allow-head? entry) 734 (match entry 735 [(den:lit internal literal input-phase lit-phase) 736 (pat:literal literal input-phase lit-phase)] 737 [(den:datum-lit internal sym) 738 (pat:datum sym)] 739 [(den:magic-class name scname argu role) 740 (parse-stxclass-use scname allow-head? id scname argu "." role)] 741 [(den:class _n _c _a) 742 (error 'parse-pat:id 743 "(internal error) decls had leftover stxclass entry: ~s" 744 entry)] 745 [(den:delayed parser scname) 746 (parse-stxclass-use id allow-head? id scname 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 (parse-stxclass-use stx allow-head? name0 scname argu pfx role)] 781 [else ;; Just proper name 782 (pat:svar name0)])) 783 784;; ---- 785 786(define (parse-stxclass-use stx allow-head? varname scname argu pfx role [parser* #f]) 787 (define config (stxclass-lookup-config)) 788 (cond [(and (memq config '(yes try)) (get-stxclass scname (eq? config 'try))) 789 => (lambda (sc) 790 (unless parser* 791 (check-stxclass-arity sc stx (length (arguments-pargs argu)) (arguments-kws argu))) 792 (parse-stxclass-use* stx allow-head? varname sc argu pfx role parser*))] 793 [else 794 (define bind (name->bind varname)) 795 (pat:fixup stx bind varname scname argu pfx role parser*)])) 796 797;; ---- 798 799(define (parse-stxclass-use* stx allow-head? name sc argu pfx role parser*) 800 ;; if parser* not #f, overrides sc parser 801 (check-no-delimit-cut-in-not stx (scopts-delimit-cut? (stxclass-opts sc))) 802 (define bind (name->bind name)) 803 (define prefix (name->prefix name pfx)) 804 (define parser (or parser* (stxclass-parser sc))) 805 (define nested-attrs (id-pattern-attrs (stxclass-attrs sc) prefix)) 806 (define opts (stxclass-opts sc)) 807 (cond [(and (stxclass/s? sc) (stxclass-inline sc) (equal? argu no-arguments)) 808 (pat:integrated bind (stxclass-inline sc) (scopts-desc opts) role)] 809 [(stxclass/s? sc) 810 (pat:var/p bind parser argu nested-attrs role opts)] 811 [(stxclass/h? sc) 812 (unless allow-head? 813 (wrong-syntax stx "splicing syntax class not allowed here")) 814 (hpat:var/p bind parser argu nested-attrs role opts)])) 815 816(define (name->prefix id pfx) 817 (cond [(wildcard? id) #f] 818 [(epsilon? id) id] 819 [else (format-id id "~a~a" (syntax-e id) pfx #:source id)])) 820 821(define (name->bind id) 822 (cond [(wildcard? id) #f] 823 [(epsilon? id) #f] 824 [else id])) 825 826;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr) 827(define (id-pattern-attrs sattrs prefix) 828 (if prefix 829 (for/list ([a (in-list sattrs)]) 830 (prefix-attr a prefix)) 831 null)) 832 833;; prefix-attr : SAttr identifier -> IAttr 834(define (prefix-attr a prefix) 835 (make attr (prefix-attr-name prefix (attr-name a)) 836 (attr-depth a) 837 (attr-syntax? a))) 838 839;; prefix-attr-name : id symbol -> id 840(define (prefix-attr-name prefix name) 841 (orig (format-id prefix "~a~a" (syntax-e prefix) name #:source prefix))) 842 843(define (orig stx) 844 (syntax-property stx 'original-for-check-syntax #t)) 845 846;; ---------------------------------------- 847;; Other pattern forms 848 849(define (parse-pat:reflect stx decls splicing?) 850 (syntax-case stx () 851 [(_ name (obj arg ...) . maybe-signature) 852 (let () 853 (unless (identifier? #'var) 854 (raise-syntax-error #f "expected identifier" stx #'name)) 855 (define attr-decls 856 (syntax-case #'maybe-signature () 857 [(#:attributes attr-decls) 858 (check-attr-arity-list #'attr-decls stx)] 859 [() null] 860 [_ (raise-syntax-error #f "bad syntax" stx)])) 861 (define prefix (name->prefix #'name ".")) 862 (define bind (name->bind #'name)) 863 (define ctor (if splicing? hpat:reflect pat:reflect)) 864 (ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind 865 (id-pattern-attrs attr-decls prefix)))])) 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 #:default #f)] 876 [phase (if phase (txlift phase) #'(syntax-local-phase-level))]) 877 (pat:literal #'lit phase phase))] 878 [_ 879 (wrong-syntax stx "bad ~~literal pattern")])) 880 881(define (parse-pat:describe stx decls allow-head?) 882 (syntax-case stx () 883 [(_ . rest) 884 (let-values ([(chunks rest) 885 (parse-keyword-options #'rest describe-option-table 886 #:no-duplicates? #t 887 #:context stx)]) 888 (define transparent? (not (assq '#:opaque chunks))) 889 (define role (options-select-value chunks '#:role #:default #'#f)) 890 (syntax-case rest () 891 [(description pattern) 892 (let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) 893 (if (head-pattern? p) 894 (hpat:describe p #'description transparent? role) 895 (pat:describe p #'description transparent? role)))]))])) 896 897(define (parse-pat:delimit stx decls allow-head?) 898 (syntax-case stx () 899 [(_ pattern) 900 (let ([p (parameterize ((cut-allowed? #t)) 901 (parse-*-pattern #'pattern decls allow-head? #f))]) 902 (if (head-pattern? p) 903 (hpat:delimit p) 904 (pat:delimit p)))])) 905 906(define (parse-pat:commit stx decls allow-head?) 907 (syntax-case stx () 908 [(_ pattern) 909 (let ([p (parameterize ((cut-allowed? #t)) 910 (parse-*-pattern #'pattern decls allow-head? #f))]) 911 (if (head-pattern? p) 912 (hpat:commit p) 913 (pat:commit p)))])) 914 915(define (parse-pat:and stx decls allow-head? allow-action?) 916 ;; allow-action? = allowed to *return* pure action pattern; 917 ;; all ~and patterns are allowed to *contain* action patterns 918 (define patterns (parse-cdr-patterns stx decls allow-head? #t)) 919 (cond [(andmap action-pattern? patterns) 920 (cond [allow-action? 921 (action:and patterns)] 922 [allow-head? 923 (wrong-syntax stx "expected at least one head or single-term pattern")] 924 [else 925 (wrong-syntax stx "expected at least one single-term pattern")])] 926 [(memq (stxclass-lookup-config) '(no try)) 927 (pat:and/fixup stx patterns)] 928 [else (parse-pat:and/k stx patterns)])) 929 930(define (parse-pat:and/k stx patterns) 931 ;; PRE: patterns not all action patterns 932 (cond [(ormap head-pattern? patterns) 933 ;; Check to make sure *all* are head patterns (and action patterns) 934 (for ([pattern (in-list patterns)] 935 [pattern-stx (in-list (stx->list (stx-cdr stx)))]) 936 (unless (or (action-pattern? pattern) (head-pattern? pattern)) 937 (wrong-syntax pattern-stx "single-term pattern not allowed after head pattern"))) 938 (hpat:andu patterns)] 939 [else (pat:andu patterns)])) 940 941(define (split-prefix xs pred) 942 (let loop ([xs xs] [rprefix null]) 943 (cond [(and (pair? xs) (pred (car xs))) 944 (loop (cdr xs) (cons (car xs) rprefix))] 945 [else 946 (values (reverse rprefix) xs)]))) 947 948(define (add-actions actions p) 949 (if (head-pattern? p) 950 (for/fold ([p p]) ([action (in-list (reverse actions))]) 951 (hpat:action action p)) 952 (for/fold ([p p]) ([action (in-list (reverse actions))]) 953 (pat:action action p)))) 954 955(define (parse-pat:or stx decls allow-head?) 956 (define patterns (parse-cdr-patterns stx decls allow-head? #f)) 957 (cond [(null? (cdr patterns)) 958 (car patterns)] 959 [else 960 (cond [(ormap head-pattern? patterns) 961 (create-hpat:or (map coerce-head-pattern patterns))] 962 [else 963 (create-pat:or patterns)])])) 964 965(define (parse-pat:not stx decls) 966 (syntax-case stx () 967 [(_ pattern) 968 (let ([p (parameterize ((cut-allowed? #f)) 969 (parse-single-pattern #'pattern decls))]) 970 (pat:not p))] 971 [_ 972 (wrong-syntax stx "expected a single subpattern")])) 973 974(define (parse-hpat:seq stx list-stx decls) 975 (define pattern (parse-single-pattern list-stx decls)) 976 (unless (proper-list-pattern? pattern) 977 (wrong-syntax stx "expected proper list pattern")) 978 (hpat:seq pattern)) 979 980(define (parse-cdr-patterns stx decls allow-head? allow-action?) 981 (unless (stx-list? stx) 982 (wrong-syntax stx "expected sequence of patterns")) 983 (let ([result 984 (for/list ([sub (in-list (cdr (stx->list stx)))]) 985 (parse-*-pattern sub decls allow-head? allow-action?))]) 986 (when (null? result) 987 (wrong-syntax stx "expected at least one pattern")) 988 result)) 989 990(define (parse-pat:dots stx head tail decls) 991 (define headps (parse-ellipsis-head-pattern head decls)) 992 (define tailp (parse-single-pattern tail decls)) 993 (unless (pair? headps) 994 (wrong-syntax head "expected at least one pattern")) 995 (pat:dots headps tailp)) 996 997(define (parse-pat:plus-dots stx head tail decls) 998 (define headp (parse-head-pattern head decls)) 999 (define tailp (parse-single-pattern tail decls)) 1000 (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f) head)) 1001 (pat:dots (list head/rep) tailp)) 1002 1003(define (parse-pat:bind stx decls) 1004 (syntax-case stx () 1005 [(_ clause ...) 1006 (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) 1007 (action:and clauses))])) 1008 1009(define (parse-pat:fail stx decls) 1010 (syntax-case stx () 1011 [(_ . rest) 1012 (let-values ([(chunks rest) 1013 (parse-keyword-options #'rest fail-directive-table 1014 #:context stx 1015 #:incompatible '((#:when #:unless)) 1016 #:no-duplicates? #t)]) 1017 (let ([condition 1018 (cond [(options-select-value chunks '#:when #:default #f) 1019 => values] 1020 [(options-select-value chunks '#:unless #:default #f) 1021 => (lambda (expr) #`(not #,expr))] 1022 [else #'#t])]) 1023 (syntax-case rest () 1024 [(message) 1025 (action:fail condition #'message)] 1026 [() 1027 (action:fail condition #''#f)] 1028 [_ 1029 (wrong-syntax stx "bad ~~fail pattern")])))])) 1030 1031(define (parse-pat:post stx decls allow-head? allow-action?) 1032 (syntax-case stx () 1033 [(_ pattern) 1034 (let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)]) 1035 (cond [(action-pattern? p) 1036 (cond [allow-action? (action:post p)] 1037 [(not allow-head?) (pat:post (action-pattern->single-pattern p))] 1038 [else (wrong-syntax stx "action pattern not allowed here")])] 1039 [(head-pattern? p) 1040 (cond [allow-head? (hpat:post p)] 1041 [else (wrong-syntax stx "head pattern not allowed here")])] 1042 [else (pat:post p)]))])) 1043 1044(define (parse-pat:peek stx decls) 1045 (syntax-case stx () 1046 [(_ pattern) 1047 (let ([p (parse-head-pattern #'pattern decls)]) 1048 (hpat:peek p))])) 1049 1050(define (parse-pat:peek-not stx decls) 1051 (syntax-case stx () 1052 [(_ pattern) 1053 (let ([p (parse-head-pattern #'pattern decls)]) 1054 (hpat:peek-not p))])) 1055 1056(define (parse-pat:parse stx decls) 1057 (syntax-case stx () 1058 [(_ pattern expr) 1059 (let ([p (parse-single-pattern #'pattern decls)]) 1060 (action:parse p #'expr))] 1061 [_ 1062 (wrong-syntax stx "bad ~~parse pattern")])) 1063 1064(define (parse-pat:do stx decls) 1065 (syntax-case stx () 1066 [(_ stmt ...) 1067 (action:do (syntax->list #'(stmt ...)))] 1068 [_ 1069 (wrong-syntax stx "bad ~~do pattern")])) 1070 1071(define (parse-pat:undo stx decls) 1072 (syntax-case stx () 1073 [(_ stmt ...) 1074 (action:undo (syntax->list #'(stmt ...)))] 1075 [_ 1076 (wrong-syntax stx "bad ~~undo pattern")])) 1077 1078(define (parse-pat:rest stx decls) 1079 (syntax-case stx () 1080 [(_ pattern) 1081 (parse-single-pattern #'pattern decls)])) 1082 1083(define (parse-hpat:optional stx decls) 1084 (define-values (head-stx head iattrs _name _tmm defaults) 1085 (parse*-optional-pattern stx decls h-optional-directive-table)) 1086 (create-hpat:or 1087 (list head 1088 (hpat:action (action:and defaults) 1089 (hpat:seq (pat:datum '())))))) 1090 1091;; parse*-optional-pattern : stx DeclEnv table 1092;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause)) 1093(define (parse*-optional-pattern stx decls optional-directive-table) 1094 (syntax-case stx () 1095 [(_ p . options) 1096 (let* ([head (parse-head-pattern #'p decls)] 1097 [chunks 1098 (parse-keyword-options/eol #'options optional-directive-table 1099 #:no-duplicates? #t 1100 #:context stx)] 1101 [too-many-msg 1102 (options-select-value chunks '#:too-many #:default #'#f)] 1103 [name 1104 (options-select-value chunks '#:name #:default #'#f)] 1105 [defaults 1106 (options-select-value chunks '#:defaults #:default '())] 1107 [pattern-iattrs (pattern-attrs head)] 1108 [defaults-iattrs 1109 (append-iattrs (map pattern-attrs defaults))] 1110 [all-iattrs 1111 (union-iattrs (list pattern-iattrs defaults-iattrs))]) 1112 (when (eq? (stxclass-lookup-config) 'yes) 1113 ;; Only check that attrs in defaults clause agree with attrs 1114 ;; in pattern when attrs in pattern are known to be complete. 1115 (check-iattrs-subset defaults-iattrs pattern-iattrs stx)) 1116 (values #'p head all-iattrs name too-many-msg defaults))])) 1117 1118;; -- EH patterns 1119;; Only parse the rep-constraint part; don't parse the head pattern within. 1120;; (To support eh-alternative-sets.) 1121 1122;; parse*-ehpat/optional : stx DeclEnv -> (list EllipsisHeadPattern stx) 1123(define (parse*-ehpat/optional stx decls) 1124 (define-values (head-stx head iattrs name too-many-msg defaults) 1125 (parse*-optional-pattern stx decls eh-optional-directive-table)) 1126 (list (create-ehpat head (make rep:optional name too-many-msg defaults) head-stx) 1127 head-stx)) 1128 1129;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx) 1130(define (parse*-ehpat/once stx decls) 1131 (syntax-case stx () 1132 [(_ p . options) 1133 (let* ([head (parse-head-pattern #'p decls)] 1134 [chunks 1135 (parse-keyword-options/eol #'options 1136 (list (list '#:too-few check-expression) 1137 (list '#:too-many check-expression) 1138 (list '#:name check-expression)) 1139 #:context stx)] 1140 [too-few-msg 1141 (options-select-value chunks '#:too-few #:default #'#f)] 1142 [too-many-msg 1143 (options-select-value chunks '#:too-many #:default #'#f)] 1144 [name 1145 (options-select-value chunks '#:name #:default #'#f)]) 1146 (list (create-ehpat head (make rep:once name too-few-msg too-many-msg) #'p) 1147 #'p))])) 1148 1149;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx) 1150(define (parse*-ehpat/bounds stx decls) 1151 (syntax-case stx () 1152 [(_ p min max . options) 1153 (let () 1154 (define head (parse-head-pattern #'p decls)) 1155 (define minN (syntax-e #'min)) 1156 (define maxN (syntax-e #'max)) 1157 (unless (exact-nonnegative-integer? minN) 1158 (wrong-syntax #'min 1159 "expected exact nonnegative integer")) 1160 (unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0)) 1161 (wrong-syntax #'max 1162 "expected exact nonnegative integer or +inf.0")) 1163 (when (> minN maxN) 1164 (wrong-syntax stx "minimum larger than maximum repetition constraint")) 1165 (let* ([chunks (parse-keyword-options/eol 1166 #'options 1167 (list (list '#:too-few check-expression) 1168 (list '#:too-many check-expression) 1169 (list '#:name check-expression)) 1170 #:context stx)] 1171 [too-few-msg 1172 (options-select-value chunks '#:too-few #:default #'#f)] 1173 [too-many-msg 1174 (options-select-value chunks '#:too-many #:default #'#f)] 1175 [name 1176 (options-select-value chunks '#:name #:default #'#f)]) 1177 (list (create-ehpat head 1178 (make rep:bounds minN maxN 1179 name too-few-msg too-many-msg) 1180 #'p) 1181 #'p)))])) 1182 1183 1184;; ============================================================ 1185;; Fixup pass (also does simplify-pattern) 1186 1187(define (fixup-rhs the-rhs head? expected-attrs) 1188 (match the-rhs 1189 [(rhs attrs tr? desc vs defs commit? delimit-cut?) 1190 (define vs* (for/list ([v (in-list vs)]) (fixup-variant v head? expected-attrs))) 1191 (rhs attrs tr? desc vs* defs commit? delimit-cut?)])) 1192 1193(define (fixup-variant v head? expected-attrs) 1194 (match v 1195 [(variant stx sattrs p defs) 1196 (parameterize ((current-syntax-context stx)) 1197 (define p1 1198 (parameterize ((stxclass-lookup-config 'yes)) 1199 (fixup-pattern p head?))) 1200 ;; (eprintf "~v\n===>\n~v\n\n" p p1) 1201 (unless (if head? (wf-H? p1) (wf-S? p1)) 1202 (error 'fixup-variant "result is not well-formed")) 1203 (define p* (simplify-pattern p1)) 1204 ;; (eprintf "=2=>\n~v\n\n" p*) 1205 ;; Called just for error-reporting 1206 (reorder-iattrs expected-attrs (pattern-attrs p*)) 1207 (variant stx sattrs p* defs))])) 1208 1209(define (fixup-pattern p0 head?) 1210 (define (S p) (fixup p #f)) 1211 (define (S* p) (fixup p #t)) 1212 (define (A/S p) (if (action-pattern? p) (A p) (S p))) 1213 (define (A/H p) (if (action-pattern? p) (A p) (H p))) 1214 1215 (define (A p) 1216 (match p 1217 ;; [(action:cut) 1218 ;; (action:cut)] 1219 ;; [(action:fail when msg) 1220 ;; (action:fail when msg)] 1221 ;; [(action:bind attr expr) 1222 ;; (action:bind attr expr)] 1223 [(action:and ps) 1224 (action:and (map A ps))] 1225 [(action:parse sp expr) 1226 (action:parse (S sp) expr)] 1227 ;; [(action:do stmts) 1228 ;; (action:do stmts)] 1229 ;; [(action:undo stmts) 1230 ;; (action:undo stmts)] 1231 [(action:ord sp group index) 1232 (create-ord-pattern (A sp) group index)] 1233 [(action:post sp) 1234 (create-post-pattern (A sp))] 1235 ;; ---- 1236 ;; Default: no sub-patterns, just return 1237 [p p])) 1238 (define (EH p) 1239 (match p 1240 [(ehpat iattrs hp repc check-null?) 1241 (create-ehpat (H hp) repc #f)])) 1242 1243 (define (fixup p allow-head?) 1244 (define (I p) (fixup p allow-head?)) 1245 (match p 1246 [(pat:fixup stx bind varname scname argu pfx role parser*) 1247 (parse-stxclass-use stx allow-head? varname scname argu pfx role parser*)] 1248 ;; ---- 1249 ;; [(pat:any) 1250 ;; (pat:any)] 1251 ;; [(pat:svar name) 1252 ;; (pat:svar name)] 1253 ;; [(pat:var/p name parser argu nested-attrs role opts) 1254 ;; (pat:var/p name parser argu nested-attrs role opts)] 1255 ;; [(pat:integrated name predicate desc role) 1256 ;; (pat:integrated name predicate desc role)] 1257 ;; [(pat:reflect obj argu attr-decls name nested-attrs) 1258 ;; (pat:reflect obj argu attr-decls name nested-attrs)] 1259 ;; [(pat:datum d) 1260 ;; (pat:datum d)] 1261 ;; [(pat:literal id input-phase lit-phase) 1262 ;; (pat:literal id input-phase lit-phase)] 1263 [(pat:vector sp) 1264 (pat:vector (S sp))] 1265 [(pat:box sp) 1266 (pat:box (S sp))] 1267 [(pat:pstruct key sp) 1268 (pat:pstruct key (S sp))] 1269 [(pat:not sp) 1270 (parameterize ((cut-allowed? #f)) 1271 (pat:not (S sp)))] 1272 [(pat:dots headps tailp) 1273 (pat:dots (map EH headps) (S tailp))] 1274 [(pat:head headp tailp) 1275 (pat:head (H headp) (S tailp))] 1276 ;; --- The following patterns may change if a subpattern switches to head pattern ---- 1277 [(pat:pair headp tailp) (error 'fixup-pattern "internal error: pat:pair in stage 0")] 1278 [(pat:action a sp) 1279 (let ([a (A a)] [sp (I sp)]) 1280 (if (head-pattern? sp) (hpat:action a sp) (pat:action a sp)))] 1281 [(pat:describe sp desc tr? role) 1282 (let ([sp (I sp)]) 1283 (if (head-pattern? sp) (hpat:describe sp desc tr? role) (pat:describe sp desc tr? role)))] 1284 [(pat:andu ps) 1285 (let ([ps (map A/S ps)]) 1286 (pat:andu ps))] 1287 [(pat:and/fixup stx ps) 1288 (let ([ps (for/list ([p (in-list ps)]) 1289 (cond [(action-pattern? p) (A p)] 1290 [(head-pattern? p) (H p)] 1291 [else (I p)]))]) 1292 (parse-pat:and/k stx ps))] 1293 [(pat:or _ ps _) 1294 (let ([ps (map I ps)]) 1295 (if (ormap head-pattern? ps) (create-hpat:or ps) (create-pat:or ps)))] 1296 [(pat:delimit sp) 1297 (let ([sp (parameterize ((cut-allowed? #t)) (I sp))]) 1298 (if (head-pattern? sp) (hpat:delimit sp) (pat:delimit sp)))] 1299 [(pat:commit sp) 1300 (let ([sp (parameterize ((cut-allowed? #t)) (I sp))]) 1301 (if (head-pattern? sp) (hpat:commit sp) (pat:commit sp)))] 1302 [(pat:ord sp group index) 1303 (create-ord-pattern (I sp) group index)] 1304 [(pat:post sp) 1305 (create-post-pattern (I sp))] 1306 ;; ---- 1307 ;; Default: no sub-patterns, just return 1308 [p p])) 1309 1310 (define (H p) 1311 (match p 1312 [(hpat:single sp) 1313 (let ([sp (fixup sp #t)]) 1314 (if (head-pattern? sp) sp (hpat:single sp)))] 1315 ;; [(hpat:var/p name parser argu nested-attrs role scopts) 1316 ;; (hpat:var/p name parser argu nested-attrs role scopts)] 1317 ;; [(hpat:reflect obj argu attr-decls name nested-attrs) 1318 ;; (hpat:reflect obj argu attr-decls name nested-attrs)] 1319 [(hpat:seq lp) 1320 (hpat:seq (S lp))] 1321 [(hpat:action a hp) 1322 (hpat:action (A a) (H hp))] 1323 [(hpat:describe hp desc tr? role) 1324 (hpat:describe (H hp) desc tr? role)] 1325 [(hpat:andu ps) 1326 (let ([ps (map A/H ps)]) 1327 (hpat:andu ps))] 1328 [(hpat:or _ ps _) 1329 (create-hpat:or (map H ps))] 1330 [(hpat:delimit hp) 1331 (parameterize ((cut-allowed? #t)) 1332 (hpat:delimit (H hp)))] 1333 [(hpat:commit hp) 1334 (parameterize ((cut-allowed? #t)) 1335 (hpat:commit (H hp)))] 1336 [(hpat:ord hp group index) 1337 (create-ord-pattern (H hp) group index)] 1338 [(hpat:post hp) 1339 (create-post-pattern (H hp))] 1340 [(hpat:peek hp) 1341 (hpat:peek (H hp))] 1342 [(hpat:peek-not hp) 1343 (hpat:peek-not (H hp))] 1344 [(? pattern? sp) 1345 (S* sp)] 1346 ;; ---- 1347 ;; Default: no sub-patterns, just return 1348 [p p])) 1349 1350 (if head? (H p0) (S p0))) 1351 1352 1353;; ============================================================ 1354;; Simplify pattern 1355 1356;;(begin (require racket/pretty) (pretty-print-columns 160)) 1357 1358;; simplify-pattern : *Pattern -> *Pattern 1359(define (simplify-pattern p0) 1360 ;;(eprintf "-- simplify --\n") 1361 ;;(eprintf "~a\n" (pretty-format p0)) 1362 (define p1 (simplify:specialize-pairs p0)) 1363 ;; (eprintf "=1=>\n~a\n" (pretty-format p1)) 1364 (define p2 (simplify:normalize-and p1)) 1365 ;;(eprintf "=2=>\n~a\n" (pretty-format p2)) 1366 (define p3 (simplify:order-and p2)) 1367 ;;(eprintf "=3=>\n~a\n" (pretty-format p3)) 1368 (define p4 (simplify:add-seq-end p3)) 1369 ;;(eprintf "=4=>\n~a\n" (pretty-format p4)) 1370 p4) 1371 1372;; ---------------------------------------- 1373;; Add pair patterns 1374 1375(define (simplify:specialize-pairs p) 1376 (define (for-pattern p) 1377 (match p 1378 [(pat:head (hpat:single headp) tailp) 1379 (pat:pair headp tailp)] 1380 [(pat:head (hpat:seq lp) tailp) 1381 (list-pattern-replace-end lp tailp)] 1382 [_ p])) 1383 (pattern-transform p for-pattern)) 1384 1385;; list-pattern-replace-end : ListPattern {L,S}Pattern -> {L,S}Pattern 1386(define (list-pattern-replace-end lp endp) 1387 (let loop ([lp lp]) 1388 (match lp 1389 [(pat:datum '()) endp] 1390 [(pat:seq-end) endp] 1391 [(pat:action ap sp) (pat:action ap (loop sp))] 1392 [(pat:head hp tp) (pat:head hp (loop tp))] 1393 [(pat:dots hs tp) (pat:dots hs (loop tp))] 1394 [(pat:ord sp group index) 1395 ;; This is awkward, but it is needed to pop the ORD progress frame on success. 1396 (define sp* (list-pattern-replace-end sp (pat:seq-end))) 1397 (pat:head (hpat:ord (hpat:seq sp*) group index) endp)] 1398 [(pat:pair hp tp) (pat:pair hp (loop tp))]))) 1399 1400;; ---------------------------------------- 1401;; Normalize *:andu patterns, drop useless actions 1402 1403(define (simplify:normalize-and p) 1404 (define (pattern->list p) 1405 (match p 1406 [(pat:any) null] 1407 [(pat:action ap sp) (append (pattern->list ap) (pattern->list sp))] 1408 [(pat:andu ps) (apply append (map pattern->list ps))] 1409 [(hpat:action ap hp) (append (pattern->list ap) (pattern->list hp))] 1410 [(hpat:andu ps) (apply append (map pattern->list ps))] 1411 [(action:and as) (apply append (map pattern->list as))] 1412 [(action:do '()) null] 1413 [(action:undo '()) null] 1414 [_ (list p)])) 1415 (define (for-pattern p) 1416 (match p 1417 [(pat:action ap sp) 1418 (pat:andu (append (pattern->list ap) (pattern->list sp)))] 1419 [(pat:andu ps) 1420 (pat:andu (apply append (map pattern->list ps)))] 1421 [(hpat:action ap hp) 1422 (hpat:andu (append (pattern->list ap) (pattern->list hp)))] 1423 [(hpat:andu ps) 1424 (hpat:andu (apply append (map pattern->list ps)))] 1425 [(action:post ap) 1426 (match (pattern->list ap) 1427 ['() (action:and '())] 1428 [(list ap*) (action:post ap*)] 1429 [as* (action:post (action:and as*))])] 1430 [_ p])) 1431 (pattern-transform p for-pattern)) 1432 1433;; ---------------------------------------- 1434;; Add *:ord and translate back to *:and, *:action 1435 1436(define (simplify:order-and p) 1437 (define (A->S p) (if (action-pattern? p) (pat:action p (pat:any)) p)) 1438 (define (for-pattern p) 1439 (match p 1440 [(pat:andu ps0) 1441 (define ord-ps (ord-and-patterns ps0 (gensym*))) 1442 (define-values (as ps) (split-pred action-pattern? ord-ps)) 1443 (define sp* (list->single-pattern (map A->S ps))) 1444 (add-action-patterns as sp*)] 1445 [(hpat:andu ps0) 1446 (define ord-ps (ord-and-patterns ps0 (gensym*))) 1447 (define-values (as ps) (split-pred action-pattern? ord-ps)) 1448 (match ps 1449 ['() (error 'simplify:order-ands "internal error: no head pattern")] 1450 [(list hp) (add-action-patterns as hp)] 1451 [(cons hp1 hps) 1452 (define sp* (list->single-pattern (map action/head-pattern->list-pattern hps))) 1453 (define hp* (hpat:and hp1 sp*)) 1454 (add-action-patterns as hp*)])] 1455 [_ p])) 1456 (pattern-transform p for-pattern)) 1457 1458;; add-action-patterns : (Listof ActionPattern) *Pattern -> *Pattern 1459(define (add-action-patterns as p) 1460 (if (pair? as) 1461 (let ([ap (list->action-pattern as)]) 1462 (cond [(single-pattern? p) (pat:action ap p)] 1463 [(head-pattern? p) (hpat:action ap p)])) 1464 p)) 1465 1466;; list->action-pattern : (Listof ActionPattern) -> ActionPattern 1467(define (list->action-pattern as) 1468 (match as 1469 [(list ap) ap] 1470 [_ (action:and as)])) 1471 1472;; list->single-pattern : (Listof SinglePattern) -> SinglePattern 1473(define (list->single-pattern ps) 1474 (match ps 1475 ['() (pat:any)] 1476 [(list p) p] 1477 [_ (pat:and ps)])) 1478 1479(define (split-pred pred? xs) 1480 (let loop ([xs xs] [acc null]) 1481 (if (and (pair? xs) (pred? (car xs))) 1482 (loop (cdr xs) (cons (car xs) acc)) 1483 (values (reverse acc) xs)))) 1484 1485;; ---------------------------------------- 1486;; Add pat:seq-end to end of list-patterns in seq 1487 1488(define (simplify:add-seq-end p) 1489 (define (for-pattern p) 1490 (match p 1491 [(hpat:seq lp) 1492 (hpat:seq (list-pattern-replace-end lp (pat:seq-end)))] 1493 [_ p])) 1494 (pattern-transform p for-pattern)) 1495 1496;; ============================================================ 1497;; Parsing pattern directives 1498 1499;; parse-pattern-directives : stxs(PatternDirective) <kw-args> 1500;; -> stx DeclEnv (listof stx) (listof SideClause) 1501(define (parse-pattern-directives stx 1502 #:allow-declare? allow-declare? 1503 #:decls decls 1504 #:context ctx) 1505 (parameterize ((current-syntax-context ctx)) 1506 (define-values (chunks rest) 1507 (parse-keyword-options stx pattern-directive-table #:context ctx)) 1508 (define-values (decls2 chunks2) 1509 (if allow-declare? 1510 (grab-decls chunks decls) 1511 (values decls chunks))) 1512 (define sides 1513 ;; NOTE: use *original* decls 1514 ;; because decls2 has #:declares for *above* pattern 1515 (parse-pattern-sides chunks2 decls)) 1516 (define-values (decls3 defs) 1517 (decls-create-defs decls2)) 1518 (values rest decls3 defs sides))) 1519 1520;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause) 1521;; Invariant: decls contains only literals bindings 1522(define (parse-pattern-sides chunks decls) 1523 (match chunks 1524 [(cons (list '#:declare declare-stx _ _) rest) 1525 (wrong-syntax declare-stx 1526 "#:declare can only appear immediately after pattern or #:with clause")] 1527 [(cons (list '#:role role-stx _) rest) 1528 (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")] 1529 [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest) 1530 (cons (create-post-pattern (action:fail when-expr msg-expr)) 1531 (parse-pattern-sides rest decls))] 1532 [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest) 1533 (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr)) 1534 (parse-pattern-sides rest decls))] 1535 [(cons (list '#:when w-stx unless-expr) rest) 1536 (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#f)) 1537 (parse-pattern-sides rest decls))] 1538 [(cons (list '#:with with-stx pattern expr) rest) 1539 (let-values ([(decls2 rest) (grab-decls rest decls)]) 1540 (let-values ([(decls2a defs) (decls-create-defs decls2)]) 1541 (list* (action:do defs) 1542 (create-post-pattern 1543 (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)) 1544 (parse-pattern-sides rest decls))))] 1545 [(cons (list '#:attr attr-stx a expr) rest) 1546 (cons (action:bind a expr) ;; no POST wrapper, cannot fail 1547 (parse-pattern-sides rest decls))] 1548 [(cons (list '#:post post-stx pattern) rest) 1549 (cons (create-post-pattern (parse-action-pattern pattern decls)) 1550 (parse-pattern-sides rest decls))] 1551 [(cons (list '#:and and-stx pattern) rest) 1552 (cons (parse-action-pattern pattern decls) ;; no POST wrapper 1553 (parse-pattern-sides rest decls))] 1554 [(cons (list '#:do do-stx stmts) rest) 1555 (cons (action:do stmts) 1556 (parse-pattern-sides rest decls))] 1557 [(cons (list '#:undo undo-stx stmts) rest) 1558 (cons (action:undo stmts) 1559 (parse-pattern-sides rest decls))] 1560 [(cons (list '#:cut cut-stx) rest) 1561 (cons (action:cut) 1562 (parse-pattern-sides rest decls))] 1563 ['() 1564 '()])) 1565 1566;; grab-decls : (listof chunk) DeclEnv 1567;; -> (values DeclEnv (listof chunk)) 1568(define (grab-decls chunks decls0) 1569 (define (add-decl stx role-stx decls) 1570 (let ([role 1571 (and role-stx 1572 (syntax-case role-stx () 1573 [(#:role role) #'role]))]) 1574 (syntax-case stx () 1575 [(#:declare name sc) 1576 (identifier? #'sc) 1577 (add-decl* decls #'name #'sc (parse-argu null) role)] 1578 [(#:declare name (sc expr ...)) 1579 (identifier? #'sc) 1580 (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)] 1581 [(#:declare name bad-sc) 1582 (wrong-syntax #'bad-sc 1583 "expected syntax class name (possibly with parameters)")]))) 1584 (define (add-decl* decls id sc-name argu role) 1585 (declenv-put-stxclass decls id sc-name argu role)) 1586 (define (loop chunks decls) 1587 (match chunks 1588 [(cons (cons '#:declare decl-stx) 1589 (cons (cons '#:role role-stx) rest)) 1590 (loop rest (add-decl decl-stx role-stx decls))] 1591 [(cons (cons '#:declare decl-stx) rest) 1592 (loop rest (add-decl decl-stx #f decls))] 1593 [_ (values decls chunks)])) 1594 (loop chunks decls0)) 1595 1596 1597;; ============================================================ 1598;; Arguments and Arities 1599 1600;; parse-argu : (listof stx) -> Arguments 1601(define (parse-argu args #:context [ctx (current-syntax-context)]) 1602 (parameterize ((current-syntax-context ctx)) 1603 (define (loop args rpargs rkws rkwargs) 1604 (cond [(null? args) 1605 (arguments (reverse rpargs) (reverse rkws) (reverse rkwargs))] 1606 [(keyword? (syntax-e (car args))) 1607 (let ([kw (syntax-e (car args))] 1608 [rest (cdr args)]) 1609 (cond [(memq kw rkws) 1610 (wrong-syntax (car args) "duplicate keyword")] 1611 [(null? rest) 1612 (wrong-syntax (car args) 1613 "missing argument expression after keyword")] 1614 #| Overzealous, perhaps? 1615 [(keyword? (syntax-e (car rest))) 1616 (wrong-syntax (car rest) "expected expression following keyword")] 1617 |# 1618 [else 1619 (loop (cdr rest) rpargs (cons kw rkws) (cons (car rest) rkwargs))]))] 1620 [else 1621 (loop (cdr args) (cons (car args) rpargs) rkws rkwargs)])) 1622 (loop args null null null))) 1623 1624;; parse-kw-formals : stx -> Arity 1625(define (parse-kw-formals formals #:context [ctx (current-syntax-context)]) 1626 (parameterize ((current-syntax-context ctx)) 1627 (define id-h (make-bound-id-table)) 1628 (define kw-h (make-hasheq)) ;; keyword => 'mandatory or 'optional 1629 (define pos 0) 1630 (define opts 0) 1631 (define (add-id! id) 1632 (when (bound-id-table-ref id-h id #f) 1633 (wrong-syntax id "duplicate formal parameter" )) 1634 (bound-id-table-set! id-h id #t)) 1635 (define (loop formals) 1636 (cond [(and (stx-pair? formals) (keyword? (syntax-e (stx-car formals)))) 1637 (let* ([kw-stx (stx-car formals)] 1638 [kw (syntax-e kw-stx)] 1639 [rest (stx-cdr formals)]) 1640 (cond [(hash-ref kw-h kw #f) 1641 (wrong-syntax kw-stx "duplicate keyword")] 1642 [(stx-null? rest) 1643 (wrong-syntax kw-stx "missing formal parameter after keyword")] 1644 [else 1645 (let-values ([(formal opt?) (parse-formal (stx-car rest))]) 1646 (add-id! formal) 1647 (hash-set! kw-h kw (if opt? 'optional 'mandatory))) 1648 (loop (stx-cdr rest))]))] 1649 [(stx-pair? formals) 1650 (let-values ([(formal opt?) (parse-formal (stx-car formals))]) 1651 (when (and (positive? opts) (not opt?)) 1652 (wrong-syntax (stx-car formals) 1653 "mandatory argument may not follow optional argument")) 1654 (add-id! formal) 1655 (set! pos (add1 pos)) 1656 (when opt? (set! opts (add1 opts))) 1657 (loop (stx-cdr formals)))] 1658 [(identifier? formals) 1659 (add-id! formals) 1660 (finish #t)] 1661 [(stx-null? formals) 1662 (finish #f)] 1663 [else 1664 (wrong-syntax formals "bad argument sequence")])) 1665 (define (finish has-rest?) 1666 (arity (- pos opts) 1667 (if has-rest? +inf.0 pos) 1668 (sort (for/list ([(k v) (in-hash kw-h)] 1669 #:when (eq? v 'mandatory)) 1670 k) 1671 keyword<?) 1672 (sort (hash-map kw-h (lambda (k v) k)) 1673 keyword<?))) 1674 (loop formals))) 1675 1676;; parse-formal : stx -> (values id bool) 1677(define (parse-formal formal) 1678 (syntax-case formal () 1679 [param 1680 (identifier? #'param) 1681 (values #'param #f)] 1682 [(param default) 1683 (identifier? #'param) 1684 (values #'param #t)] 1685 [_ 1686 (wrong-syntax formal 1687 "expected formal parameter with optional default")])) 1688 1689;; ============================================================ 1690;; Keyword Options & Checkers 1691 1692;; check-attr-arity-list : stx stx -> (listof SAttr) 1693(define (check-attr-arity-list stx ctx) 1694 (unless (stx-list? stx) 1695 (raise-syntax-error #f "expected list of attribute declarations" ctx stx)) 1696 (let ([iattrs 1697 (for/list ([x (in-list (stx->list stx))]) 1698 (check-attr-arity x ctx))]) 1699 (iattrs->sattrs (append-iattrs (map list iattrs))))) 1700 1701;; check-attr-arity : stx stx -> IAttr 1702(define (check-attr-arity stx ctx) 1703 (syntax-case stx () 1704 [attr 1705 (identifier? #'attr) 1706 (make-attr #'attr 0 #f)] 1707 [(attr depth) 1708 (begin (unless (identifier? #'attr) 1709 (raise-syntax-error #f "expected attribute name" ctx #'attr)) 1710 (unless (exact-nonnegative-integer? (syntax-e #'depth)) 1711 (raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth)) 1712 (make-attr #'attr (syntax-e #'depth) #f))] 1713 [_ 1714 (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)])) 1715 1716;; check-literals-list : stx stx -> (listof den:lit) 1717;; - txlifts defs of phase expressions 1718;; - txlifts checks that literals are bound 1719(define (check-literals-list stx ctx) 1720 (unless (stx-list? stx) 1721 (raise-syntax-error #f "expected literals list" ctx stx)) 1722 (for/list ([x (in-list (stx->list stx))]) 1723 (check-literal-entry x ctx))) 1724 1725;; check-literal-entry : stx stx -> den:lit 1726(define (check-literal-entry stx ctx) 1727 (define (go internal external phase) 1728 (txlift #`(check-literal #,external #,phase #,ctx)) 1729 (let ([external (syntax-property external 'literal (gensym))]) 1730 (make den:lit internal external phase phase))) 1731 (syntax-case stx () 1732 [(internal external #:phase phase) 1733 (and (identifier? #'internal) (identifier? #'external)) 1734 (go #'internal #'external (txlift #'phase))] 1735 [(internal external) 1736 (and (identifier? #'internal) (identifier? #'external)) 1737 (go #'internal #'external #'(syntax-local-phase-level))] 1738 [id 1739 (identifier? #'id) 1740 (go #'id #'id #'(syntax-local-phase-level))] 1741 [_ 1742 (raise-syntax-error #f "expected literal entry" ctx stx)])) 1743 1744;; check-datum-literals-list : stx stx -> (listof den:datum-lit) 1745(define (check-datum-literals-list stx ctx) 1746 (unless (stx-list? stx) 1747 (raise-syntax-error #f "expected datum-literals list" ctx stx)) 1748 (for/list ([x (in-list (stx->list stx))]) 1749 (check-datum-literal-entry x ctx))) 1750 1751;; check-datum-literal-entry : stx stx -> den:datum-lit 1752(define (check-datum-literal-entry stx ctx) 1753 (syntax-case stx () 1754 [(internal external) 1755 (and (identifier? #'internal) (identifier? #'external)) 1756 (make den:datum-lit #'internal (syntax-e #'external))] 1757 [id 1758 (identifier? #'id) 1759 (make den:datum-lit #'id (syntax-e #'id))] 1760 [_ 1761 (raise-syntax-error #f "expected datum-literal entry" ctx stx)])) 1762 1763;; Literal sets - Import 1764 1765;; check-literal-sets-list : stx stx -> (listof (list id literalset stx stx)) 1766(define (check-literal-sets-list stx ctx) 1767 (unless (stx-list? stx) 1768 (raise-syntax-error #f "expected literal-set list" ctx stx)) 1769 (for/list ([x (in-list (stx->list stx))]) 1770 (check-literal-set-entry x ctx))) 1771 1772;; check-literal-set-entry : stx stx -> (list id literalset stx stx) 1773(define (check-literal-set-entry stx ctx) 1774 (define (elaborate litset-id lctx phase) 1775 (let ([litset (syntax-local-value/record litset-id literalset?)]) 1776 (unless litset 1777 (raise-syntax-error #f "expected identifier defined as a literal-set" 1778 ctx litset-id)) 1779 (list litset-id litset lctx phase))) 1780 (syntax-case stx () 1781 [(litset . more) 1782 (and (identifier? #'litset)) 1783 (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table 1784 #:no-duplicates? #t 1785 #:context ctx)] 1786 [lctx (options-select-value chunks '#:at #:default #'litset)] 1787 [phase (options-select-value chunks '#:phase #:default #f)]) 1788 (elaborate #'litset lctx (if phase (txlift phase) #'(syntax-local-phase-level))))] 1789 [litset 1790 (identifier? #'litset) 1791 (elaborate #'litset #'litset #'(syntax-local-phase-level))] 1792 [_ 1793 (raise-syntax-error #f "expected literal-set entry" ctx stx)])) 1794 1795;; Conventions 1796 1797;; returns (listof (cons Conventions (listof syntax))) 1798(define (check-conventions-list stx ctx) 1799 (unless (stx-list? stx) 1800 (raise-syntax-error #f "expected conventions list" ctx stx)) 1801 (for/list ([x (in-list (stx->list stx))]) 1802 (check-conventions x ctx))) 1803 1804;; returns (cons Conventions (listof syntax)) 1805(define (check-conventions stx ctx) 1806 (define (elaborate conventions-id argu) 1807 (let ([cs (syntax-local-value/record conventions-id conventions?)]) 1808 (unless cs 1809 (raise-syntax-error #f "expected identifier defined as a conventions" 1810 ctx conventions-id)) 1811 (cons cs argu))) 1812 (syntax-case stx () 1813 [(conventions arg ...) 1814 (identifier? #'conventions) 1815 (elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))] 1816 [conventions 1817 (identifier? #'conventions) 1818 (elaborate #'conventions no-arguments)] 1819 [_ 1820 (raise-syntax-error "expected conventions entry" ctx stx)])) 1821 1822;; returns (listof (list regexp DeclEntry)) 1823(define (check-conventions-rules stx ctx) 1824 (unless (stx-list? stx) 1825 (raise-syntax-error #f "expected convention rule list" ctx stx)) 1826 (for/list ([x (in-list (stx->list stx))]) 1827 (check-conventions-rule x ctx))) 1828 1829;; returns (list regexp DeclEntry) 1830(define (check-conventions-rule stx ctx) 1831 (define (check-conventions-pattern x blame) 1832 (cond [(symbol? x) 1833 (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] 1834 [(regexp? x) x] 1835 [else 1836 (raise-syntax-error #f "expected identifier convention pattern" 1837 ctx blame)])) 1838 (define (check-sc-expr x rx) 1839 (let ([x (check-stxclass-application x ctx)]) 1840 (make den:class rx (car x) (cdr x)))) 1841 (syntax-case stx () 1842 [(rx sc) 1843 (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)]) 1844 (list name-pattern (check-sc-expr #'sc name-pattern)))])) 1845 1846(define (check-stxclass-header stx ctx) 1847 (syntax-case stx () 1848 [name 1849 (identifier? #'name) 1850 (list #'name #'() no-arity)] 1851 [(name . formals) 1852 (identifier? #'name) 1853 (list #'name #'formals (parse-kw-formals #'formals #:context ctx))] 1854 [_ (raise-syntax-error #f "expected syntax class header" stx ctx)])) 1855 1856(define (check-stxclass-application stx ctx) 1857 ;; Doesn't check "operator" is actually a stxclass 1858 (syntax-case stx () 1859 [op 1860 (identifier? #'op) 1861 (cons #'op no-arguments)] 1862 [(op arg ...) 1863 (identifier? #'op) 1864 (cons #'op (parse-argu (syntax->list #'(arg ...))))] 1865 [_ (raise-syntax-error #f "expected syntax class use" ctx stx)])) 1866 1867;; bind clauses 1868(define (check-bind-clause-list stx ctx) 1869 (unless (stx-list? stx) 1870 (raise-syntax-error #f "expected sequence of bind clauses" ctx stx)) 1871 (for/list ([clause (in-list (stx->list stx))]) 1872 (check-bind-clause clause ctx))) 1873 1874(define (check-bind-clause clause ctx) 1875 (syntax-case clause () 1876 [(attr-decl expr) 1877 (action:bind (check-attr-arity #'attr-decl ctx) #'expr)] 1878 [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) 1879 1880(define (check-stmt-list stx ctx) 1881 (syntax-case stx () 1882 [(e ...) 1883 (syntax->list #'(e ...))] 1884 [_ 1885 (raise-syntax-error #f "expected list of expressions and definitions" ctx stx)])) 1886 1887 1888;; ============================================================ 1889;; Directive tables 1890 1891;; common-parse-directive-table 1892(define common-parse-directive-table 1893 (list (list '#:disable-colon-notation) 1894 (list '#:literals check-literals-list) 1895 (list '#:datum-literals check-datum-literals-list) 1896 (list '#:literal-sets check-literal-sets-list) 1897 (list '#:conventions check-conventions-list) 1898 (list '#:local-conventions check-conventions-rules))) 1899 1900;; parse-directive-table 1901(define parse-directive-table 1902 (list* (list '#:context check-expression) 1903 (list '#:track-literals) 1904 common-parse-directive-table)) 1905 1906;; rhs-directive-table 1907(define rhs-directive-table 1908 (list* (list '#:description check-expression) 1909 (list '#:transparent) 1910 (list '#:opaque) 1911 (list '#:attributes check-attr-arity-list) 1912 (list '#:auto-nested-attributes) 1913 (list '#:commit) 1914 (list '#:no-delimit-cut) 1915 common-parse-directive-table)) 1916 1917;; pattern-directive-table 1918(define pattern-directive-table 1919 (list (list '#:declare check-identifier check-expression) 1920 (list '#:role check-expression) ;; attached to preceding #:declare 1921 (list '#:fail-when check-expression check-expression) 1922 (list '#:fail-unless check-expression check-expression) 1923 (list '#:when check-expression) 1924 (list '#:with check-expression check-expression) 1925 (list '#:attr check-attr-arity check-expression) 1926 (list '#:and check-expression) 1927 (list '#:post check-expression) 1928 (list '#:do check-stmt-list) 1929 (list '#:undo check-stmt-list) 1930 (list '#:cut))) 1931 1932;; fail-directive-table 1933(define fail-directive-table 1934 (list (list '#:when check-expression) 1935 (list '#:unless check-expression))) 1936 1937;; describe-option-table 1938(define describe-option-table 1939 (list (list '#:opaque) 1940 (list '#:role check-expression))) 1941 1942;; eh-optional-directive-table 1943(define eh-optional-directive-table 1944 (list (list '#:too-many check-expression) 1945 (list '#:name check-expression) 1946 (list '#:defaults check-bind-clause-list))) 1947 1948;; h-optional-directive-table 1949(define h-optional-directive-table 1950 (list (list '#:defaults check-bind-clause-list))) 1951 1952;; phase-directive-table 1953(define phase-directive-table 1954 (list (list '#:phase check-expression))) 1955 1956;; litset-directive-table 1957(define litset-directive-table 1958 (cons (list '#:at (lambda (stx ctx) stx)) 1959 phase-directive-table)) 1960 1961;; var-pattern-directive-table 1962(define var-pattern-directive-table 1963 (list (list '#:attr-name-separator check-stx-string) 1964 (list '#:role check-expression))) 1965