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