From 3995a4ab59c8f14e180d08bccf023a6dbd2823d2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Thu, 10 Nov 2016 15:21:26 +0100
Subject: [PATCH] Added a syntax-local-template-metafunction-introduce
function, so that template metafunctions can be unhygienic if necessary.
---
.../syntax/scribblings/parse/experimental.scrbl | 3 +++
.../syntax/parse/experimental/template.rkt | 17 +++++++++++++++--
2 files changed, 18 insertions(+), 2 deletions(-)
diff --git a/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
index 9affdcffeb..09a562f5b5 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
@@ -345,4 +345,7 @@ the context above; instead, @racket[let-values] would report an
invalid binding list.
}
+@defform[(syntax-local-template-introduce stx)]{
+ Like @racket[syntax-local-introduce], but for @tech{template metafunctions}.}
+
@(close-eval the-eval)
diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt
index b52fd80e6e..cd062c6783 100644
--- a/racket/collects/syntax/parse/experimental/template.rkt
+++ b/racket/collects/syntax/parse/experimental/template.rkt
@@ -8,7 +8,8 @@
[quasisyntax/loc quasitemplate/loc]
[~? ??]
[~@ ?@])
- define-template-metafunction)
+ define-template-metafunction
+ syntax-local-template-metafunction-introduce)
;; ============================================================
;; Metafunctions
@@ -26,11 +27,23 @@
(define current-template-metafunction-introducer
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
+(define old-template-metafunction-introducer
+ (make-parameter #f))
+
(define ((make-hygienic-metafunction transformer) stx)
(define mark (make-syntax-introducer))
(define old-mark (current-template-metafunction-introducer))
- (parameterize ((current-template-metafunction-introducer mark))
+ (parameterize ((current-template-metafunction-introducer mark)
+ (old-template-metafunction-introducer old-mark))
(define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
(unless (syntax? r)
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
(old-mark (mark r))))
+
+(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))))