1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
#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)
(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 undos fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es undos fh0 cp0 rl success argu))))))))])))
|
