rep.rkt - www - Unnamed repository; edit this file 'description' to name the repository.

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