syntax/parse: added define-syntax-class/specialize
This commit is contained in:
parent
0a048b67bb
commit
e5e12ab01a
39
collects/syntax/parse/experimental/specialize.rkt
Normal file
39
collects/syntax/parse/experimental/specialize.rkt
Normal 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)))))))]))
|
|
@ -255,3 +255,27 @@ their attributes with @scheme[name].
|
||||||
[(_ (~eh-var x ext-options) ...)
|
[(_ (~eh-var x ext-options) ...)
|
||||||
#'(x.s.a (x.s.b ...) ((x.c1 x.c2) ...))])
|
#'(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])
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
|
@ -34,6 +34,7 @@
|
||||||
syntax/parse/experimental/splicing
|
syntax/parse/experimental/splicing
|
||||||
syntax/parse/experimental/contract
|
syntax/parse/experimental/contract
|
||||||
syntax/parse/experimental/reflect
|
syntax/parse/experimental/reflect
|
||||||
|
syntax/parse/experimental/specialize
|
||||||
syntax/parse/experimental/eh)])
|
syntax/parse/experimental/eh)])
|
||||||
`((for-syntax racket/base ,@mods)
|
`((for-syntax racket/base ,@mods)
|
||||||
,@mods)))))
|
,@mods)))))
|
||||||
|
@ -102,6 +103,7 @@
|
||||||
syntax/parse/experimental/splicing
|
syntax/parse/experimental/splicing
|
||||||
syntax/parse/experimental/reflect
|
syntax/parse/experimental/reflect
|
||||||
syntax/parse/experimental/provide
|
syntax/parse/experimental/provide
|
||||||
|
syntax/parse/experimental/specialize
|
||||||
syntax/parse/experimental/eh
|
syntax/parse/experimental/eh
|
||||||
"parse-dummy-bindings.rkt"))
|
"parse-dummy-bindings.rkt"))
|
||||||
(provide (for-label (all-from-out racket/base)
|
(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/splicing)
|
||||||
(all-from-out syntax/parse/experimental/reflect)
|
(all-from-out syntax/parse/experimental/reflect)
|
||||||
(all-from-out syntax/parse/experimental/provide)
|
(all-from-out syntax/parse/experimental/provide)
|
||||||
|
(all-from-out syntax/parse/experimental/specialize)
|
||||||
(all-from-out syntax/parse/experimental/eh)
|
(all-from-out syntax/parse/experimental/eh)
|
||||||
(all-from-out "parse-dummy-bindings.rkt")))
|
(all-from-out "parse-dummy-bindings.rkt")))
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
syntax/parse/experimental/reflect
|
syntax/parse/experimental/reflect
|
||||||
syntax/parse/experimental/splicing
|
syntax/parse/experimental/splicing
|
||||||
syntax/parse/experimental/eh
|
syntax/parse/experimental/eh
|
||||||
|
syntax/parse/experimental/specialize
|
||||||
"setup.rkt"
|
"setup.rkt"
|
||||||
(for-syntax syntax/parse))
|
(for-syntax syntax/parse))
|
||||||
|
|
||||||
|
@ -77,3 +78,24 @@
|
||||||
|
|
||||||
(terx (1) (f:foo)
|
(terx (1) (f:foo)
|
||||||
#rx"expected 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)])))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user