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

syntax/parse: added define-syntax-class/specialize

Browse Source
This commit is contained in:
Ryan Culpepper 2011-05-02 20:46:13 -06:00
parent 0a048b67bb
commit e5e12ab01a
4 changed files with 88 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/syntax/parse/experimental/specialize.rkt Normal file
View File

@ -0,0 +1,39 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
"../private/kws.rkt"
"../private/rep-data.rkt"
"../private/rep.rkt")
"../private/runtime.rkt")
(provide define-syntax-class/specialize)
(define-syntax (define-syntax-class/specialize stx)
(syntax-case stx ()
[(dscs header sc-expr)
(let-values ([(name formals arity)
(let ([p (check-stxclass-header #'header stx)])
(values (car p) (cadr p) (caddr p)))]
[(target-scname argu)
(let ([p (check-stxclass-application #'sc-expr stx)])
(values (car p) (cdr p)))])
(let* ([pos-count (length (arguments-pargs argu))]
[kws (arguments-kws argu)]
[target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
(with-syntax ([name name]
[formals formals]
[parser (generate-temporary (format-symbol "parser-~a" #'name))]
[splicing? (stxclass-splicing? target)]
[arity arity]
[attrs (stxclass-attrs target)]
[options (stxclass-options target)]
[target-parser (stxclass-parser target)]
[argu argu])
#`(begin (define-syntax name
(stxclass 'name 'arity 'attrs
(quote-syntax parser)
'splicing?
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)))))))]))

24
collects/syntax/scribblings/parse/experimental.scrbl
View File

@ -255,3 +255,27 @@ their attributes with @scheme[name].
[(_ (~eh-var x ext-options) ...)
#'(x.s.a (x.s.b ...) ((x.c1 x.c2) ...))])
]
@section{Syntax class specialization}
@defmodule[syntax/parse/experimental/specialize]
@defform/subs[(define-syntax-class/specialize header syntax-class-use)
([header id
(id . kw-formals)]
[syntax-class-use target-stxclass-id
(target-stxclass-id arg ...)])]{
Defines @racket[id] as a syntax class with the same attributes,
options (eg, @racket[#:commit], @racket[#:no-delimit-cut]), and
patterns as @racket[target-stxclass-id] but with the given
@racket[arg]s supplied.
@examples[#:eval the-eval
(define-syntax-class/specialize nat>10 (nat> 10))
(syntax-parse #'(11 12) [(n:nat>10 ...) 'ok])
(syntax-parse #'(8 9) [(n:nat>10 ...) 'ok])
]
}

3
collects/syntax/scribblings/parse/parse-common.rkt
View File

@ -34,6 +34,7 @@
syntax/parse/experimental/splicing
syntax/parse/experimental/contract
syntax/parse/experimental/reflect
syntax/parse/experimental/specialize
syntax/parse/experimental/eh)])
`((for-syntax racket/base ,@mods)
,@mods)))))
@ -102,6 +103,7 @@
syntax/parse/experimental/splicing
syntax/parse/experimental/reflect
syntax/parse/experimental/provide
syntax/parse/experimental/specialize
syntax/parse/experimental/eh
"parse-dummy-bindings.rkt"))
(provide (for-label (all-from-out racket/base)
@ -112,5 +114,6 @@
(all-from-out syntax/parse/experimental/splicing)
(all-from-out syntax/parse/experimental/reflect)
(all-from-out syntax/parse/experimental/provide)
(all-from-out syntax/parse/experimental/specialize)
(all-from-out syntax/parse/experimental/eh)
(all-from-out "parse-dummy-bindings.rkt")))

22
collects/tests/stxparse/test-exp.rkt
View File

@ -5,6 +5,7 @@
syntax/parse/experimental/reflect
syntax/parse/experimental/splicing
syntax/parse/experimental/eh
syntax/parse/experimental/specialize
"setup.rkt"
(for-syntax syntax/parse))
@ -77,3 +78,24 @@
(terx (1) (f:foo)
#rx"expected foo")
;; Specialization
(define-syntax-class/specialize nat>10 (nat> 10))
(tok (11 23 45) (n:nat>10 ...))
(terx (11 10 9) (n:nat>10 ...)
#rx"expected natural number greater than 10")
(tcerr "specialize preserves #:no-delimit-cut"
(let ()
(define-syntax-class a #:no-delimit-cut (pattern _))
(define-syntax-class/specialize b a)
(syntax-parse #'12 [(~not x:b) (void)]))
#rx"syntax class with #:no-delimit-cut option not allowed within ~not pattern")
(test-case "specialize preserves lack of #:no-delimit-cut"
(let ()
(define-syntax-class a (pattern _:id))
(define-syntax-class/specialize b a)
(syntax-parse #'12 [(~not x:b) (void)])))