suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: added roles, other updates/fixes

Browse Source 
expr/c uses role for contract label when avail
export ~peek-not (previously missed)
fixes for integrable stxclasses
This commit is contained in:
Ryan Culpepper 2012-02-29 05:52:48 -07:00
parent a0065b9efa
commit fb7c7e3793
19 changed files with 315 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/syntax/parse/debug.rkt
View File

@ -39,7 +39,7 @@
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (fs) fs)])
(app-argu parser x x (ps-empty x x) null fh fh
(app-argu parser x x (ps-empty x x) null fh fh #f
(lambda (fh . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu)))))]))

11
collects/syntax/parse/experimental/contract.rkt
View File

@ -4,14 +4,17 @@
"provide.rkt"
unstable/wrapc
(only-in syntax/parse/private/residual ;; keep abs. path
this-context-syntax)
this-context-syntax
this-role)
racket/contract/base)
(define not-given (gensym))
(define-syntax-class (expr/c ctc-stx
#:positive [pos-blame 'use-site]
#:negative [neg-blame 'from-macro]
#:macro [macro-name #f]
#:name [expr-name #f]
#:name [expr-name not-given]
#:context [ctx #f])
#:attributes (c)
(pattern y:expr
@ -20,7 +23,9 @@
#'y
#:positive pos-blame
#:negative neg-blame
#:name expr-name
#:name (if (eq? expr-name not-given)
this-role
expr-name)
#:macro macro-name
#:context (or ctx (this-context-syntax)))))

2
collects/syntax/parse/experimental/provide.rkt
View File

@ -85,7 +85,7 @@
[opc-id opc] ...
[okwc-id okwc] ...)
(rename-contract
(->* (any/c any/c any/c any/c any/c any/c any/c
(->* (any/c any/c any/c any/c any/c any/c any/c any/c
mpc-id ... mkw-c-part ... ...)
(okw-c-part ... ...)
any)

4
collects/syntax/parse/experimental/specialize.rkt
View File

@ -35,5 +35,5 @@
options
#f))
(define-values (parser)
(lambda (x cx pr es fh0 cp0 success . formals)
(app-argu target-parser x cx pr es fh0 cp0 success argu)))))))]))
(lambda (x cx pr es fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu)))))))]))

4
collects/syntax/parse/experimental/splicing.rkt
View File

