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

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