template.rkt (2055B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 auto-syntax-e/utils) 4 (only-in racket/private/template 5 metafunction)) 6 (provide (rename-out [syntax template] 7 [syntax/loc template/loc] 8 [quasisyntax quasitemplate] 9 [quasisyntax/loc quasitemplate/loc] 10 [~? ??] 11 [~@ ?@]) 12 define-template-metafunction) 13 14 ;; ============================================================ 15 ;; Metafunctions 16 17 (define-syntax (define-template-metafunction stx) 18 (syntax-case stx () 19 [(dsm (id arg ...) . body) 20 #'(dsm id (lambda (arg ...) . body))] 21 [(dsm id expr) 22 (identifier? #'id) 23 (with-syntax ([(internal-id) (generate-temporaries #'(id))]) 24 #'(begin (define internal-id (make-hygienic-metafunction expr)) 25 (define-syntax id (metafunction (quote-syntax internal-id)))))])) 26 27 (define current-template-metafunction-introducer 28 (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) 29 30 (define old-template-metafunction-introducer 31 (make-parameter #f)) 32 33 (define (syntax-local-template-metafunction-introduce stx) 34 (let ([mark (current-template-metafunction-introducer)] 35 [old-mark (old-template-metafunction-introducer)]) 36 (unless old-mark 37 (error 'syntax-local-template-metafunction-introduce 38 "must be called within the dynamic extent of a template metafunction")) 39 (mark (old-mark stx)))) 40 41 (define ((make-hygienic-metafunction transformer) stx) 42 (define mark (make-syntax-introducer)) 43 (define old-mark (current-template-metafunction-introducer)) 44 (parameterize ((current-template-metafunction-introducer mark) 45 (old-template-metafunction-introducer old-mark)) 46 (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx)))))) 47 (unless (syntax? r) 48 (raise-syntax-error #f "result of template metafunction was not syntax" stx)) 49 (old-mark (mark r))))