@ -34,7 +34,7 @@
description)
(define parser
(let ([permute (mk-permute '(a.name ...))])
(lambda (x cx pr es fh _cp success param ...)
(lambda (x cx pr es fh _cp rl success param ...)
(let ([stx (datum->syntax cx x cx)])
(let ([result
(let/ec escape
@ -50,7 +50,7 @@
((error)
(let ([es
(list* (expect:message (cadr result))
(expect:thing (get-description param ...) #f)
(expect:thing (get-description param ...) #f rl)
es)])
(fh (failure pr es))))))))))
(define-syntax name

1
collects/syntax/parse/private/keywords.rkt
View File

@ -37,3 +37,4 @@
(define-keyword ~post)
(define-keyword ~eh-var)
(define-keyword ~peek)
(define-keyword ~peek-not)

97
collects/syntax/parse/private/parse.rkt
View File

@ -73,10 +73,10 @@
#f
'#s(options #t #t)
(integrate (quote-syntax predicate) 'description)))
(define (parser x cx pr es fh0 cp0 success)
(define (parser x cx pr es fh0 cp0 rl success)
(if (predicate x)
(success fh0)
(let ([es (cons (expect:thing 'description #t) es)])
(let ([es (cons (expect:thing 'description #t rl) es)])
(fh0 (failure pr es)))))))]))
(define-syntax (parser/rhs stx)
@ -163,39 +163,43 @@
;; ============================================================
#|
Parsing protocol:
Parsing protocols:
(parse:* <*> * progress-var expectstack-var success-expr) : Ans
(parse:<X> <X-args> pr es success-expr) : Ans
*-stxclass-parser
: stxish stx progress expectstack fail-handler cut-prompt success-proc arg ... -> Ans
<S-args> : x cx
<H-args> : x cx rest-x rest-cx rest-pr
<EH-args> : x cx ???
<A-args> : x cx
<S> : x cx
<H> : x cx rest-x rest-cx rest-pr
<EH> : x cx ???
<A> : x cx
x is term to parse, usually syntax but can be pair/null (stx-list?) in cdr patterns
cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src
pr, es are progress and expectstack, respectively
rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr
x is term to parse, usually syntax but can be pair, empty in cdr patterns
cx is most recent syntax object:
if x must be coerced to syntax, use cx as lexctx and src
(stxclass-parser x cx pr es fail-handler cut-prompt role success-proc arg ...) : Ans
success-proc : fail-handler <???> attr-value ... -> Ans
success-proc:
for stxclass, is (fail-handler attr-value ... -> Ans)
for splicing-stxclass, is (fail-handler rest-x rest-cx rest-pr attr-value -> Ans)
fail-handler, cut-prompt : failure -> Ans
Usually sub-patterns processed in tail position,
but *can* do non-tail calls for:
Fail-handler is normally represented with stxparam 'fail-handler', but must be
threaded through stxclass calls (in through stxclass-parser, out through
success-proc) to support backtracking. Cut-prompt is never changed within
stxclass or within alternative, so no threading needed.
Usually sub-patterns processed in tail position, but *can* do non-tail calls for:
- ~commit
- var of stxclass with ~commit
(Also safe to keep normal tail-call protocol.)
It is also safe to keep normal tail-call protocol and just adjust fail-handler.
There is no real benefit to specializing ~commit, since it does not involve
creating a success closure.
|#
#|
Optimizations
Some optimizations:
- commit protocol for stxclasses (but not ~commit, no point)
- avoid choice point in (EH ... . ()) by eager pair check
- integrable stxclasses (identifier, keyword, expr)
- avoid continue-vs-end choice point in (EH ... . ()) by eager pair check
- integrable stxclasses, specialize ellipses of integrable stxclasses
|#
;; ----
@ -237,7 +241,7 @@ Conventions:
- success : var (bound to success procedure)
- k : expr
- rest-x, rest-cx, rest-pr : id (to be bound)
- fh, cp : id (var)
- fh, cp, rl : id (var)
|#
;; (parse:rhs rhs relsattrs (arg:id ...) get-description:id splicing?)
@ -248,14 +252,15 @@ Conventions:
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...)
#s(options commit? delimit-cut?) _integrate)
relsattrs formals splicing? description)
#'(lambda (x cx pr es fh0 cp0 success . formals)
#'(lambda (x cx pr es fh0 cp0 rl success . formals)
def ...
(#%expression
(with ([this-syntax x])
(with ([this-syntax x]
[this-role rl])
(syntax-parameterize ((this-context-syntax
(syntax-rules ()
[(tbs) (ps-context-syntax pr)])))
(let ([es (cons (expect:thing description 'transparent?) es)]
(let ([es (cons (expect:thing description 'transparent? rl) es)]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(with ([fail-handler fh0]
[cut-prompt cp0])
@ -416,10 +421,10 @@ Conventions:
k)]
[#s(pat:any _attrs)
#'k]
[#s(pat:var _attrs name #f _ () _ _)
[#s(pat:var _attrs name #f _ () _ _ _)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)]
[#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit?)
[#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit? role)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
@ -427,7 +432,7 @@ Conventions:
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
#'(app-argu parser x cx pr es fail-handler cut-prompt
#'(app-argu parser x cx pr es fail-handler cut-prompt role
(lambda (fh av ...)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
@ -439,7 +444,7 @@ Conventions:
#'(let-values ([(fs av ...)
(with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(app-argu parser x cx pr es fail-handler cut-prompt role
(lambda (fh av ...) (values #f av ...))
argu)))])
(if fs
@ -454,7 +459,7 @@ Conventions:
#'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)])
(app-argu parser x cx pr es fail-handler cut-prompt
(app-argu parser x cx pr es fail-handler cut-prompt #f
(lambda (fh . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
@ -543,8 +548,8 @@ Conventions:
[pr (ps-add-unpstruct pr)])
(parse:S datum scx subpattern pr es k))
(fail (failure pr es))))]
[#s(pat:describe attrs description transparent? pattern)
#`(let ([es (cons (expect:thing description transparent?) es)]
[#s(pat:describe attrs pattern description transparent? role)
#`(let ([es (cons (expect:thing description transparent? role) es)]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(parse:S x cx pattern pr es k))]
[#s(pat:delimit attrs pattern)
@ -562,7 +567,7 @@ Conventions:
[#s(pat:post attrs pattern)
#`(let ([pr (ps-add-post pr)])
(parse:S x cx pattern pr es k))]
[#s(pat:integrated _attrs name predicate description)
[#s(pat:integrated _attrs name predicate description role)
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) x*])
@ -570,7 +575,7 @@ Conventions:
#'(let ([x* (datum->syntax cx x cx)])
(if (predicate x*)
(let-attributes (name-attr ...) k)
(let ([es (cons (expect:thing 'description #t) es)])
(let ([es (cons (expect:thing 'description #t role) es)])
(fail (failure pr es))))))])]))
;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans]
@ -663,13 +668,13 @@ Conventions:
(syntax-case stx ()
[(parse:H x cx rest-x rest-cx rest-pr head pr es k)
(syntax-case #'head ()
[#s(hpat:describe _ description transparent? pattern)
#`(let ([es* (cons (expect:thing description transparent?) es)]
[#s(hpat:describe _ pattern description transparent? role)
#`(let ([es* (cons (expect:thing description transparent? role) es)]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es*
(let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
k)))]
[#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit?)
[#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit? role)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
@ -678,7 +683,7 @@ Conventions:
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
#`(app-argu parser x cx pr es fail-handler cut-prompt
#`(app-argu parser x cx pr es fail-handler cut-prompt role
(lambda (fh rest-x rest-cx rest-pr av ...)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
@ -690,7 +695,7 @@ Conventions:
#'(let-values ([(fs rest-x rest-cx rest-pr av ...)
(with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(app-argu parser x cx pr es fail-handler cut-prompt role
(lambda (fh rest-x rest-cx rest-pr av ...)
(values #f rest-x rest-cx rest-pr av ...))
argu)))])
@ -707,7 +712,7 @@ Conventions:
#'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)])
(app-argu parser x cx pr es fail-handler cut-prompt
(app-argu parser x cx pr es fail-handler cut-prompt #f
(lambda (fh rest-x rest-cx rest-pr . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
@ -803,19 +808,19 @@ Conventions:
;; == Specialized cases
;; -- (x ... . ())
[(parse:dots x cx (#s(ehpat (attr0)
#s(pat:var _attrs name #f _ () _ _)
#s(pat:var _attrs name #f _ () _ _ _)
#f))
#s(pat:datum () ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f)])
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)])
(case status
((ok) (let-attributes ([attr0 result]) k))
(else (fail result))))]
;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
[(parse:dots x cx (#s(ehpat (attr0)
#s(pat:integrated _attrs _name pred? desc)
#s(pat:integrated _attrs _name pred? desc role)
#f))
#s(pat:datum () ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc)])
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)])
(case status
((ok) (let-attributes ([attr0 result]) k))
(else (fail result))))]

23
collects/syntax/parse/private/rep-data.rkt
View File

@ -72,12 +72,23 @@ DeclEnv =
DeclEntry =
(den:lit id id ct-phase ct-phase)
(den:class id id Arguments)
(den:magic-class id id Arguments)
(den:magic-class id id Arguments stx)
(den:parser id (listof SAttr) bool bool bool)
(den:delayed id id)
Arguments is defined in rep-patterns.rkt
A DeclEnv is built up in stages:
1) syntax-parse (or define-syntax-class) directives
#:literals -> den:lit
#:local-conventions -> den:class
#:conventions -> den:delayed
#:literal-sets -> den:lit
2) pattern directives
#:declare -> den:magic-class
3) create-aux-def creates aux parser defs
den:class -> den:parser or den:delayed
== Scoping ==
A #:declare directive results in a den:magic-class entry, which
@ -91,7 +102,7 @@ expressions are duplicated, and may be evaluated in different scopes.
(define-struct den:lit (internal external input-phase lit-phase))
(define-struct den:class (name class argu))
(define-struct den:magic-class (name class argu))
(define-struct den:magic-class (name class argu role))
(define-struct den:parser (parser attrs splicing? commit? delimit-cut?))
;; and from residual.rkt: (define-struct den:delayed (parser class))
@ -117,7 +128,7 @@ expressions are duplicated, and may be evaluated in different scopes.
(match val
[(struct den:lit (_i _e _ip _lp))
(wrong-syntax id "identifier previously declared as literal")]
[(struct den:magic-class (name _c _a))
[(struct den:magic-class (name _c _a _r))
(if (and blame-declare? stxclass-name)
(wrong-syntax name
"identifier previously declared with syntax class ~a"
@ -135,11 +146,11 @@ expressions are duplicated, and may be evaluated in different scopes.
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
(define (declenv-put-stxclass env id stxclass-name argu)
(define (declenv-put-stxclass env id stxclass-name argu [role #f])
(declenv-check-unbound env id)
(make-declenv
(bound-id-table-set (declenv-table env) id
(make den:magic-class id stxclass-name argu))
(make den:magic-class id stxclass-name argu role))
(declenv-conventions env)))
;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
@ -212,7 +223,7 @@ expressions are duplicated, and may be evaluated in different scopes.
[declenv-lookup
(-> DeclEnv/c identifier? any)]
[declenv-put-stxclass
(-> DeclEnv/c identifier? identifier? arguments?
(-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f)
DeclEnv/c)]
[declenv-domain-difference
(-> DeclEnv/c (listof identifier?)

40
collects/syntax/parse/private/rep-patterns.rkt
View File

@ -22,7 +22,7 @@ A Base is (listof IAttr)
#|
A SinglePattern is one of
(pat:any Base)
(pat:var Base id id Arguments (listof IAttr) nat/#f bool)
(pat:var Base id id Arguments (listof IAttr) nat/#f bool stx)
(pat:literal Base identifier ct-phase ct-phase)
(pat:datum Base datum)
(pat:action Base ActionPattern SinglePattern)
@ -35,12 +35,12 @@ A SinglePattern is one of
(pat:vector Base SinglePattern)
(pat:box Base SinglePattern)
(pat:pstruct Base key SinglePattern)
(pat:describe Base stx boolean SinglePattern)
(pat:describe Base SinglePattern stx boolean stx)
(pat:delimit Base SinglePattern)
(pat:commit Base SinglePattern)
(pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
(pat:post Base SinglePattern)
(pat:integrated Base id/#f id string)
(pat:integrated Base id/#f id string stx)
A ListPattern is a subtype of SinglePattern; one of
(pat:datum Base '())
@ -51,7 +51,7 @@ A ListPattern is a subtype of SinglePattern; one of
|#
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:action (attrs action inner) #:prefab)
@ -64,12 +64,12 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:vector (attrs pattern) #:prefab)
(define-struct pat:box (attrs pattern) #:prefab)
(define-struct pat:pstruct (attrs key pattern) #:prefab)
(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
(define-struct pat:describe (attrs pattern description transparent? role) #:prefab)
(define-struct pat:delimit (attrs pattern) #:prefab)
(define-struct pat:commit (attrs pattern) #:prefab)
(define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
(define-struct pat:post (attrs pattern) #:prefab)
(define-struct pat:integrated (attrs name predicate description) #:prefab)
(define-struct pat:integrated (attrs name predicate description role) #:prefab)
#|
A ActionPattern is one of
@ -94,13 +94,13 @@ action:and is desugared below in create-* procedures
#|
A HeadPattern is one of
(hpat:var Base id id Arguments (listof IAttr) nat/#f bool)
(hpat:var Base id id Arguments (listof IAttr) nat/#f bool stx)
(hpat:seq Base ListPattern)
(hpat:action Base ActionPattern HeadPattern)
(hpat:and Base HeadPattern SinglePattern)
(hpat:or Base (listof HeadPattern))
(hpat:optional Base HeadPattern (listof clause:attr))
(hpat:describe Base stx/#f boolean HeadPattern)
(hpat:describe Base HeadPattern stx/#f boolean stx)
(hpat:delimit Base HeadPattern)
(hpat:commit Base HeadPattern)
(hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
@ -109,13 +109,13 @@ A HeadPattern is one of
(hpat:peek-not Base HeadPattern)
|#
(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:action (attrs action inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab)
(define-struct hpat:optional (attrs inner defaults) #:prefab)
(define-struct hpat:describe (attrs description transparent? pattern) #:prefab)
(define-struct hpat:describe (attrs pattern description transparent? role) #:prefab)
(define-struct hpat:delimit (attrs pattern) #:prefab)
(define-struct hpat:commit (attrs pattern) #:prefab)
(define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
@ -239,10 +239,10 @@ A SideClause is one of
(define (create-pat:any)
(make pat:any null))
(define (create-pat:var name parser argu nested-attrs attr-count commit?)
(define (create-pat:var name parser argu nested-attrs attr-count commit? role)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser argu nested-attrs attr-count commit?)))
(make pat:var attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-pat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
@ -279,8 +279,8 @@ A SideClause is one of
(define (create-pat:pstruct key pattern)
(make pat:pstruct (pattern-attrs pattern) key pattern))
(define (create-pat:describe description transparent? p)
(make pat:describe (pattern-attrs p) description transparent? p))
(define (create-pat:describe p description transparent? role)
(make pat:describe (pattern-attrs p) p description transparent? role))
(define (create-pat:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
@ -306,9 +306,9 @@ A SideClause is one of
(define (create-pat:post pattern)
(make pat:post (pattern-attrs pattern) pattern))
(define (create-pat:integrated name predicate description)
(define (create-pat:integrated name predicate description role)
(let ([attrs (if name (list (make attr name 0 #t)) null)])
(make pat:integrated attrs name predicate description)))
(make pat:integrated attrs name predicate description role)))
;; ----
@ -336,10 +336,10 @@ A SideClause is one of
;; ----
(define (create-hpat:var name parser argu nested-attrs attr-count commit?)
(define (create-hpat:var name parser argu nested-attrs attr-count commit? role)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser argu nested-attrs attr-count commit?)))
(make hpat:var attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-hpat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
@ -357,8 +357,8 @@ A SideClause is one of
(let ([attrs (append-iattrs (map pattern-attrs (list g hp)))])
(make hpat:action attrs g hp))]))
(define (create-hpat:describe description transparent? p)
(make hpat:describe (pattern-attrs p) description transparent? p))
(define (create-hpat:describe p description transparent? role)
(make hpat:describe (pattern-attrs p) p description transparent? role))
(define (create-hpat:and hp sp)
(make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp))

162
collects/syntax/parse/private/rep.rkt
View File

@ -260,7 +260,7 @@
(match entry
[(struct den:lit (_i _e _ip _lp))
(values entry null)]
[(struct den:magic-class (name class argu))
[(struct den:magic-class (name class argu role))
(values entry null)]
[(struct den:class (name class argu))
;; FIXME: integrable syntax classes?
@ -555,7 +555,7 @@
(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)
(create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(eh-alternative-repc alt))
(replace-eh-alternative-attrs
alt (iattrs->sattrs iattrs))))))]
@ -609,59 +609,33 @@
(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))
[(struct den:magic-class (name class argu role))
(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?)))]
[sc (get-stxclass/check-arity class class pos-count kws)])
(parse-pat:var* id allow-head? id sc argu "." role #f))]
[(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?)))]
(check-no-delimit-cut-in-not id delimit-cut?)
(cond [splicing?
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id parser no-arguments attrs commit? "." #f)]
[else
(parse-pat:id/s id parser no-arguments attrs commit? "." #f)])]
[(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))]))]
(parse-pat:var* id allow-head? id sc no-arguments "." #f parser))]
['#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)))]))
(parse-pat:var* id allow-head? name sc no-arguments "." #f #f)
(create-pat:var name #f no-arguments null #f #t #f)))]))
(define (parse-pat:var stx decls allow-head?)
(define name0
@ -672,10 +646,10 @@
#'name]
[_
(wrong-syntax stx "bad ~~var form")]))
(define-values (scname sc+args-stx argu pfx)
(define-values (scname sc+args-stx argu pfx role)
(syntax-case stx (~var)
[(~var _name)
(values #f #f null #f)]
(values #f #f null #f #f)]
[(~var _name sc/sc+args . rest)
(let-values ([(sc argu)
(let ([p (check-stxclass-application #'sc/sc+args stx)])
@ -686,7 +660,8 @@
#:context stx))
(define sep
(options-select-value chunks '#:attr-name-separator #:default #f))
(values sc #'sc/sc+args argu (if sep (syntax-e sep) ".")))]
(define role (options-select-value chunks '#:role #:default #'#f))
(values sc #'sc/sc+args argu (if sep (syntax-e sep) ".") role))]
[_
(wrong-syntax stx "bad ~~var form")]))
(cond [(and (epsilon? name0) (not scname))
@ -697,46 +672,51 @@
(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))]
(parse-pat:var* stx allow-head? name0 sc argu pfx role #f))]
[else ;; Just proper name
(create-pat:var name0 #f (arguments null null null) null #f #t)]))
(create-pat:var name0 #f (arguments null null null) null #f #t #f)]))
(define (parse-pat:var* stx allow-head? name sc argu [pfx "."])
(define (parse-pat:var* stx allow-head? name sc argu pfx role parser*)
;; if parser* not #f, overrides sc parser
(check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
(cond [(stxclass/s? sc)
(if (and (stxclass-integrate sc) (equal? argu no-arguments))
(parse-pat:id/s/integrate name (stxclass-integrate sc))
(parse-pat:id/s name
(stxclass-parser sc)
argu
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx))]
(cond [(and (stxclass/s? sc)
(stxclass-integrate sc)
(equal? argu no-arguments))
(parse-pat:id/s/integrate name (stxclass-integrate sc) role)]
[(stxclass/s? sc)
(parse-pat:id/s name
(or parser* (stxclass-parser sc))
argu
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx
role)]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax stx "splicing syntax class not allowed here"))
(parse-pat:id/h name
(stxclass-parser sc)
(or parser* (stxclass-parser sc))
argu
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx)]))
pfx
role)]))
(define (parse-pat:id/s name parser argu attrs commit? [pfx "."])
(define (parse-pat:id/s name parser argu attrs commit? pfx role)
(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?))
(create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (parse-pat:id/s/integrate name integrate)
(define (parse-pat:id/s/integrate name integrate role)
(define bind (name->bind name))
(create-pat:integrated bind
(integrate-predicate integrate)
(integrate-description integrate)))
(let ([predicate (integrate-predicate integrate)]
[description (integrate-description integrate)])
(create-pat:integrated bind predicate description role)))
(define (parse-pat:id/h name parser argu attrs commit? [pfx "."])
(define (parse-pat:id/h name parser argu attrs commit? pfx role)
(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?))
(create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (name->prefix id pfx)
(cond [(wildcard? id) #f]
@ -810,12 +790,13 @@
#:no-duplicates? #t
#:context stx)])
(define transparent? (not (assq '#:opaque chunks)))
(define role (options-select-value chunks '#:role #:default #'#f))
(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)))]))]))
(create-hpat:describe p #'description transparent? role)
(create-pat:describe p #'description transparent? role)))]))]))
(define (parse-pat:delimit stx decls allow-head?)
(syntax-case stx ()
@ -1155,6 +1136,9 @@
[(cons (list '#:declare declare-stx _ _) rest)
(wrong-syntax declare-stx
"#:declare can only follow pattern or #:with clause")]
[(cons (list '#:role role-stx _) rest)
(wrong-syntax role-stx
"#:role can only follow immediately after #:declare clause")]
[(cons (list '#:fail-when fw-stx when-condition expr) rest)
(cons (make clause:fail when-condition expr)
(parse-pattern-sides rest decls))]
@ -1182,23 +1166,30 @@
;; 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 (add-decl stx role-stx decls)
(let ([role
(and role-stx
(syntax-case role-stx ()
[(#:role role) #'role]))])
(syntax-case stx ()
[(#:declare name sc)
(identifier? #'sc)
(add-decl* decls #'name #'sc (parse-argu null) role)]
[(#:declare name (sc expr ...))
(identifier? #'sc)
(add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)]
[(#:declare name bad-sc)
(wrong-syntax #'bad-sc
"expected syntax class name (possibly with parameters)")])))
(define (add-decl* decls id sc-name argu role)
(declenv-put-stxclass decls id sc-name argu role))
(define (loop chunks decls)
(match chunks
[(cons (cons '#:declare decl-stx)
(cons (cons '#:role role-stx) rest))
(loop rest (add-decl decl-stx role-stx decls))]
[(cons (cons '#:declare decl-stx) rest)
(loop rest (add-decl decl-stx decls))]
(loop rest (add-decl decl-stx #f decls))]
[_ (values decls chunks)]))
(loop chunks decls0))
@ -1515,6 +1506,7 @@
;; pattern-directive-table
(define pattern-directive-table
(list (list '#:declare check-identifier check-expression)
(list '#:role check-expression) ;; attached to preceding #:declare
(list '#:fail-when check-expression check-expression)
(list '#:fail-unless check-expression check-expression)
(list '#:when check-expression)
@ -1529,7 +1521,8 @@
;; describe-option-table
(define describe-option-table
(list (list '#:opaque)))
(list (list '#:opaque)
(list '#:role check-expression)))
;; eh-optional-directive-table
(define eh-optional-directive-table
@ -1552,4 +1545,5 @@
;; var-pattern-directive-table
(define var-pattern-directive-table
(list (list '#:attr-name-separator check-stx-string)))
(list (list '#:attr-name-separator check-stx-string)
(list '#:role check-expression)))

15
collects/syntax/parse/private/residual.rkt
View File

@ -48,6 +48,7 @@
(provide (all-from-out "runtime-progress.rkt")
this-syntax
this-role
this-context-syntax
attribute
attribute-binding
@ -70,6 +71,10 @@
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
(define-syntax-parameter this-role
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
;; this-context-syntax
;; Bound to (expression that extracts) context syntax (bottom frame in progress)
(define-syntax-parameter this-context-syntax
@ -198,7 +203,7 @@
(provide predicate-ellipsis-parser)
(define (predicate-ellipsis-parser x cx pr es pred? desc)
(define (predicate-ellipsis-parser x cx pr es pred? desc rl)
(let ([elems (stx->list x)])
(if (and elems (andmap pred? elems))
(values 'ok elems)
@ -210,9 +215,13 @@
(loop (cdr x) cx (add1 i))
(let* ([pr (ps-add-cdr pr i)]
[pr (ps-add-car pr)]
[es (cons (expect:thing desc #t) es)])
[es (cons (expect:thing desc #t rl) es)])
(values 'fail (failure pr es))))]
[else ;; not null, because stx->list failed
(let ([pr (ps-add-cdr pr i)]
[es (cons (expect:atom '()) es)])
#|
;; Don't extend es! That way we don't get spurious "expected ()"
;; that *should* have been cancelled out by ineffable pair failures.
[es (cons (expect:atom '()) es)]
|#)
(values 'fail (failure pr es)))])))))

4
collects/syntax/parse/private/runtime-progress.rkt
View File

@ -181,7 +181,7 @@ Interpretation: Inner PS structures are applied first.
An ExpectStack is (listof Expect)
An Expect is one of
- (make-expect:thing string boolean)
- (make-expect:thing string boolean string/#f)
* (make-expect:message string)
* (make-expect:atom atom)
* (make-expect:literal identifier)
@ -189,7 +189,7 @@ An Expect is one of
The *-marked variants can only occur at the top of the stack.
|#
(define-struct expect:thing (description transparent?) #:prefab)
(define-struct expect:thing (description transparent? role) #:prefab)
(define-struct expect:message (message) #:prefab)
(define-struct expect:atom (atom) #:prefab)
(define-struct expect:literal (literal) #:prefab)

4
collects/syntax/parse/private/runtime-reflect.rkt
View File

@ -66,8 +66,8 @@ A Reified is
[else
(loop (cdr result) indexes (add1 i))])))
(make-keyword-procedure
(lambda (kws kwargs x cx pr es fh cp success . rest)
(keyword-apply parser kws kwargs x cx pr es fh cp
(lambda (kws kwargs x cx pr es fh cp rl success . rest)
(keyword-apply parser kws kwargs x cx pr es fh cp rl
(if splicing?
(lambda (fh x cx pr . result)
(apply success fh x cx pr (take-indexes result indexes)))

18
collects/syntax/parse/private/runtime-report.rkt
View File

@ -8,6 +8,12 @@
current-failure-handler
maximal-failures)
#|
TODO: given (expect:thing D _ R) and (expect:thing D _ #f),
simplify to (expect:thing D _ #f)
thus, "expected D" rather than "expected D or D for R" (?)
|#
#|
Note: there is a cyclic dependence between residual.rkt and this module,
broken by a lazy-require of this module into residual.rkt
@ -81,6 +87,7 @@ complicated.
(report/expects (list frame-expect) frame-stx)]))])))
;; report/expects : (listof Expect) syntax -> Report
;; FIXME: partition by role first?
(define (report/expects expects frame-stx)
(report (join-sep (for/list ([expect expects])
(prose-for-expect expect))
@ -90,8 +97,10 @@ complicated.
;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
(match e
[(expect:thing description transparent?)
(format "expected ~a" description)]
[(expect:thing description transparent? role)
(if role
(format "expected ~a for ~a" description role)
(format "expected ~a" description))]
[(expect:atom atom)
(format "expected the literal ~a~s~a"
(if (symbol? atom) "symbol `" "")
@ -157,10 +166,11 @@ complicated.
(let loop ([es es])
(match es
['() '()]
[(cons (expect:thing description '#f) rest-es)
[(cons (expect:thing description '#f role) rest-es)
;; Tricky! If multiple opaque frames, multiple "returns",
;; but innermost one called first, so jumps past the rest.
(return (cons (car es) (loop rest-es)))]
;; Also, flip opaque to transparent for sake of equality.
(return (cons (expect:thing description #t role) (loop rest-es)))]
[(cons expect rest-es)
(cons expect (loop rest-es))]))))

4
collects/syntax/parse/private/runtime.rkt
View File

@ -211,8 +211,8 @@ residual.rkt.
(length (syntax->list #'(parg ...)))
(syntax->datum #'(kw ...)))])
(with-syntax ([parser (stxclass-parser sc)])
#'(lambda (x cx pr es fh cp success)
(app-argu parser x cx pr es fh cp success argu)))))]))
#'(lambda (x cx pr es fh cp rl success)
(app-argu parser x cx pr es fh cp rl success argu)))))]))
(define-syntax (app-argu stx)
(syntax-case stx ()

4
collects/syntax/scribblings/parse/litconv.scrbl
View File

@ -120,9 +120,9 @@ the @racket[_phase] argument defaults to
Defines @deftech{conventions} that supply default syntax classes for
pattern variables. A pattern variable that has no explicit syntax
class is checked against each @racket[id-pattern], and the first one
class is checked against each @racket[name-pattern], and the first one
that matches determines the syntax class for the pattern. If no
@racket[id-pattern] matches, then the pattern variable has no syntax
@racket[name-pattern] matches, then the pattern variable has no syntax
class.
@myexamples[

78
collects/syntax/scribblings/parse/patterns.scrbl
View File

@ -38,8 +38,8 @@ means specifically @tech{@Spattern}.
pvar-id:syntax-class-id
literal-id
(@#,ref[~var s-] id)
(@#,ref[~var s+] id syntax-class-id)
(@#,ref[~var s+] id (syntax-class-id arg ...))
(@#,ref[~var s+] id syntax-class-id maybe-role)
(@#,ref[~var s+] id (syntax-class-id arg ...) maybe-role)
(~literal literal-id)
atomic-datum
(~datum datum)
@ -54,7 +54,7 @@ means specifically @tech{@Spattern}.
#s(prefab-struct-key (unsyntax @svar[pattern-part]) ...)
#&@#,svar[S-pattern]
(~rest S-pattern)
(@#,ref[~describe s] maybe-opaque expr S-pattern)
(@#,ref[~describe s] maybe-opaque maybe-role expr S-pattern)
(@#,ref[~commit s] S-pattern)
(@#,ref[~delimit-cut s] S-pattern)
A-pattern]
@ -67,13 +67,14 @@ means specifically @tech{@Spattern}.
(~rest L-pattern)]
[H-pattern
pvar-id:splicing-syntax-class-id
(@#,ref[~var h] id splicing-syntax-class-id)
(@#,ref[~var h] id (splicing-syntax-class-id arg ...))
(@#,ref[~var h] id splicing-syntax-class-id maybe-role)
(@#,ref[~var h] id (splicing-syntax-class-id arg ...)
maybe-role)
(~seq . L-pattern)
(@#,ref[~and h] proper-H/A-pattern ...+)
(@#,ref[~or h] H-pattern ...+)
(@#,ref[~optional h] H-pattern maybe-optional-option)
(@#,ref[~describe h] maybe-opaque expr H-pattern)
(@#,ref[~describe h] maybe-opaque maybe-role expr H-pattern)
(@#,ref[~commit h] H-pattern)
(@#,ref[~delimit-cut h] H-pattern)
(~peek H-pattern)
@ -255,9 +256,12 @@ like an @tech{annotated pattern variable} with the implicit syntax
class inserted.
}
@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class-use)
@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class-use maybe-role)
([syntax-class-use syntax-class-id
(syntax-class-id arg ...)])]{
(syntax-class-id arg ...)]
[maybe-role (code:line)
(code:line #:role role-expr)])
#:contracts ([role-expr (or/c string? #f)])]{
An @deftech{annotated pattern variable}. The pattern matches only
terms accepted by @svar[syntax-class-id] (parameterized by the
@ -271,6 +275,9 @@ character) to the name of the syntax class's attribute.
If @svar[pvar-id] is @racket[_], no attributes are bound.
If @racket[role-expr] is given and evaluates to a string, it is
combined with the syntax class's description in error messages.
@myexamples[
(syntax-parse #'a
[(~var var id) (syntax-e #'var)])
@ -286,6 +293,8 @@ If @svar[pvar-id] is @racket[_], no attributes are bound.
(syntax-parse #'(1 2 3 4 5)
[((~var small (nat-less-than 4)) ... large:nat ...)
(list #'(small ...) #'(large ...))])
(syntax-parse #'(m a b 3)
[(_ (~var x id #:role "variable") ...) 'ok])
]
}
@ -537,15 +546,35 @@ above).
@specsubform/subs[(@#,def[~describe s] maybe-opaque expr S-pattern)
([maybe-opaque (code:line)
(code:line #:opaque)])
#:contracts ([expr (or/c string? #f)])]{
(code:line #:opaque)]
[maybe-role (code:line)
(code:line #:role role-expr)])
#:contracts ([expr (or/c string? #f)]
[role-expr (or/c string? #f)])]{
The @racket[~describe] pattern form annotates a pattern with a
description, a string expression that is evaluated in the scope of all
prior attribute bindings. If parsing the inner pattern fails, then the
description is used to synthesize the error message.
description is used to synthesize the error message. A
@racket[~describe] pattern does not influence backtracking.
A @racket[~describe] pattern has no effect on backtracking.
If @racket[#:opaque] is given, failure information from within
@racket[S-pattern] is discarded and the error is reported solely in
terms of the description given.
If @racket[role-expr] is given and produces a string, its value is
combined with the description in error messages.
@myexamples[
(syntax-parse #'(m 1)
[(_ (~describe "id pair" (x:id y:id))) 'ok])
(syntax-parse #'(m (a 2))
[(_ (~describe "id pair" (x:id y:id))) 'ok])
(syntax-parse #'(m (a 2))
[(_ (~describe #:opaque "id pair" (x:id y:id))) 'ok])
(syntax-parse #'(m 1)
[(_ (~describe #:role "formals" "id pair" (x y))) 'ok])
]
}
@specsubform[(@#,def[~commit s] S-pattern)]{
@ -605,9 +634,12 @@ Equivalent to @racket[(~var pvar-id splicing-syntax-class-id)].
}
@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class-use)
@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class-use maybe-role)
([splicing-syntax-class-use splicing-syntax-class-id
(splicing-syntax-class-id arg ...)])]{
(splicing-syntax-class-id arg ...)]
[maybe-role (code:line)
(code:line #:role role-expr)])
#:contracts ([role-expr (or/c string? #f)])]{
Pattern variable annotated with a @tech{splicing syntax
class}. Similar to a normal @tech{annotated pattern variable}, except
@ -754,9 +786,9 @@ outside of the @racket[~peek-not]-pattern.
(pattern (~seq x (~peek-not _))))
(syntax-parse #'(a b c)
[((~or f:final o:other) ...)
[((~or f:final other) ...)
(printf "finals are ~s\n" (syntax->datum #'(f.x ...)))
(printf "others are ~s\n" (syntax->datum #'(o ...)))])
(printf "others are ~s\n" (syntax->datum #'(other ...)))])
]
}
@ -891,13 +923,13 @@ forms based on keywords. Consider the following expression:
[(define-syntaxes (x:id ...) e) 'define-syntaxes]
[e 'expression])]
Given the ill-formed term @racket[(define-values a 123)], the
expression tries the first clause, fails to match @racket[a] against
the pattern @racket[(x:id ...)], and then backtracks to the second
clause and ultimately the third clause, producing the value
@racket['expression]. But the term is not an expression; it is an
ill-formed use of @racket[define-values]. The proper way to write the
@racket[syntax-parse] expression follows:
Given the ill-formed term @racket[(define-values a 123)],
@racket[syntax-parse] tries the first clause, fails to match
@racket[a] against the pattern @racket[(x:id ...)], and then
backtracks to the second clause and ultimately the third clause,
producing the value @racket['expression]. But the term is not an
expression; it is an ill-formed use of @racket[define-values]. The
proper way to write the @racket[syntax-parse] expression follows:
@interaction[#:eval the-eval
(syntax-parse #'(define-values a 123)

27
collects/syntax/scribblings/parse/stxclasses.scrbl
View File

@ -171,8 +171,7 @@ specifying side conditions. The grammar for pattern directives
follows:
@racketgrammar[pattern-directive
(code:line #:declare pattern-id syntax-class-id)
(code:line #:declare pattern-id (syntax-class-id arg ...))
(code:line #:declare pattern-id stxclass maybe-role)
(code:line #:with syntax-pattern expr)
(code:line #:attr attr-arity-decl expr)
(code:line #:fail-when condition-expr message-expr)
@ -180,18 +179,20 @@ follows:
(code:line #:when condition-expr)
(code:line #:do [def-or-expr ...])]
@specsubform[(code:line #:declare pvar-id syntax-class-id)]
@specsubform[(code:line #:declare pvar-id (syntax-class-id arg ...))]{
@specsubform/subs[(code:line #:declare pvar-id stxclass maybe-role)
([stxclass syntax-class-id
(syntax-class-id arg ...)]
[maybe-role (code:line)
(code:line #:role role-expr)])]{
The first form is equivalent to using the
@svar[pvar-id:syntax-class-id] form in the pattern (but it is illegal
to use both for the same pattern variable).
The second form allows the use of parameterized syntax classes, which
cannot be expressed using the ``colon'' notation. The @racket[arg]s
are evaluated outside the scope of any of the attribute bindings from
pattern that the @racket[#:declare] directive applies to. Keyword
arguments are supported, using the same syntax as in @racket[#%app].
Associates @racket[pvar-id] with a syntax class and possibly a role,
equivalent to replacing each occurrence of @racket[pvar-id] in the
pattern with @racket[(~var pvar-id stxclass maybe-role)].
The second form of @racket[stxclass] allows the use of parameterized
syntax classes, which cannot be expressed using the ``colon''
notation. The @racket[arg]s are evaluated in the scope where the
@racket[pvar-id] occurs in the pattern. Keyword arguments are
supported, using the same syntax as in @racket[#%app].
}
@specsubform[(code:line #:with syntax-pattern stx-expr)]{

31
collects/tests/stxparse/select.rkt
View File

@ -108,3 +108,34 @@
(terx (1 a 2 b)
((~or (~once x:id #:name "identifier") n:nat) ...)
#rx"too many occurrences of identifier")
;; Roles
(terx 1
(~var x id #:role "var")
#rx"expected identifier for var")
(terx 1
(~describe #:opaque #:role "R" "D" (_))
#rx"expected D for R")
(terx 1
(~describe #:role "R" "D" (_))
#rx"expected D for R")
(test-case "#:describe #:role"
(check-exn #rx"expected identifier for var"
(lambda ()
(syntax-parse #'1
[x
#:declare x id #:role "var"
'ok]))))
(test-case "role coalescing"
(check-exn #rx"^m: expected identifier for thing$" ;; not repeated
(lambda ()
(syntax-parse #'(m 0 b)
[(_ x y:nat)
#:declare x id #:role "thing"
'a]
[(_ x y:id)
#:declare x id #:role "thing"
'b]))))