specialize.rkt (1998B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 racket/syntax 4 syntax/parse/private/kws 5 syntax/parse/private/rep-data 6 "../private/rep.rkt") 7 "../private/runtime.rkt") 8 (provide define-syntax-class/specialize) 9 10 (define-syntax (define-syntax-class/specialize stx) 11 (parameterize ((current-syntax-context stx)) 12 (syntax-case stx () 13 [(dscs header sc-expr) 14 (with-disappeared-uses 15 (let-values ([(name formals arity) 16 (let ([p (check-stxclass-header #'header stx)]) 17 (values (car p) (cadr p) (caddr p)))] 18 [(target-scname argu) 19 (let ([p (check-stxclass-application #'sc-expr stx)]) 20 (values (car p) (cdr p)))]) 21 (let* ([pos-count (length (arguments-pargs argu))] 22 [kws (arguments-kws argu)] 23 [target (get-stxclass/check-arity target-scname target-scname pos-count kws)]) 24 (with-syntax ([name name] 25 [formals formals] 26 [parser (generate-temporary (format-symbol "parser-~a" #'name))] 27 [splicing? (stxclass-splicing? target)] 28 [arity arity] 29 [attrs (stxclass-attrs target)] 30 [opts (stxclass-opts target)] 31 [target-parser (stxclass-parser target)] 32 [argu argu]) 33 #`(begin (define-syntax name 34 (stxclass 'name 'arity 'attrs 35 (quote-syntax parser) 36 'splicing? 37 'opts #f)) 38 (define-values (parser) 39 (lambda (x cx pr es fh0 cp0 rl success . formals) 40 (app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))