diff --git a/collects/syntax/parse/experimental/specialize.rkt b/collects/syntax/parse/experimental/specialize.rkt new file mode 100644 index 0000000000..057b6225a8 --- /dev/null +++ b/collects/syntax/parse/experimental/specialize.rkt @@ -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)))))))])) diff --git a/collects/syntax/scribblings/parse/experimental.scrbl b/collects/syntax/scribblings/parse/experimental.scrbl index 770c2d65af..29ca0fed1f 100644 --- a/collects/syntax/scribblings/parse/experimental.scrbl +++ b/collects/syntax/scribblings/parse/experimental.scrbl @@ -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]) +] +} diff --git a/collects/syntax/scribblings/parse/parse-common.rkt b/collects/syntax/scribblings/parse/parse-common.rkt index 17baad6f1a..bc4c8a02be 100644 --- a/collects/syntax/scribblings/parse/parse-common.rkt +++ b/collects/syntax/scribblings/parse/parse-common.rkt @@ -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"))) diff --git a/collects/tests/stxparse/test-exp.rkt b/collects/tests/stxparse/test-exp.rkt index fda7958aca..deab549bef 100644 --- a/collects/tests/stxparse/test-exp.rkt +++ b/collects/tests/stxparse/test-exp.rkt @@ -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)])))