www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

template.rkt (2326B)

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