Add syntax/apply-transformer, which provides local-apply-transformer

pkgs/racket-doc/scribblings/reference/syntax-model.scrbl

@@ -578,8 +578,8 @@ a call of the @tech{syntax transformer} by the expander; see
 @secref["expand-steps"].
 
 Before the expander passes a @tech{syntax object} to a transformer,
-the @tech{syntax object} is extended with a fresh @tech{scope} (that
-applies to all sub-@tech{syntax objects}) to distinguish @tech{syntax objects}
+the @tech{syntax object} is extended with a fresh @deftech{macro-introduction scope}
+(that applies to all sub-@tech{syntax objects}) to distinguish @tech{syntax objects}
 at the macro's use site from @tech{syntax objects} that are introduced by the macro;
 in the result of the transformer the presence of the @tech{scope} is
 flipped, so that introduced @tech{syntax objects} retain the @tech{scope},

pkgs/racket-doc/syntax/scribblings/apply-transformer.scrbl

@@ -0,0 +1,27 @@
+#lang scribble/doc
+@(require "common.rkt" (for-label syntax/apply-transformer))
+
+@title[#:tag "syntax/apply-transformer"]{Applying Macro Transformers}
+
+@defmodule[syntax/apply-transformer]
+
+@defproc[(local-apply-transformer [transformer (or/c (-> syntax? syntax?) set!-transformer?)]
+                                  [stx syntax?]
+                                  [context (or/c 'expression 'top-level 'module 'module-begin list?)]
+                                  [intdef-ctxs (listof internal-definition-context?) '()])
+         syntax?]{
+
+Applies @racket[transformer] as a @tech[#:doc refman]{syntax transformer} to @racket[stx] in the
+current expansion context. The result is similar to expanding @racket[(m stx)] with
+@racket[local-expand], where @racket[m] is bound to @racket[transformer], except that expansion is
+guaranteed to stop after applying a single macro transformation (assuming @racket[transformer] does
+not explicitly force further recursive expansion).
+
+Unlike simply applying @racket[transformer] to @racket[stx] directly, using
+@racket[local-apply-transformer] introduces the appropriate @tech[#:doc refman]{use-site scope} and
+@tech[#:doc refman]{macro-introduction scope} that would be added by the expander.
+
+The @racket[context] and @racket[intdef-ctxs] arguments are treated the same way as the corresponding
+arguments to @racket[local-expand].
+
+@history[#:added "6.90.0.29"]}

pkgs/racket-doc/syntax/scribblings/transformer-helpers.scrbl

@@ -11,3 +11,4 @@
 @include-section["path-spec.scrbl"]
 @include-section["template.scrbl"]
 @include-section["transformer.scrbl"]
+@include-section["apply-transformer.scrbl"]

racket/collects/syntax/apply-transformer.rkt

@@ -0,0 +1,55 @@
+#lang racket/base
+
+(require (for-template racket/base)
+         racket/syntax)
+
+(provide local-apply-transformer)
+
+(define ((make-quoting-transformer transformer-proc) stx)
+  (syntax-case stx ()
+    [(_ form)
+     (let ([result (transformer-proc #'form)])
+       (unless (syntax? result)
+         (raise-arguments-error 'local-apply-transformer
+                                "received value from syntax expander was not syntax"
+                                "received" result))
+       #`(quote #,result))]))
+
+(define (local-apply-transformer transformer stx context [intdef-ctxs '()])
+  (unless (or (set!-transformer? transformer)
+              (and (procedure? transformer)
+                   (procedure-arity-includes? transformer 1)))
+    (raise-argument-error 'local-apply-transformer
+                          "(or/c (-> syntax? syntax?) set!-transformer?)"
+                          transformer))
+  (unless (syntax? stx)
+    (raise-argument-error 'local-apply-transformer "syntax?" stx))
+  (unless (or (eq? context 'expression)
+              (eq? context 'top-level)
+              (eq? context 'module)
+              (eq? context 'module-begin)
+              (list? context))
+    (raise-argument-error 'local-apply-transformer
+                          "(or/c 'expression 'top-level 'module 'module-begin list?)"
+                          context))
+  (unless (and (list? intdef-ctxs)
+               (andmap internal-definition-context? intdef-ctxs))
+    (raise-argument-error 'local-apply-transformer
+                          "(listof internal-definition-context?)"
+                          intdef-ctxs))
+  (unless (syntax-transforming?)
+    (raise-arguments-error 'local-apply-transformer "not currently expanding"))
+  (let* ([intdef-ctx (syntax-local-make-definition-context #f #f)]
+         [transformer-proc (if (set!-transformer? transformer)
+                               (set!-transformer-procedure transformer)
+                               transformer)]
+         [transformer-id (internal-definition-context-introduce
+                          intdef-ctx
+                          (generate-temporary 'local-apply-transformer))]
+         [intdef-ctxs* (cons intdef-ctx intdef-ctxs)])
+    (syntax-local-bind-syntaxes
+     (list transformer-id)
+     #`(quote #,(make-quoting-transformer transformer-proc))
+     intdef-ctx)
+    (syntax-case (local-expand #`(#,transformer-id #,stx) context '() intdef-ctxs*) (quote)
+      [(quote form) #'form])))