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

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