3aa16f2c26
Can't do check completely statically, because phase of comparison is expression (and even default is slightly unpredictable). So instead compute whether check would succeed for likely phase offsets, and use list of ok offsets as run-time fast path (memv instead of identifier-binding).
1609 lines
61 KiB
Racket
1609 lines
61 KiB
Racket
#lang racket/base
|
|
(require (for-template racket/base
|
|
racket/stxparam
|
|
"keywords.rkt"
|
|
"runtime.rkt")
|
|
racket/contract/base
|
|
"minimatch.rkt"
|
|
syntax/id-table
|
|
syntax/stx
|
|
syntax/keyword
|
|
racket/syntax
|
|
unstable/struct
|
|
"txlift.rkt"
|
|
"rep-data.rkt"
|
|
"kws.rkt")
|
|
|
|
;; Error reporting
|
|
;; All entry points should have explicit, mandatory #:context arg
|
|
;; (mandatory from outside, at least)
|
|
|
|
(provide/contract
|
|
[parse-rhs
|
|
(-> syntax? (or/c false/c (listof sattr?)) boolean?
|
|
#:context (or/c false/c syntax?)
|
|
rhs?)]
|
|
[optimize-rhs
|
|
(-> rhs? any/c
|
|
(or/c #f (list/c rhs? syntax?)))]
|
|
[parse-pattern+sides
|
|
(-> syntax? syntax?
|
|
#:splicing? boolean?
|
|
#:decls DeclEnv/c
|
|
#:context syntax?
|
|
any)]
|
|
[parse*-ellipsis-head-pattern
|
|
(-> syntax? DeclEnv/c boolean?
|
|
#:context syntax?
|
|
any)]
|
|
[parse-directive-table any/c]
|
|
[get-decls+defs
|
|
(-> list? boolean? #:context (or/c false/c syntax?)
|
|
(values DeclEnv/c (listof syntax?)))]
|
|
[create-aux-def
|
|
(-> DeclEntry/c
|
|
(values DeclEntry/c (listof syntax?)))]
|
|
[parse-argu
|
|
(-> (listof syntax?)
|
|
#:context syntax?
|
|
arguments?)]
|
|
[parse-kw-formals
|
|
(-> syntax?
|
|
#:context syntax?
|
|
arity?)]
|
|
[check-stxclass-header
|
|
(-> syntax? syntax?
|
|
(list/c identifier? syntax? arity?))]
|
|
[check-stxclass-application
|
|
(-> syntax? syntax?
|
|
(cons/c identifier? arguments?))]
|
|
[check-conventions-rules
|
|
(-> syntax? syntax?
|
|
(listof (list/c regexp? any/c)))]
|
|
[check-attr-arity-list
|
|
(-> syntax? syntax?
|
|
(listof sattr?))])
|
|
|
|
;; ----
|
|
|
|
(define (atomic-datum? stx)
|
|
(let ([datum (syntax-e stx)])
|
|
(or (null? datum)
|
|
(boolean? datum)
|
|
(string? datum)
|
|
(number? datum)
|
|
(keyword? datum))))
|
|
|
|
(define (id-predicate kw)
|
|
(lambda (stx)
|
|
(and (identifier? stx)
|
|
(free-identifier=? stx kw)
|
|
(begin (disappeared! stx) #t))))
|
|
|
|
(define wildcard? (id-predicate (quote-syntax _)))
|
|
(define epsilon? (id-predicate (quote-syntax ||)))
|
|
(define dots? (id-predicate (quote-syntax ...)))
|
|
(define plus-dots? (id-predicate (quote-syntax ...+)))
|
|
|
|
(define keywords
|
|
(list (quote-syntax _)
|
|
(quote-syntax ||)
|
|
(quote-syntax ...)
|
|
(quote-syntax ~var)
|
|
(quote-syntax ~datum)
|
|
(quote-syntax ~literal)
|
|
(quote-syntax ~and)
|
|
(quote-syntax ~or)
|
|
(quote-syntax ~not)
|
|
(quote-syntax ~seq)
|
|
(quote-syntax ~rep)
|
|
(quote-syntax ~once)
|
|
(quote-syntax ~optional)
|
|
(quote-syntax ~between)
|
|
(quote-syntax ~rest)
|
|
(quote-syntax ~describe)
|
|
(quote-syntax ~!)
|
|
(quote-syntax ~bind)
|
|
(quote-syntax ~fail)
|
|
(quote-syntax ~parse)
|
|
(quote-syntax ~do)
|
|
(quote-syntax ...+)
|
|
(quote-syntax ~delimit-cut)
|
|
(quote-syntax ~commit)
|
|
(quote-syntax ~reflect)
|
|
(quote-syntax ~splicing-reflect)
|
|
(quote-syntax ~eh-var)
|
|
(quote-syntax ~peek)
|
|
(quote-syntax ~peek-not)))
|
|
|
|
(define (reserved? stx)
|
|
(and (identifier? stx)
|
|
(for/or ([kw (in-list keywords)])
|
|
(free-identifier=? stx kw))))
|
|
|
|
(define (safe-name? stx)
|
|
(and (identifier? stx)
|
|
(not (regexp-match? #rx"^~" (symbol->string (syntax-e stx))))))
|
|
|
|
;; cut-allowed? : (paramter/c boolean?)
|
|
;; Used to detect ~cut within ~not pattern.
|
|
;; (Also #:no-delimit-cut stxclass within ~not)
|
|
(define cut-allowed? (make-parameter #t))
|
|
|
|
;; ---
|
|
|
|
(define (disappeared! x)
|
|
(cond [(identifier? x)
|
|
(record-disappeared-uses (list x))]
|
|
[(and (stx-pair? x) (identifier? (stx-car x)))
|
|
(record-disappeared-uses (list (stx-car x)))]
|
|
[else
|
|
(raise-type-error 'disappeared!
|
|
"identifier or syntax with leading identifier"
|
|
x)]))
|
|
|
|
;; ---
|
|
|
|
;; parse-rhs : stx boolean (or #f (listof SAttr)) stx -> RHS
|
|
;; If expected-attrs is true, then referenced stxclasses must be defined and
|
|
;; literals must be bound. Set to #f for pass1 (attr collection);
|
|
;; parser requires stxclasses to be bound.
|
|
(define (parse-rhs stx expected-attrs splicing? #:context ctx)
|
|
(call/txlifts
|
|
(lambda ()
|
|
(parameterize ((current-syntax-context ctx))
|
|
(define-values (rest description transp? attributes auto-nested? colon-notation?
|
|
decls defs options)
|
|
(parse-rhs/part1 stx splicing? (and expected-attrs #t)))
|
|
(define variants
|
|
(parameterize ((stxclass-lookup-config
|
|
(cond [expected-attrs 'yes]
|
|
[auto-nested? 'try]
|
|
[else 'no]))
|
|
(stxclass-colon-notation? colon-notation?))
|
|
(parse-variants rest decls splicing? expected-attrs)))
|
|
(let ([sattrs
|
|
(or attributes
|
|
(intersect-sattrss (map variant-attrs variants)))])
|
|
(make rhs stx sattrs transp? description variants
|
|
(append (get-txlifts-as-definitions) defs)
|
|
options #f))))))
|
|
|
|
(define (parse-rhs/part1 stx splicing? strict?)
|
|
(define-values (chunks rest)
|
|
(parse-keyword-options stx rhs-directive-table
|
|
#:context (current-syntax-context)
|
|
#:incompatible '((#:attributes #:auto-nested-attributes)
|
|
(#:commit #:no-delimit-cut))
|
|
#:no-duplicates? #t))
|
|
(define description (options-select-value chunks '#:description #:default #f))
|
|
(define opaque? (and (assq '#:opaque chunks) #t))
|
|
(define transparent? (not opaque?))
|
|
(define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t))
|
|
(define colon-notation? (not (assq '#:disable-colon-notation chunks)))
|
|
(define commit?
|
|
(and (assq '#:commit chunks) #t))
|
|
(define delimit-cut?
|
|
(not (assq '#:no-delimit-cut chunks)))
|
|
(define attributes (options-select-value chunks '#:attributes #:default #f))
|
|
(define-values (decls defs) (get-decls+defs chunks strict?))
|
|
(values rest description transparent? attributes auto-nested? colon-notation?
|
|
decls defs (make options commit? delimit-cut?)))
|
|
|
|
;; ----
|
|
|
|
#|
|
|
A syntax class is integrable if
|
|
- only positional params without defaults
|
|
- no attributes
|
|
- description is a string constant
|
|
- one variant: (~fail #:when/unless cond) ... no message
|
|
- and thus no txlifted definitions, no convention definitions, etc
|
|
- don't care about commit?, delimit-cut?, transparent?
|
|
because other restrictions make them irrelevant
|
|
|#
|
|
|
|
;; optimize-rhs : RHS stxlist -> (list RHS stx)/#f
|
|
;; Returns #f to indicate cannot integrate.
|
|
(define (optimize-rhs rhs0 params)
|
|
(define (check-stx-string x)
|
|
(syntax-case x (quote)
|
|
[(quote str) (string? (syntax-e #'str)) #'str]
|
|
[_ #f]))
|
|
(define (stx-false? x)
|
|
(syntax-case x (quote)
|
|
[(quote #f) #t]
|
|
[_ #f]))
|
|
(match rhs0
|
|
[(rhs _o '() _trans? (? check-stx-string description) (list variant0) '() _opts '#f)
|
|
(match variant0
|
|
[(variant _o '() pattern0 '())
|
|
(match pattern0
|
|
[(pat:action '() (action:fail '() cond-stx msg-stx) (pat:any '()))
|
|
(cond [(stx-false? msg-stx)
|
|
;; Yes!
|
|
(with-syntax ([(predicate) (generate-temporaries #'(predicate))]
|
|
[(param ...) params]
|
|
[fail-condition cond-stx])
|
|
(let* ([predicate-def
|
|
#'(define (predicate x param ...)
|
|
(syntax-parameterize ((this-syntax
|
|
(make-rename-transformer
|
|
(quote-syntax x))))
|
|
(#%expression (not fail-condition))))]
|
|
[integrate* (make integrate #'predicate
|
|
(check-stx-string description))]
|
|
[pattern*
|
|
(create-pat:action
|
|
(create-action:fail #'(not (predicate this-syntax param ...)) #'#f)
|
|
(create-pat:any))]
|
|
[variant*
|
|
(variant _o '() pattern* '())])
|
|
(list
|
|
(make rhs _o '() _trans? description (list variant*) '() _opts integrate*)
|
|
predicate-def)))]
|
|
[else #f])]
|
|
[_ #f])]
|
|
[_ #f])]
|
|
[_ #f]))
|
|
|
|
;; ----
|
|
|
|
(define (parse-variants rest decls splicing? expected-attrs)
|
|
(define (gather-variants stx)
|
|
(syntax-case stx (pattern)
|
|
[((pattern . _) . rest)
|
|
(begin (disappeared! (stx-car stx))
|
|
(cons (parse-variant (stx-car stx) splicing? decls expected-attrs)
|
|
(gather-variants #'rest)))]
|
|
[(bad-variant . rest)
|
|
(wrong-syntax #'bad-variant "expected syntax-class variant")]
|
|
[()
|
|
null]))
|
|
(gather-variants rest))
|
|
|
|
;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax))
|
|
(define (get-decls+defs chunks strict?
|
|
#:context [ctx (current-syntax-context)])
|
|
(parameterize ((current-syntax-context ctx))
|
|
(let*-values ([(decls defs1) (get-decls chunks strict?)]
|
|
[(decls defs2) (decls-create-defs decls)])
|
|
(values decls (append defs1 defs2)))))
|
|
|
|
;; get-decls : chunks -> (values DeclEnv (listof syntax))
|
|
(define (get-decls chunks strict?)
|
|
(define lits (options-select-value chunks '#:literals #:default null))
|
|
(define litsets (options-select-value chunks '#:literal-sets #:default null))
|
|
(define convs (options-select-value chunks '#:conventions #:default null))
|
|
(define localconvs (options-select-value chunks '#:local-conventions #:default null))
|
|
(define literals
|
|
(append-lits+litsets lits litsets))
|
|
(define-values (convs-rules convs-defs)
|
|
(for/fold ([convs-rules null] [convs-defs null])
|
|
([conv-entry (in-list convs)])
|
|
(let* ([c (car conv-entry)]
|
|
[argu (cdr conv-entry)]
|
|
[get-parser-id (conventions-get-procedures c)]
|
|
[rules ((conventions-get-rules c))])
|
|
(values (append rules convs-rules)
|
|
(cons (make-conventions-def (map cadr rules) get-parser-id argu)
|
|
convs-defs)))))
|
|
(define convention-rules (append localconvs convs-rules))
|
|
(values (new-declenv literals #:conventions convention-rules)
|
|
(reverse convs-defs)))
|
|
|
|
;; make-conventions-def : (listof den:delay) id Argument -> syntax
|
|
(define (make-conventions-def dens get-parsers-id argu)
|
|
(with-syntax ([(parser ...) (map den:delayed-parser dens)]
|
|
[get-parsers get-parsers-id]
|
|
[argu argu])
|
|
#'(define-values (parser ...)
|
|
(apply values (app-argu get-parsers argu)))))
|
|
|
|
;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
|
|
(define (decls-create-defs decls0)
|
|
(define (updater key value defs)
|
|
(let-values ([(value newdefs) (create-aux-def value)])
|
|
(values value (append newdefs defs))))
|
|
(declenv-update/fold decls0 updater null))
|
|
|
|
;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
|
|
;; FIXME: replace with txlift mechanism
|
|
(define (create-aux-def entry)
|
|
(match entry
|
|
[(struct den:lit (_i _e _ip _lp))
|
|
(values entry null)]
|
|
[(struct den:magic-class (name class argu))
|
|
(values entry null)]
|
|
[(struct den:class (name class argu))
|
|
;; FIXME: integrable syntax classes?
|
|
(cond [(identifier? name)
|
|
(let* ([pos-count (length (arguments-pargs argu))]
|
|
[kws (arguments-kws argu)]
|
|
[sc (get-stxclass/check-arity class class pos-count kws)])
|
|
(with-syntax ([sc-parser (stxclass-parser sc)])
|
|
(with-syntax ([parser (generate-temporary class)])
|
|
(values (make den:parser #'parser
|
|
(stxclass-attrs sc) (stxclass/h? sc)
|
|
(stxclass-commit? sc) (stxclass-delimit-cut? sc))
|
|
(list #`(define-values (parser)
|
|
(curried-stxclass-parser #,class #,argu)))))))]
|
|
[(regexp? name)
|
|
;; Conventions rule; delay class lookup until module/intdefs pass2
|
|
;; to allow forward references
|
|
(with-syntax ([parser (generate-temporary class)]
|
|
[description (generate-temporary class)])
|
|
(values (make den:delayed #'parser class)
|
|
(list #`(define-values (parser)
|
|
(curried-stxclass-parser #,class #,argu)))))])]
|
|
[(struct den:parser (_p _a _sp _c _dc?))
|
|
(values entry null)]
|
|
[(struct den:delayed (_p _c))
|
|
(values entry null)]))
|
|
|
|
(define (append-lits+litsets lits litsets)
|
|
(define seen (make-bound-id-table lits))
|
|
(for ([litset (in-list litsets)])
|
|
(for ([lit (in-list litset)])
|
|
(when (bound-id-table-ref seen (car lit) #f)
|
|
(wrong-syntax (car lit) "duplicate literal declaration"))
|
|
(bound-id-table-set! seen (car lit) #t)))
|
|
(apply append lits litsets))
|
|
|
|
;; parse-variant : stx boolean DeclEnv #f/(listof Sattr) -> RHS
|
|
(define (parse-variant stx splicing? decls0 expected-attrs)
|
|
(syntax-case stx (pattern)
|
|
[(pattern p . rest)
|
|
(let-values ([(rest pattern defs)
|
|
(parse-pattern+sides #'p #'rest
|
|
#:splicing? splicing?
|
|
#:decls decls0
|
|
#:context stx)])
|
|
(disappeared! stx)
|
|
(unless (stx-null? rest)
|
|
(wrong-syntax (if (pair? rest) (car rest) rest)
|
|
"unexpected terms after pattern directives"))
|
|
(let* ([attrs (pattern-attrs pattern)]
|
|
[sattrs (iattrs->sattrs attrs)])
|
|
(when expected-attrs
|
|
(parameterize ((current-syntax-context stx))
|
|
;; Called just for error-reporting
|
|
(reorder-iattrs expected-attrs attrs)))
|
|
(make variant stx sattrs pattern defs)))]))
|
|
|
|
;; parse-pattern+sides : stx stx <options> -> (values stx Pattern (listof stx))
|
|
;; Parses pattern, side clauses; desugars side clauses & merges with pattern
|
|
(define (parse-pattern+sides p-stx s-stx
|
|
#:splicing? splicing?
|
|
#:decls decls0
|
|
#:context ctx)
|
|
(let-values ([(rest decls defs sides)
|
|
(parse-pattern-directives s-stx
|
|
#:allow-declare? #t
|
|
#:decls decls0
|
|
#:context ctx)])
|
|
(let* ([pattern0 (parse-whole-pattern p-stx decls splicing? #:context ctx)]
|
|
[pattern (combine-pattern+sides pattern0 sides splicing?)])
|
|
(values rest pattern defs))))
|
|
|
|
(define (side-clauses-attrss clauses)
|
|
(for/list ([c (in-list clauses)]
|
|
#:when (or (clause:with? c) (clause:attr? c)))
|
|
(if (clause:with? c)
|
|
(pattern-attrs (clause:with-pattern c))
|
|
(list (clause:attr-attr c)))))
|
|
|
|
;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
|
|
(define (parse-whole-pattern stx decls [splicing? #f]
|
|
#:context [ctx (current-syntax-context)])
|
|
(parameterize ((current-syntax-context ctx))
|
|
(define pattern
|
|
(if splicing?
|
|
(parse-head-pattern stx decls)
|
|
(parse-single-pattern stx decls)))
|
|
(define pvars (map attr-name (pattern-attrs pattern)))
|
|
(define excess-domain (declenv-domain-difference decls pvars))
|
|
(when (pair? excess-domain)
|
|
(wrong-syntax #f "declared pattern variables do not appear in pattern"
|
|
#:extra excess-domain))
|
|
pattern))
|
|
|
|
;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern
|
|
(define (combine-pattern+sides pattern sides splicing?)
|
|
(define actions-pattern
|
|
(create-action:and
|
|
(for/list ([side (in-list sides)])
|
|
(match side
|
|
[(make clause:fail condition message)
|
|
(create-action:post
|
|
(create-action:fail condition message))]
|
|
[(make clause:with wpat expr defs)
|
|
(let ([ap (create-action:post
|
|
(create-action:parse wpat expr))])
|
|
(if (pair? defs)
|
|
(create-action:and (list (create-action:do defs) ap))
|
|
ap))]
|
|
[(make clause:attr attr expr)
|
|
(create-action:bind (list side))]
|
|
[(make clause:do stmts)
|
|
(create-action:do stmts)]))))
|
|
(define dummy-pattern
|
|
(and (pair? sides)
|
|
(create-pat:action actions-pattern (create-pat:any))))
|
|
(if dummy-pattern
|
|
(if splicing?
|
|
(create-hpat:and pattern dummy-pattern)
|
|
(create-pat:and (list pattern dummy-pattern)))
|
|
pattern))
|
|
|
|
;; ----
|
|
|
|
;; parse-single-pattern : stx DeclEnv -> SinglePattern
|
|
(define (parse-single-pattern stx decls)
|
|
(parse-*-pattern stx decls #f #f))
|
|
|
|
;; parse-head-pattern : stx DeclEnv -> HeadPattern
|
|
(define (parse-head-pattern stx decls)
|
|
(parse-*-pattern stx decls #t #f))
|
|
|
|
;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern
|
|
(define (parse-*-pattern stx decls allow-head? allow-action?)
|
|
(define (check-head! x)
|
|
(unless allow-head?
|
|
(wrong-syntax stx "head pattern not allowed here"))
|
|
x)
|
|
(define (check-action! x)
|
|
;; Coerce to S-pattern IF only S-patterns allowed
|
|
(cond [allow-action? x]
|
|
[(not allow-head?) (action-pattern->single-pattern x)]
|
|
[else
|
|
(wrong-syntax stx "action pattern not allowed here")]))
|
|
(syntax-case stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe
|
|
~seq ~optional ~! ~bind ~fail ~parse ~do
|
|
~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
|
|
~splicing-reflect)
|
|
[wildcard
|
|
(wildcard? #'wildcard)
|
|
(begin (disappeared! stx)
|
|
(create-pat:any))]
|
|
[~!
|
|
(disappeared! stx)
|
|
(begin
|
|
(unless (cut-allowed?)
|
|
(wrong-syntax stx
|
|
"cut (~~!) not allowed within ~~not pattern"))
|
|
(check-action!
|
|
(create-action:cut)))]
|
|
[reserved
|
|
(reserved? #'reserved)
|
|
(wrong-syntax stx "pattern keyword not allowed here")]
|
|
[id
|
|
(identifier? #'id)
|
|
(parse-pat:id stx decls allow-head?)]
|
|
[datum
|
|
(atomic-datum? #'datum)
|
|
(create-pat:datum (syntax->datum #'datum))]
|
|
[(~var . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:var stx decls allow-head?)]
|
|
[(~datum . rest)
|
|
(disappeared! stx)
|
|
(syntax-case stx (~datum)
|
|
[(~datum d)
|
|
(create-pat:datum (syntax->datum #'d))]
|
|
[_ (wrong-syntax stx "bad ~~datum form")])]
|
|
[(~literal . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:literal stx decls)]
|
|
[(~and . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:and stx decls allow-head? allow-action?)]
|
|
[(~or . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:or stx decls allow-head?)]
|
|
[(~not . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:not stx decls)]
|
|
[(~rest . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:rest stx decls)]
|
|
[(~describe . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:describe stx decls allow-head?)]
|
|
[(~delimit-cut . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:delimit stx decls allow-head?)]
|
|
[(~commit . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:commit stx decls allow-head?)]
|
|
[(~reflect . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:reflect stx decls #f)]
|
|
[(~seq . rest)
|
|
(disappeared! stx)
|
|
(check-head!
|
|
(parse-hpat:seq stx #'rest decls))]
|
|
[(~optional . rest)
|
|
(disappeared! stx)
|
|
(check-head!
|
|
(parse-hpat:optional stx decls))]
|
|
[(~splicing-reflect . rest)
|
|
(disappeared! stx)
|
|
(check-head!
|
|
(parse-pat:reflect stx decls #t))]
|
|
[(~bind . rest)
|
|
(disappeared! stx)
|
|
(check-action!
|
|
(parse-pat:bind stx decls))]
|
|
[(~fail . rest)
|
|
(disappeared! stx)
|
|
(check-action!
|
|
(parse-pat:fail stx decls))]
|
|
[(~post . rest)
|
|
(disappeared! stx)
|
|
(parse-pat:post stx decls allow-head? allow-action?)]
|
|
[(~peek . rest)
|
|
(disappeared! stx)
|
|
(check-head!
|
|
(parse-pat:peek stx decls))]
|
|
[(~peek-not . rest)
|
|
(disappeared! stx)
|
|
(check-head!
|
|
(parse-pat:peek-not stx decls))]
|
|
[(~parse . rest)
|
|
(disappeared! stx)
|
|
(check-action!
|
|
(parse-pat:parse stx decls))]
|
|
[(~do . rest)
|
|
(disappeared! stx)
|
|
(check-action!
|
|
(parse-pat:do stx decls))]
|
|
[(head dots . tail)
|
|
(dots? #'dots)
|
|
(begin (disappeared! #'dots)
|
|
(parse-pat:dots stx #'head #'tail decls))]
|
|
[(head plus-dots . tail)
|
|
(plus-dots? #'plus-dots)
|
|
(begin (disappeared! #'plus-dots)
|
|
(parse-pat:plus-dots stx #'head #'tail decls))]
|
|
[(head . tail)
|
|
(let ([headp (parse-*-pattern #'head decls #t #t)]
|
|
[tailp (parse-single-pattern #'tail decls)])
|
|
(cond [(action-pattern? headp)
|
|
(create-pat:action headp tailp)]
|
|
[(head-pattern? headp)
|
|
(create-pat:head headp tailp)]
|
|
[else
|
|
(create-pat:pair headp tailp)]))]
|
|
[#(a ...)
|
|
(let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
|
|
(create-pat:vector lp))]
|
|
[b
|
|
(box? (syntax-e #'b))
|
|
(let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)])
|
|
(create-pat:box bp))]
|
|
[s
|
|
(and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s)))
|
|
(let* ([s (syntax-e #'s)]
|
|
[key (prefab-struct-key s)]
|
|
[contents (struct->list s)])
|
|
(let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
|
|
(create-pat:pstruct key lp)))]))
|
|
|
|
;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern)
|
|
(define (parse-ellipsis-head-pattern stx decls)
|
|
(for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))])
|
|
(car ehpat+hstx)))
|
|
|
|
;; parse*-ellipsis-head-pattern : stx DeclEnv bool
|
|
;; -> (listof (list EllipsisHeadPattern stx/eh-alternative))
|
|
(define (parse*-ellipsis-head-pattern stx decls allow-or?
|
|
#:context [ctx (current-syntax-context)])
|
|
(syntax-case stx (~eh-var ~or ~between ~optional ~once)
|
|
[(~eh-var name eh-alt-set-id)
|
|
(let ()
|
|
(define prefix (name->prefix #'name "."))
|
|
(define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id))
|
|
(for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))])
|
|
(let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
|
|
[attr-count (length iattrs)])
|
|
(list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt))
|
|
(create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f)
|
|
(eh-alternative-repc alt))
|
|
(replace-eh-alternative-attrs
|
|
alt (iattrs->sattrs iattrs))))))]
|
|
[(~or . _)
|
|
allow-or?
|
|
(begin
|
|
(unless (stx-list? stx)
|
|
(wrong-syntax stx "expected sequence of patterns"))
|
|
(apply append
|
|
(for/list ([sub (in-list (cdr (stx->list stx)))])
|
|
(parse*-ellipsis-head-pattern sub decls allow-or?))))]
|
|
[(~optional . _)
|
|
(disappeared! stx)
|
|
(list (parse*-ehpat/optional stx decls))]
|
|
[(~once . _)
|
|
(disappeared! stx)
|
|
(list (parse*-ehpat/once stx decls))]
|
|
[(~between . _)
|
|
(disappeared! stx)
|
|
(list (parse*-ehpat/bounds stx decls))]
|
|
[_
|
|
(let ([head (parse-head-pattern stx decls)])
|
|
(list (list (make ehpat (map increase-depth (pattern-attrs head))
|
|
head
|
|
#f)
|
|
stx)))]))
|
|
|
|
(define (repc-adjust-attrs iattrs repc)
|
|
(cond [(or (rep:once? repc) (rep:optional? repc))
|
|
iattrs]
|
|
[(or (rep:bounds? repc) (eq? #f repc))
|
|
(map increase-depth iattrs)]
|
|
[else
|
|
(error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
|
|
|
|
(define (replace-eh-alternative-attrs alt sattrs)
|
|
(match alt
|
|
[(eh-alternative repc _attrs parser)
|
|
(eh-alternative repc sattrs parser)]))
|
|
|
|
;; ----
|
|
|
|
(define (check-no-delimit-cut-in-not id delimit-cut?)
|
|
(unless (or delimit-cut? (cut-allowed?))
|
|
(wrong-syntax id
|
|
(string-append "syntax class with #:no-delimit-cut option "
|
|
"not allowed within ~~not pattern"))))
|
|
|
|
(define (parse-pat:id id decls allow-head?)
|
|
(define entry (declenv-lookup decls id))
|
|
(match entry
|
|
[(struct den:lit (internal literal input-phase lit-phase))
|
|
(create-pat:literal literal input-phase lit-phase)]
|
|
[(struct den:magic-class (name class argu))
|
|
(let* ([pos-count (length (arguments-pargs argu))]
|
|
[kws (arguments-kws argu)]
|
|
[sc (get-stxclass/check-arity class class pos-count kws)]
|
|
[splicing? (stxclass-splicing? sc)]
|
|
[attrs (stxclass-attrs sc)]
|
|
[parser (stxclass-parser sc)]
|
|
[commit? (stxclass-commit? sc)]
|
|
[delimit-cut? (stxclass-delimit-cut? sc)])
|
|
(check-no-delimit-cut-in-not id delimit-cut?)
|
|
(if splicing?
|
|
(begin
|
|
(unless allow-head?
|
|
(wrong-syntax id "splicing syntax class not allowed here"))
|
|
(parse-pat:id/h id parser argu attrs commit?))
|
|
(parse-pat:id/s id parser argu attrs commit?)))]
|
|
[(struct den:class (_n _c _a))
|
|
(error 'parse-pat:id
|
|
"(internal error) decls had leftover stxclass entry: ~s"
|
|
entry)]
|
|
[(struct den:parser (parser attrs splicing? commit? delimit-cut?))
|
|
(begin
|
|
(check-no-delimit-cut-in-not id delimit-cut?)
|
|
(if splicing?
|
|
(begin
|
|
(unless allow-head?
|
|
(wrong-syntax id "splicing syntax class not allowed here"))
|
|
(parse-pat:id/h id parser no-arguments attrs commit?))
|
|
(parse-pat:id/s id parser no-arguments attrs commit?)))]
|
|
[(struct den:delayed (parser class))
|
|
(let ([sc (get-stxclass class)])
|
|
(check-no-delimit-cut-in-not id (stxclass-delimit-cut? sc))
|
|
(cond [(stxclass/s? sc)
|
|
(parse-pat:id/s id
|
|
parser
|
|
no-arguments
|
|
(stxclass-attrs sc)
|
|
(stxclass-commit? sc))]
|
|
[(stxclass/h? sc)
|
|
(unless allow-head?
|
|
(wrong-syntax id "splicing syntax class not allowed here"))
|
|
(parse-pat:id/h id
|
|
parser
|
|
no-arguments
|
|
(stxclass-attrs sc)
|
|
(stxclass-commit? sc))]))]
|
|
['#f
|
|
(unless (safe-name? id)
|
|
(wrong-syntax id "expected identifier not starting with ~~ character"))
|
|
(let-values ([(name sc) (split-id/get-stxclass id decls)])
|
|
(if sc
|
|
(parse-pat:var* id allow-head? name sc no-arguments)
|
|
(create-pat:var name #f no-arguments null #f #t)))]))
|
|
|
|
(define (parse-pat:var stx decls allow-head?)
|
|
(define name0
|
|
(syntax-case stx (~var)
|
|
[(~var name . _)
|
|
(unless (identifier? #'name)
|
|
(wrong-syntax #'name "expected identifier"))
|
|
#'name]
|
|
[_
|
|
(wrong-syntax stx "bad ~~var form")]))
|
|
(define-values (scname sc+args-stx argu pfx)
|
|
(syntax-case stx (~var)
|
|
[(~var _name)
|
|
(values #f #f null #f)]
|
|
[(~var _name sc/sc+args . rest)
|
|
(let-values ([(sc argu)
|
|
(let ([p (check-stxclass-application #'sc/sc+args stx)])
|
|
(values (car p) (cdr p)))])
|
|
(define chunks
|
|
(parse-keyword-options/eol #'rest var-pattern-directive-table
|
|
#:no-duplicates? #t
|
|
#:context stx))
|
|
(define sep
|
|
(options-select-value chunks '#:attr-name-separator #:default #f))
|
|
(values sc #'sc/sc+args argu (if sep (syntax-e sep) ".")))]
|
|
[_
|
|
(wrong-syntax stx "bad ~~var form")]))
|
|
(cond [(and (epsilon? name0) (not scname))
|
|
(wrong-syntax name0 "illegal pattern variable name")]
|
|
[(and (wildcard? name0) (not scname))
|
|
(create-pat:any)]
|
|
[scname
|
|
(let ([sc (get-stxclass/check-arity scname sc+args-stx
|
|
(length (arguments-pargs argu))
|
|
(arguments-kws argu))])
|
|
(parse-pat:var* stx allow-head? name0 sc argu pfx))]
|
|
[else ;; Just proper name
|
|
(create-pat:var name0 #f (arguments null null null) null #f #t)]))
|
|
|
|
(define (parse-pat:var* stx allow-head? name sc argu [pfx "."])
|
|
(check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
|
|
(cond [(stxclass/s? sc)
|
|
(if (and (stxclass-integrate sc) (null? (arguments-kws argu)))
|
|
(parse-pat:id/s/integrate name (stxclass-integrate sc) argu)
|
|
(parse-pat:id/s name
|
|
(stxclass-parser sc)
|
|
argu
|
|
(stxclass-attrs sc)
|
|
(stxclass-commit? sc)
|
|
pfx))]
|
|
[(stxclass/h? sc)
|
|
(unless allow-head?
|
|
(wrong-syntax stx "splicing syntax class not allowed here"))
|
|
(parse-pat:id/h name
|
|
(stxclass-parser sc)
|
|
argu
|
|
(stxclass-attrs sc)
|
|
(stxclass-commit? sc)
|
|
pfx)]))
|
|
|
|
(define (parse-pat:id/s name parser argu attrs commit? [pfx "."])
|
|
(define prefix (name->prefix name pfx))
|
|
(define bind (name->bind name))
|
|
(create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?))
|
|
|
|
(define (parse-pat:id/s/integrate name integrate argu)
|
|
(define bind (name->bind name))
|
|
(create-pat:integrated bind argu
|
|
(integrate-predicate integrate)
|
|
(integrate-description integrate)))
|
|
|
|
(define (parse-pat:id/h name parser argu attrs commit? [pfx "."])
|
|
(define prefix (name->prefix name pfx))
|
|
(define bind (name->bind name))
|
|
(create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?))
|
|
|
|
(define (name->prefix id pfx)
|
|
(cond [(wildcard? id) #f]
|
|
[(epsilon? id) id]
|
|
[else (format-id id "~a~a" (syntax-e id) pfx)]))
|
|
|
|
(define (name->bind id)
|
|
(cond [(wildcard? id) #f]
|
|
[(epsilon? id) #f]
|
|
[else id]))
|
|
|
|
;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr)
|
|
(define (id-pattern-attrs sattrs prefix)
|
|
(if prefix
|
|
(for/list ([a (in-list sattrs)])
|
|
(prefix-attr a prefix))
|
|
null))
|
|
|
|
;; prefix-attr : SAttr identifier -> IAttr
|
|
(define (prefix-attr a prefix)
|
|
(make attr (prefix-attr-name prefix (attr-name a))
|
|
(attr-depth a)
|
|
(attr-syntax? a)))
|
|
|
|
;; prefix-attr-name : id symbol -> id
|
|
(define (prefix-attr-name prefix name)
|
|
(format-id prefix "~a~a" (syntax-e prefix) name))
|
|
|
|
;; ----
|
|
|
|
(define (parse-pat:reflect stx decls splicing?)
|
|
(syntax-case stx ()
|
|
[(_ name (obj arg ...) . maybe-signature)
|
|
(let ()
|
|
(unless (identifier? #'var)
|
|
(raise-syntax-error #f "expected identifier" stx #'name))
|
|
(define attr-decls
|
|
(syntax-case #'maybe-signature ()
|
|
[(#:attributes attr-decls)
|
|
(check-attr-arity-list #'attr-decls stx)]
|
|
[() null]
|
|
[_ (raise-syntax-error #f "bad syntax" stx)]))
|
|
(define prefix (name->prefix #'name "."))
|
|
(define bind (name->bind #'name))
|
|
(define ctor (if splicing? create-hpat:reflect create-pat:reflect))
|
|
(ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind
|
|
(id-pattern-attrs attr-decls prefix)))]))
|
|
|
|
;; ---
|
|
|
|
(define (parse-pat:literal stx decls)
|
|
(syntax-case stx (~literal)
|
|
[(~literal lit . more)
|
|
(unless (identifier? #'lit)
|
|
(wrong-syntax #'lit "expected identifier"))
|
|
(let* ([chunks (parse-keyword-options/eol #'more phase-directive-table
|
|
#:no-duplicates? #t
|
|
#:context stx)]
|
|
[phase (options-select-value chunks '#:phase
|
|
#:default #'(syntax-local-phase-level))])
|
|
;; FIXME: Duplicates phase expr!
|
|
(create-pat:literal #'lit phase phase))]
|
|
[_
|
|
(wrong-syntax stx "bad ~~literal pattern")]))
|
|
|
|
(define (parse-pat:describe stx decls allow-head?)
|
|
(syntax-case stx ()
|
|
[(_ . rest)
|
|
(let-values ([(chunks rest)
|
|
(parse-keyword-options #'rest describe-option-table
|
|
#:no-duplicates? #t
|
|
#:context stx)])
|
|
(define transparent? (not (assq '#:opaque chunks)))
|
|
(syntax-case rest ()
|
|
[(description pattern)
|
|
(let ([p (parse-*-pattern #'pattern decls allow-head? #f)])
|
|
(if (head-pattern? p)
|
|
(create-hpat:describe #'description transparent? p)
|
|
(create-pat:describe #'description transparent? p)))]))]))
|
|
|
|
(define (parse-pat:delimit stx decls allow-head?)
|
|
(syntax-case stx ()
|
|
[(_ pattern)
|
|
(let ([p (parameterize ((cut-allowed? #t))
|
|
(parse-*-pattern #'pattern decls allow-head? #f))])
|
|
(if (head-pattern? p)
|
|
(create-hpat:delimit p)
|
|
(create-pat:delimit p)))]))
|
|
|
|
(define (parse-pat:commit stx decls allow-head?)
|
|
(syntax-case stx ()
|
|
[(_ pattern)
|
|
(let ([p (parameterize ((cut-allowed? #t))
|
|
(parse-*-pattern #'pattern decls allow-head? #f))])
|
|
(if (head-pattern? p)
|
|
(create-hpat:commit p)
|
|
(create-pat:commit p)))]))
|
|
|
|
(define (split-prefix xs pred)
|
|
(let loop ([xs xs] [rprefix null])
|
|
(cond [(and (pair? xs) (pred (car xs)))
|
|
(loop (cdr xs) (cons (car xs) rprefix))]
|
|
[else
|
|
(values (reverse rprefix) xs)])))
|
|
|
|
(define (parse-pat:and stx decls allow-head? allow-action?)
|
|
;; allow-action? = allowed to *return* pure action pattern;
|
|
;; all ~and patterns are allowed to *contain* action patterns
|
|
(define patterns0 (parse-cdr-patterns stx decls allow-head? #t))
|
|
(define-values (actions patterns) (split-prefix patterns0 action-pattern?))
|
|
(cond [(null? patterns)
|
|
(cond [allow-action?
|
|
(create-action:and actions)]
|
|
[allow-head?
|
|
(wrong-syntax stx "expected at least one head pattern")]
|
|
[else
|
|
(wrong-syntax stx "expected at least one single-term pattern")])]
|
|
[else
|
|
(let ([p (parse-pat:and* stx patterns)])
|
|
(if (head-pattern? p)
|
|
(for/fold ([p p]) ([action (in-list (reverse actions))])
|
|
(create-hpat:action action p))
|
|
(for/fold ([p p]) ([action (in-list (reverse actions))])
|
|
(create-pat:action action p))))]))
|
|
|
|
(define (parse-pat:and* stx patterns)
|
|
;; patterns is non-empty (empty case handled above)
|
|
(cond [(null? (cdr patterns))
|
|
(car patterns)]
|
|
[(ormap head-pattern? patterns)
|
|
;; Check to make sure *all* are head patterns
|
|
(for ([pattern (in-list patterns)]
|
|
[pattern-stx (in-list (stx->list (stx-cdr stx)))])
|
|
(unless (or (action-pattern? pattern) (head-pattern? pattern))
|
|
(wrong-syntax
|
|
pattern-stx
|
|
"single-term pattern not allowed after head pattern")))
|
|
(let ([p0 (car patterns)]
|
|
[lps (map action/head-pattern->list-pattern (cdr patterns))])
|
|
(create-hpat:and p0 (create-pat:and lps)))]
|
|
[else
|
|
(create-pat:and
|
|
(for/list ([p (in-list patterns)])
|
|
(if (action-pattern? p)
|
|
(action-pattern->single-pattern p)
|
|
p)))]))
|
|
|
|
(define (parse-pat:or stx decls allow-head?)
|
|
(define patterns (parse-cdr-patterns stx decls allow-head? #f))
|
|
(cond [(null? (cdr patterns))
|
|
(car patterns)]
|
|
[else
|
|
(cond [(ormap head-pattern? patterns)
|
|
(create-hpat:or patterns)]
|
|
[else
|
|
(create-pat:or patterns)])]))
|
|
|
|
(define (parse-pat:not stx decls)
|
|
(syntax-case stx (~not)
|
|
[(~not pattern)
|
|
(let ([p (parameterize ((cut-allowed? #f))
|
|
(parse-single-pattern #'pattern decls))])
|
|
(create-pat:not p))]
|
|
[_
|
|
(wrong-syntax stx "expected a single subpattern")]))
|
|
|
|
(define (parse-hpat:seq stx list-stx decls)
|
|
(define pattern (parse-single-pattern list-stx decls))
|
|
(check-list-pattern pattern stx)
|
|
(create-hpat:seq pattern))
|
|
|
|
(define (parse-cdr-patterns stx decls allow-head? allow-action?)
|
|
(unless (stx-list? stx)
|
|
(wrong-syntax stx "expected sequence of patterns"))
|
|
(let ([result
|
|
(for/list ([sub (in-list (cdr (stx->list stx)))])
|
|
(parse-*-pattern sub decls allow-head? allow-action?))])
|
|
(when (null? result)
|
|
(wrong-syntax stx "expected at least one pattern"))
|
|
result))
|
|
|
|
(define (parse-pat:dots stx head tail decls)
|
|
(define headps (parse-ellipsis-head-pattern head decls))
|
|
(define tailp (parse-single-pattern tail decls))
|
|
(unless (pair? headps)
|
|
(wrong-syntax head "expected at least one pattern"))
|
|
(create-pat:dots headps tailp))
|
|
|
|
(define (parse-pat:plus-dots stx head tail decls)
|
|
(define headp (parse-head-pattern head decls))
|
|
(define tailp (parse-single-pattern tail decls))
|
|
(define head/rep
|
|
(make-ehpat (map increase-depth (pattern-attrs headp))
|
|
headp
|
|
(make-rep:bounds 1 +inf.0 #f #f #f)))
|
|
(create-pat:dots (list head/rep) tailp))
|
|
|
|
(define (parse-pat:bind stx decls)
|
|
(syntax-case stx ()
|
|
[(_ clause ...)
|
|
(let ([clauses (check-bind-clause-list #'(clause ...) stx)])
|
|
(make action:bind
|
|
(append-iattrs (side-clauses-attrss clauses))
|
|
clauses))]))
|
|
|
|
(define (parse-pat:fail stx decls)
|
|
(syntax-case stx ()
|
|
[(_ . rest)
|
|
(let-values ([(chunks rest)
|
|
(parse-keyword-options #'rest fail-directive-table
|
|
#:context stx
|
|
#:incompatible '((#:when #:unless))
|
|
#:no-duplicates? #t)])
|
|
(let ([condition
|
|
(if (null? chunks)
|
|
#'#t
|
|
(let ([chunk (car chunks)])
|
|
(if (eq? (car chunk) '#:when)
|
|
(caddr chunk)
|
|
#`(not #,(caddr chunk)))))])
|
|
(syntax-case rest ()
|
|
[(message)
|
|
(create-action:fail condition #'message)]
|
|
[()
|
|
(create-action:fail condition #''#f)]
|
|
[_
|
|
(wrong-syntax stx "bad ~~fail pattern")])))]))
|
|
|
|
(define (parse-pat:post stx decls allow-head? allow-action?)
|
|
(syntax-case stx ()
|
|
[(_ pattern)
|
|
(let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)])
|
|
(cond [(action-pattern? p)
|
|
(cond [allow-action? (create-action:post p)]
|
|
[(not allow-head?) (create-pat:post (action-pattern->single-pattern p))]
|
|
[else (wrong-syntax stx "action pattern not allowed here")])]
|
|
[(head-pattern? p)
|
|
(cond [allow-head? (create-hpat:post p)]
|
|
[else (wrong-syntax stx "head pattern now allowed here")])]
|
|
[else
|
|
(create-pat:post p)]))]))
|
|
|
|
(define (parse-pat:peek stx decls)
|
|
(syntax-case stx (~peek)
|
|
[(~peek pattern)
|
|
(let ([p (parse-head-pattern #'pattern decls)])
|
|
(create-hpat:peek p))]))
|
|
|
|
(define (parse-pat:peek-not stx decls)
|
|
(syntax-case stx (~peek-not)
|
|
[(~peek-not pattern)
|
|
(let ([p (parse-head-pattern #'pattern decls)])
|
|
(create-hpat:peek-not p))]))
|
|
|
|
(define (parse-pat:parse stx decls)
|
|
(syntax-case stx (~parse)
|
|
[(~parse pattern expr)
|
|
(let ([p (parse-single-pattern #'pattern decls)])
|
|
(create-action:parse p #'expr))]
|
|
[_
|
|
(wrong-syntax stx "bad ~~parse pattern")]))
|
|
|
|
(define (parse-pat:do stx decls)
|
|
(syntax-case stx (~do)
|
|
[(~do stmt ...)
|
|
(create-action:do (syntax->list #'(stmt ...)))]
|
|
[_
|
|
(wrong-syntax stx "bad ~~do pattern")]))
|
|
|
|
(define (parse-pat:rest stx decls)
|
|
(syntax-case stx ()
|
|
[(_ pattern)
|
|
(parse-single-pattern #'pattern decls)]))
|
|
|
|
(define (check-list-pattern pattern stx)
|
|
(match pattern
|
|
[(make pat:datum _base '())
|
|
#t]
|
|
[(make pat:head _base _head tail)
|
|
(check-list-pattern tail stx)]
|
|
[(make pat:action _base _action tail)
|
|
(check-list-pattern tail stx)]
|
|
[(make pat:dots _base _head tail)
|
|
(check-list-pattern tail stx)]
|
|
[(make pat:pair _base _head tail)
|
|
(check-list-pattern tail stx)]
|
|
[_
|
|
(wrong-syntax stx "expected proper list pattern")]))
|
|
|
|
(define (parse-hpat:optional stx decls)
|
|
(define-values (head-stx head iattrs _name _tmm defaults)
|
|
(parse*-optional-pattern stx decls h-optional-directive-table))
|
|
(make hpat:optional iattrs head defaults))
|
|
|
|
;; parse*-optional-pattern : stx DeclEnv table
|
|
;; -> (values
|
|
(define (parse*-optional-pattern stx decls optional-directive-table)
|
|
(syntax-case stx (~optional)
|
|
[(~optional p . options)
|
|
(let* ([head (parse-head-pattern #'p decls)]
|
|
[chunks
|
|
(parse-keyword-options/eol #'options optional-directive-table
|
|
#:no-duplicates? #t
|
|
#:context stx)]
|
|
[too-many-msg
|
|
(options-select-value chunks '#:too-many #:default #'#f)]
|
|
[name
|
|
(options-select-value chunks '#:name #:default #'#f)]
|
|
[defaults
|
|
(options-select-value chunks '#:defaults #:default '())]
|
|
[pattern-iattrs (pattern-attrs head)]
|
|
[defaults-iattrs
|
|
(append-iattrs (side-clauses-attrss defaults))]
|
|
[all-iattrs
|
|
(union-iattrs (list pattern-iattrs defaults-iattrs))])
|
|
(check-iattrs-subset defaults-iattrs pattern-iattrs stx)
|
|
(values #'p head all-iattrs name too-many-msg defaults))]))
|
|
|
|
;; -- EH patterns
|
|
;; Only parse the rep-constraint part; don't parse the head pattern within.
|
|
;; (To support eh-alternative-sets.)
|
|
|
|
;; parse*-ehpat/optional : stx DeclEnv -> (list EllipsisHeadPattern stx)
|
|
(define (parse*-ehpat/optional stx decls)
|
|
(define-values (head-stx head iattrs name too-many-msg defaults)
|
|
(parse*-optional-pattern stx decls eh-optional-directive-table))
|
|
(list (make ehpat iattrs
|
|
head
|
|
(make rep:optional name too-many-msg defaults))
|
|
head-stx))
|
|
|
|
;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx)
|
|
(define (parse*-ehpat/once stx decls)
|
|
(syntax-case stx (~once)
|
|
[(~once p . options)
|
|
(let* ([head (parse-head-pattern #'p decls)]
|
|
[chunks
|
|
(parse-keyword-options/eol #'options
|
|
(list (list '#:too-few check-expression)
|
|
(list '#:too-many check-expression)
|
|
(list '#:name check-expression))
|
|
#:context stx)]
|
|
[too-few-msg
|
|
(options-select-value chunks '#:too-few #:default #'#f)]
|
|
[too-many-msg
|
|
(options-select-value chunks '#:too-many #:default #'#f)]
|
|
[name
|
|
(options-select-value chunks '#:name #:default #'#f)])
|
|
(list (make ehpat (pattern-attrs head)
|
|
head
|
|
(make rep:once name too-few-msg too-many-msg))
|
|
#'p))]))
|
|
|
|
;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx)
|
|
(define (parse*-ehpat/bounds stx decls)
|
|
(syntax-case stx (~between)
|
|
[(~between p min max . options)
|
|
(let ()
|
|
(define head (parse-head-pattern #'p decls))
|
|
(define minN (syntax-e #'min))
|
|
(define maxN (syntax-e #'max))
|
|
(unless (exact-nonnegative-integer? minN)
|
|
(wrong-syntax #'min
|
|
"expected exact nonnegative integer"))
|
|
(unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0))
|
|
(wrong-syntax #'max
|
|
"expected exact nonnegative integer or +inf.0"))
|
|
(when (> minN maxN)
|
|
(wrong-syntax stx "minimum larger than maximum repetition constraint"))
|
|
(let* ([chunks (parse-keyword-options/eol
|
|
#'options
|
|
(list (list '#:too-few check-expression)
|
|
(list '#:too-many check-expression)
|
|
(list '#:name check-expression))
|
|
#:context stx)]
|
|
[too-few-msg
|
|
(options-select-value chunks '#:too-few #:default #'#f)]
|
|
[too-many-msg
|
|
(options-select-value chunks '#:too-many #:default #'#f)]
|
|
[name
|
|
(options-select-value chunks '#:name #:default #'#f)])
|
|
(list (make ehpat (map increase-depth (pattern-attrs head))
|
|
head
|
|
(make rep:bounds #'min #'max
|
|
name too-few-msg too-many-msg))
|
|
#'p)))]))
|
|
|
|
;; -----
|
|
|
|
;; parse-pattern-directives : stxs(PatternDirective) <kw-args>
|
|
;; -> stx DeclEnv (listof stx) (listof SideClause)
|
|
(define (parse-pattern-directives stx
|
|
#:allow-declare? allow-declare?
|
|
#:decls decls
|
|
#:context ctx)
|
|
(parameterize ((current-syntax-context ctx))
|
|
(define-values (chunks rest)
|
|
(parse-keyword-options stx pattern-directive-table #:context ctx))
|
|
(define-values (decls2 chunks2)
|
|
(if allow-declare?
|
|
(grab-decls chunks decls)
|
|
(values decls chunks)))
|
|
(define sides
|
|
;; NOTE: use *original* decls
|
|
;; because decls2 has #:declares for *above* pattern
|
|
(parse-pattern-sides chunks2 decls))
|
|
(define-values (decls3 defs)
|
|
(decls-create-defs decls2))
|
|
(values rest decls3 defs (parse-pattern-sides chunks2 decls))))
|
|
|
|
;; parse-pattern-sides : (listof chunk) DeclEnv
|
|
;; -> (listof SideClause/c)
|
|
;; Invariant: decls contains only literals bindings
|
|
(define (parse-pattern-sides chunks decls)
|
|
(match chunks
|
|
[(cons (list '#:declare declare-stx _ _) rest)
|
|
(wrong-syntax declare-stx
|
|
"#:declare can only follow pattern or #:with clause")]
|
|
[(cons (list '#:fail-when fw-stx when-condition expr) rest)
|
|
(cons (make clause:fail when-condition expr)
|
|
(parse-pattern-sides rest decls))]
|
|
[(cons (list '#:fail-unless fu-stx unless-condition expr) rest)
|
|
(cons (make clause:fail #`(not #,unless-condition) expr)
|
|
(parse-pattern-sides rest decls))]
|
|
[(cons (list '#:when w-stx unless-condition) rest)
|
|
;; Bleh: when is basically fail-unless without the msg argument
|
|
(cons (make clause:fail #`(not #,unless-condition) #'#f)
|
|
(parse-pattern-sides rest decls))]
|
|
[(cons (list '#:with with-stx pattern expr) rest)
|
|
(let-values ([(decls2 rest) (grab-decls rest decls)])
|
|
(let-values ([(decls2a defs) (decls-create-defs decls2)])
|
|
(cons (make clause:with (parse-whole-pattern pattern decls2a) expr defs)
|
|
(parse-pattern-sides rest decls))))]
|
|
[(cons (list '#:attr attr-stx a expr) rest)
|
|
(cons (make clause:attr a expr)
|
|
(parse-pattern-sides rest decls))]
|
|
[(cons (list '#:do do-stx stmts) rest)
|
|
(cons (make clause:do stmts)
|
|
(parse-pattern-sides rest decls))]
|
|
['()
|
|
'()]))
|
|
|
|
;; grab-decls : (listof chunk) DeclEnv
|
|
;; -> (values DeclEnv (listof chunk))
|
|
(define (grab-decls chunks decls0)
|
|
(define (add-decl stx decls)
|
|
(syntax-case stx ()
|
|
[(#:declare name sc)
|
|
(identifier? #'sc)
|
|
(add-decl* decls #'name #'sc (parse-argu null))]
|
|
[(#:declare name (sc expr ...))
|
|
(identifier? #'sc)
|
|
(add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))))]
|
|
[(#:declare name bad-sc)
|
|
(wrong-syntax #'bad-sc
|
|
"expected syntax class name (possibly with parameters)")]))
|
|
(define (add-decl* decls id sc-name argu)
|
|
(declenv-put-stxclass decls id sc-name argu))
|
|
(define (loop chunks decls)
|
|
(match chunks
|
|
[(cons (cons '#:declare decl-stx) rest)
|
|
(loop rest (add-decl decl-stx decls))]
|
|
[_ (values decls chunks)]))
|
|
(loop chunks decls0))
|
|
|
|
|
|
;; ----
|
|
|
|
;; Keyword Options & Checkers
|
|
|
|
;; check-attr-arity-list : stx stx -> (listof SAttr)
|
|
(define (check-attr-arity-list stx ctx)
|
|
(unless (stx-list? stx)
|
|
(raise-syntax-error #f "expected list of attribute declarations" ctx stx))
|
|
(let ([iattrs
|
|
(for/list ([x (in-list (stx->list stx))])
|
|
(check-attr-arity x ctx))])
|
|
(iattrs->sattrs (append-iattrs (map list iattrs)))))
|
|
|
|
;; check-attr-arity : stx stx -> IAttr
|
|
(define (check-attr-arity stx ctx)
|
|
(syntax-case stx ()
|
|
[attr
|
|
(identifier? #'attr)
|
|
(make-attr #'attr 0 #f)]
|
|
[(attr depth)
|
|
(begin (unless (identifier? #'attr)
|
|
(raise-syntax-error #f "expected attribute name" ctx #'attr))
|
|
(unless (exact-nonnegative-integer? (syntax-e #'depth))
|
|
(raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth))
|
|
(make-attr #'attr (syntax-e #'depth) #f))]
|
|
[_
|
|
(raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
|
|
|
|
;; check-literals-list : stx stx -> (listof (list id id ct-phase ct-phase))
|
|
;; - txlifts defs of phase expressions
|
|
;; - txlifts checks that literals are bound
|
|
(define (check-literals-list stx ctx)
|
|
(unless (stx-list? stx)
|
|
(raise-syntax-error #f "expected literals list" ctx stx))
|
|
(let ([lits
|
|
(for/list ([x (in-list (stx->list stx))])
|
|
(check-literal-entry x ctx))])
|
|
(let ([dup (check-duplicate-identifier (map car lits))])
|
|
(when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
|
|
lits))
|
|
|
|
;; check-literal-entry : stx stx -> (list id id ct-phase ct-phase)
|
|
(define (check-literal-entry stx ctx)
|
|
(define (go internal external phase)
|
|
(txlift #`(check-literal #,external #,phase #,ctx))
|
|
(list internal external phase phase))
|
|
(syntax-case stx ()
|
|
[(internal external #:phase phase)
|
|
(and (identifier? #'internal) (identifier? #'external))
|
|
(go #'internal #'external (txlift #'phase))]
|
|
[(internal external)
|
|
(and (identifier? #'internal) (identifier? #'external))
|
|
(go #'internal #'external #'(syntax-local-phase-level))]
|
|
[id
|
|
(identifier? #'id)
|
|
(go #'id #'id #'(syntax-local-phase-level))]
|
|
[_
|
|
(raise-syntax-error #f "expected literal entry"
|
|
ctx stx)]))
|
|
|
|
;; Literal sets - Import
|
|
|
|
;; check-literal-sets-list : stx stx -> (listof (listof (list id id ct-phase^2)))
|
|
(define (check-literal-sets-list stx ctx)
|
|
(unless (stx-list? stx)
|
|
(raise-syntax-error #f "expected literal-set list" ctx stx))
|
|
(for/list ([x (in-list (stx->list stx))])
|
|
(check-literal-set-entry x ctx)))
|
|
|
|
;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase^2))
|
|
(define (check-literal-set-entry stx ctx)
|
|
(define (elaborate litset-id lctx phase)
|
|
(let ([litset (syntax-local-value/record litset-id literalset?)])
|
|
(unless litset
|
|
(raise-syntax-error #f "expected identifier defined as a literal-set"
|
|
ctx litset-id))
|
|
(elaborate2 litset lctx phase)))
|
|
(define (elaborate2 litset lctx phase)
|
|
(for/list ([entry (in-list (literalset-literals litset))])
|
|
(list (datum->syntax lctx (car entry) stx)
|
|
(cadr entry)
|
|
phase
|
|
(caddr entry))))
|
|
(syntax-case stx ()
|
|
[(litset . more)
|
|
(and (identifier? #'litset))
|
|
(let* ([chunks (parse-keyword-options/eol #'more litset-directive-table
|
|
#:no-duplicates? #t
|
|
#:context ctx)]
|
|
[lctx (options-select-value chunks '#:at #:default #'litset)]
|
|
[phase (options-select-value chunks '#:phase
|
|
#:default #'(syntax-local-phase-level))])
|
|
(elaborate #'litset lctx (txlift phase)))]
|
|
[litset
|
|
(identifier? #'litset)
|
|
(elaborate #'litset #'litset #'(syntax-local-phase-level))]
|
|
[_
|
|
(raise-syntax-error #f "expected literal-set entry" ctx stx)]))
|
|
|
|
;; Conventions
|
|
|
|
;; returns (listof (cons Conventions (listof syntax)))
|
|
(define (check-conventions-list stx ctx)
|
|
(unless (stx-list? stx)
|
|
(raise-syntax-error #f "expected conventions list" ctx stx))
|
|
(for/list ([x (in-list (stx->list stx))])
|
|
(check-conventions x ctx)))
|
|
|
|
;; returns (cons Conventions (listof syntax))
|
|
(define (check-conventions stx ctx)
|
|
(define (elaborate conventions-id argu)
|
|
(let ([cs (syntax-local-value/record conventions-id conventions?)])
|
|
(unless cs
|
|
(raise-syntax-error #f "expected identifier defined as a conventions"
|
|
ctx conventions-id))
|
|
(cons cs argu)))
|
|
(syntax-case stx ()
|
|
[(conventions arg ...)
|
|
(identifier? #'conventions)
|
|
(elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))]
|
|
[conventions
|
|
(identifier? #'conventions)
|
|
(elaborate #'conventions no-arguments)]
|
|
[_
|
|
(raise-syntax-error "expected conventions entry" ctx stx)]))
|
|
|
|
;; returns (listof (list regexp DeclEntry))
|
|
(define (check-conventions-rules stx ctx)
|
|
(unless (stx-list? stx)
|
|
(raise-syntax-error #f "expected convention rule list" ctx stx))
|
|
(for/list ([x (in-list (stx->list stx))])
|
|
(check-conventions-rule x ctx)))
|
|
|
|
;; returns (list regexp DeclEntry)
|
|
(define (check-conventions-rule stx ctx)
|
|
(define (check-conventions-pattern x blame)
|
|
(cond [(symbol? x)
|
|
(regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))]
|
|
[(regexp? x) x]
|
|
[else
|
|
(raise-syntax-error #f "expected identifier convention pattern"
|
|
ctx blame)]))
|
|
(define (check-sc-expr x rx)
|
|
(let ([x (check-stxclass-application x ctx)])
|
|
(make den:class rx (car x) (cdr x))))
|
|
(syntax-case stx ()
|
|
[(rx sc)
|
|
(let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)])
|
|
(list name-pattern (check-sc-expr #'sc name-pattern)))]))
|
|
|
|
(define (check-stxclass-header stx ctx)
|
|
(syntax-case stx ()
|
|
[name
|
|
(identifier? #'name)
|
|
(list #'name #'() no-arity)]
|
|
[(name . formals)
|
|
(identifier? #'name)
|
|
(list #'name #'formals (parse-kw-formals #'formals #:context ctx))]
|
|
[_ (raise-syntax-error #f "expected syntax class header" stx ctx)]))
|
|
|
|
(define (check-stxclass-application stx ctx)
|
|
;; Doesn't check "operator" is actually a stxclass
|
|
(syntax-case stx ()
|
|
[op
|
|
(identifier? #'op)
|
|
(cons #'op no-arguments)]
|
|
[(op arg ...)
|
|
(identifier? #'op)
|
|
(cons #'op (parse-argu (syntax->list #'(arg ...))))]
|
|
[_ (raise-syntax-error #f "expected syntax class use" ctx stx)]))
|
|
|
|
;; bind clauses
|
|
(define (check-bind-clause-list stx ctx)
|
|
(unless (stx-list? stx)
|
|
(raise-syntax-error #f "expected sequence of bind clauses" ctx stx))
|
|
(for/list ([clause (in-list (stx->list stx))])
|
|
(check-bind-clause clause ctx)))
|
|
|
|
(define (check-bind-clause clause ctx)
|
|
(syntax-case clause ()
|
|
[(attr-decl expr)
|
|
(make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)]
|
|
[_ (raise-syntax-error #f "expected bind clause" ctx clause)]))
|
|
|
|
(define (check-stmt-list stx ctx)
|
|
(syntax-case stx ()
|
|
[(e ...)
|
|
(syntax->list #'(e ...))]
|
|
[_
|
|
(raise-syntax-error #f "expected list of expressions and definitions" ctx stx)]))
|
|
|
|
;; Arguments and Arities
|
|
|
|
;; parse-argu : (listof stx) -> Arguments
|
|
(define (parse-argu args #:context [ctx (current-syntax-context)])
|
|
(parameterize ((current-syntax-context ctx))
|
|
(define (loop args rpargs rkws rkwargs)
|
|
(cond [(null? args)
|
|
(arguments (reverse rpargs) (reverse rkws) (reverse rkwargs))]
|
|
[(keyword? (syntax-e (car args)))
|
|
(let ([kw (syntax-e (car args))]
|
|
[rest (cdr args)])
|
|
(cond [(memq kw rkws)
|
|
(wrong-syntax (car args) "duplicate keyword")]
|
|
[(null? rest)
|
|
(wrong-syntax (car args)
|
|
"missing argument expression after keyword")]
|
|
#| Overzealous, perhaps?
|
|
[(keyword? (syntax-e (car rest)))
|
|
(wrong-syntax (car rest) "expected expression following keyword")]
|
|
|#
|
|
[else
|
|
(loop (cdr rest) rpargs (cons kw rkws) (cons (car rest) rkwargs))]))]
|
|
[else
|
|
(loop (cdr args) (cons (car args) rpargs) rkws rkwargs)]))
|
|
(loop args null null null)))
|
|
|
|
;; parse-kw-formals : stx -> Arity
|
|
(define (parse-kw-formals formals #:context [ctx (current-syntax-context)])
|
|
(parameterize ((current-syntax-context ctx))
|
|
(define id-h (make-bound-id-table))
|
|
(define kw-h (make-hasheq)) ;; keyword => 'mandatory or 'optional
|
|
(define pos 0)
|
|
(define opts 0)
|
|
(define (add-id! id)
|
|
(when (bound-id-table-ref id-h id #f)
|
|
(wrong-syntax id "duplicate formal parameter" ))
|
|
(bound-id-table-set! id-h id #t))
|
|
(define (loop formals)
|
|
(cond [(and (stx-pair? formals) (keyword? (syntax-e (stx-car formals))))
|
|
(let* ([kw-stx (stx-car formals)]
|
|
[kw (syntax-e kw-stx)]
|
|
[rest (stx-cdr formals)])
|
|
(cond [(hash-ref kw-h kw #f)
|
|
(wrong-syntax kw-stx "duplicate keyword")]
|
|
[(stx-null? rest)
|
|
(wrong-syntax kw-stx "missing formal parameter after keyword")]
|
|
[else
|
|
(let-values ([(formal opt?) (parse-formal (stx-car rest))])
|
|
(add-id! formal)
|
|
(hash-set! kw-h kw (if opt? 'optional 'mandatory)))
|
|
(loop (stx-cdr rest))]))]
|
|
[(stx-pair? formals)
|
|
(let-values ([(formal opt?) (parse-formal (stx-car formals))])
|
|
(when (and (positive? opts) (not opt?))
|
|
(wrong-syntax (stx-car formals)
|
|
"mandatory argument may not follow optional argument"))
|
|
(add-id! formal)
|
|
(set! pos (add1 pos))
|
|
(when opt? (set! opts (add1 opts)))
|
|
(loop (stx-cdr formals)))]
|
|
[(identifier? formals)
|
|
(add-id! formals)
|
|
(finish #t)]
|
|
[(stx-null? formals)
|
|
(finish #f)]
|
|
[else
|
|
(wrong-syntax formals "bad argument sequence")]))
|
|
(define (finish has-rest?)
|
|
(arity (- pos opts)
|
|
(if has-rest? +inf.0 pos)
|
|
(sort (for/list ([(k v) (in-hash kw-h)]
|
|
#:when (eq? v 'mandatory))
|
|
k)
|
|
keyword<?)
|
|
(sort (hash-map kw-h (lambda (k v) k))
|
|
keyword<?)))
|
|
(loop formals)))
|
|
|
|
;; parse-formal : stx -> (values id bool)
|
|
(define (parse-formal formal)
|
|
(syntax-case formal ()
|
|
[param
|
|
(identifier? #'param)
|
|
(values #'param #f)]
|
|
[(param default)
|
|
(identifier? #'param)
|
|
(values #'param #t)]
|
|
[_
|
|
(wrong-syntax formal
|
|
"expected formal parameter with optional default")]))
|
|
|
|
|
|
;; Directive tables
|
|
|
|
;; common-parse-directive-table
|
|
(define common-parse-directive-table
|
|
(list (list '#:disable-colon-notation)
|
|
(list '#:literals check-literals-list)
|
|
(list '#:literal-sets check-literal-sets-list)
|
|
(list '#:conventions check-conventions-list)
|
|
(list '#:local-conventions check-conventions-rules)))
|
|
|
|
;; parse-directive-table
|
|
(define parse-directive-table
|
|
(list* (list '#:context check-expression)
|
|
common-parse-directive-table))
|
|
|
|
;; rhs-directive-table
|
|
(define rhs-directive-table
|
|
(list* (list '#:description check-expression)
|
|
(list '#:transparent)
|
|
(list '#:opaque)
|
|
(list '#:attributes check-attr-arity-list)
|
|
(list '#:auto-nested-attributes)
|
|
(list '#:commit)
|
|
(list '#:no-delimit-cut)
|
|
common-parse-directive-table))
|
|
|
|
;; pattern-directive-table
|
|
(define pattern-directive-table
|
|
(list (list '#:declare check-identifier check-expression)
|
|
(list '#:fail-when check-expression check-expression)
|
|
(list '#:fail-unless check-expression check-expression)
|
|
(list '#:when check-expression)
|
|
(list '#:with check-expression check-expression)
|
|
(list '#:attr check-attr-arity check-expression)
|
|
(list '#:do check-stmt-list)))
|
|
|
|
;; fail-directive-table
|
|
(define fail-directive-table
|
|
(list (list '#:when check-expression)
|
|
(list '#:unless check-expression)))
|
|
|
|
;; describe-option-table
|
|
(define describe-option-table
|
|
(list (list '#:opaque)))
|
|
|
|
;; eh-optional-directive-table
|
|
(define eh-optional-directive-table
|
|
(list (list '#:too-many check-expression)
|
|
(list '#:name check-expression)
|
|
(list '#:defaults check-bind-clause-list)))
|
|
|
|
;; h-optional-directive-table
|
|
(define h-optional-directive-table
|
|
(list (list '#:defaults check-bind-clause-list)))
|
|
|
|
;; phase-directive-table
|
|
(define phase-directive-table
|
|
(list (list '#:phase check-expression)))
|
|
|
|
;; litset-directive-table
|
|
(define litset-directive-table
|
|
(cons (list '#:at (lambda (stx ctx) stx))
|
|
phase-directive-table))
|
|
|
|
;; var-pattern-directive-table
|
|
(define var-pattern-directive-table
|
|
(list (list '#:attr-name-separator check-stx-string)))
|