41 lines
2.0 KiB
Plaintext
41 lines
2.0 KiB
Plaintext
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
racket/syntax
|
|
syntax/parse/private/kws
|
|
syntax/parse/private/rep-data
|
|
"../private/rep.rkt")
|
|
"../private/runtime.rkt")
|
|
(provide define-syntax-class/specialize)
|
|
|
|
(define-syntax (define-syntax-class/specialize stx)
|
|
(parameterize ((current-syntax-context stx))
|
|
(syntax-case stx ()
|
|
[(dscs header sc-expr)
|
|
(with-disappeared-uses
|
|
(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)]
|
|
[opts (stxclass-opts target)]
|
|
[target-parser (stxclass-parser target)]
|
|
[argu argu])
|
|
#`(begin (define-syntax name
|
|
(stxclass 'name 'arity 'attrs
|
|
(quote-syntax parser)
|
|
'splicing?
|
|
'opts #f))
|
|
(define-values (parser)
|
|
(lambda (x cx pr es fh0 cp0 rl success . formals)
|
|
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))
|