www

commit de60a419e243927c58cce0a27b754eb55f655adc
parent 64edde1f2de2b745dc182352c3e27adeff9ce022
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Thu, 10 Nov 2016 15:21:26 +0100

Cherry-pick PR #1514: Added a syntax-local-template-metafunction-introduce function, so that template metafunctions can be unhygienic if necessary.

Diffstat:
M
parse/experimental/private/substitute.rkt
 | 
17
+++++++++++++++--
M
parse/experimental/template.rkt
 | 
1
+
M
scribblings/stxparse-info.scrbl
 | 
16
++++++++++++++--

3 files changed, 30 insertions(+), 4 deletions(-)
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
@@ -2,7 +2,8 @@
 (require syntax/parse/private/minimatch
          racket/private/promise
          racket/private/stx) ;; syntax/stx
-(provide translate)
+(provide translate
+         syntax-local-template-metafunction-introduce)
 
 #|
 ;; Doesn't seem to make much difference.
@@ -254,7 +255,8 @@ An VarRef is one of
                [mark (make-syntax-introducer)]
                [old-mark (current-template-metafunction-introducer)]
                [mf (get index env lenv)])
-           (parameterize ((current-template-metafunction-introducer mark))
+           (parameterize ((current-template-metafunction-introducer mark)
+                          (old-template-metafunction-introducer old-mark))
              (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))])
                (unless (syntax? r)
                  (raise-syntax-error #f "result of template metafunction was not syntax" stx))
@@ -396,6 +398,17 @@ An VarRef is one of
          (syntax-local-introduce stx)
          stx))))
 
+(define old-template-metafunction-introducer
+  (make-parameter #f))
+
+(define (syntax-local-template-metafunction-introduce stx)
+  (let ([mark (current-template-metafunction-introducer)]
+        [old-mark (old-template-metafunction-introducer)])
+    (unless old-mark
+      (error 'syntax-local-template-metafunction-introduce
+             "must be called within the dynamic extent of a template metafunction"))
+    (mark (old-mark stx))))
+
 ;; ----
 
 (define (stx-cadr x) (stx-car (stx-cdr x)))
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -13,6 +13,7 @@
          quasitemplate
          quasitemplate/loc
          define-template-metafunction
+         syntax-local-template-metafunction-introduce
          ??
          ?@)
 
diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl
@@ -209,4 +209,16 @@ track which syntax or datum pattern variables are bound.
     (define-syntax (get-pvars stx)
       #`'#,(current-pvars))
     (get-pvars))
-  '(y x))]])}
-\ No newline at end of file
+  '(y x))]])}
+
+@section{Extensions to @racketmodname[syntax/parse/experimental/template]}
+
+@defmodule[stxparse-info/parse/experimental/template]
+
+@defform[(syntax-local-template-introduce stx)]{
+ Like @racket[syntax-local-introduce], but for @tech{template metafunctions}.
+
+ This change is also available in the package
+ @racketmodname{backport-template-pr1514}. It has been submitted as a Pull
+ Request to Racket, but can be used in
+ @racketmodname[stxparse-info/parse/experimental/template] right away.}
+\ No newline at end of file