diff --git a/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
index d8b368762e..135f930c59 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
@@ -347,4 +347,37 @@ the context above; instead, @racket[let-values] would report an
invalid binding list.
}
+@deftogether[
+ ((defthing prop:template-metafunction struct-type-property?)
+ (defthing template-metafunction? (-> any/c boolean?))
+ (defthing template-metafunction-accessor (-> template-metafunction? identifier?)))]{
+
+ A structure type property, and the associated predicate and accessor. The
+ property value is either an identifier, or the index of a field containing an
+ identifier. The identifier should be bound to the run-time metafunction. The
+ run-time metafunction should accept a syntax object representing its use, and
+ produce a new syntax object as a result.
+
+ When an identifier is bound as syntax to a structure instance with this
+ property, it is treated as a template metafunction as if the identifier had
+ been declared with define-template-metafunction.
+
+ @examples[#:eval the-eval
+ (define (my-metafunction-proc stx)
+ (syntax-case stx ()
+ [(_ n) (datum->syntax #'n (add1 (syntax-e #'n)))]))
+
+ (begin-for-syntax
+ (struct mf-struct (proc-id)
+ #:property prop:template-metafunction
+ (struct-field-index proc-id)))
+
+ (define-syntax mf (mf-struct #'my-metafunction-proc))
+
+ (template (mf 3))
+ (with-syntax ([(x ...) #'(1 2 3)])
+ (template ((mf x) ...)))]
+
+ @history[#:added 6.9]}
+
@(close-eval the-eval)
diff --git a/pkgs/racket-test/tests/stxparse/test-template.rkt b/pkgs/racket-test/tests/stxparse/test-template.rkt
index 3ccfb7932e..43745990f5 100644
--- a/pkgs/racket-test/tests/stxparse/test-template.rkt
+++ b/pkgs/racket-test/tests/stxparse/test-template.rkt
@@ -66,3 +66,66 @@
(terx (template (bad-mf))
#rx"result of template metafunction was not syntax")
+
+;; ============================================================
+
+;; Test prop:template-metafunction and template-metafunction?
+
+(define-syntax (is-metafunction? stx)
+ (syntax-case stx ()
+ [(_ id)
+ #`#,(template-metafunction? (syntax-local-value #'id))]))
+
+(test-case "template-metafunction? on define-template-metafunction"
+ (define-template-metafunction (mf1 stx)
+ #'1)
+
+ (check-true (is-metafunction? mf1)))
+
+(begin-for-syntax
+ (struct my-template-metafunction2 (proc-id)
+ #:property prop:template-metafunction (struct-field-index proc-id)))
+(test-case
+ "template-metafunction? on custom prop:template-metafunction with field"
+ (define (myproc2 stx) #'2)
+ (define-syntax mf2 (my-template-metafunction2 (quote-syntax myproc2)))
+
+ (check-true (is-metafunction? mf2)))
+
+
+;; must be before the definition of my-template-metafunction3
+(define (myproc3 stx) #'3)
+;; must be outside of the (test-case …) form
+(begin-for-syntax
+ (struct my-template-metafunction3 ()
+ #:property prop:template-metafunction (quote-syntax myproc3)))
+(test-case "template-metafunction? on custom prop:template-metafunction with id"
+ (define-syntax mf3 (my-template-metafunction3))
+
+ (check-true (is-metafunction? mf3)))
+
+(begin-for-syntax
+ (struct my-template-metafunction4 (proc-id)
+ #:property prop:template-metafunction (struct-field-index proc-id)))
+(test-case "use custom prop:template-metafunction with field"
+ (define (myproc4 stx)
+ (syntax-case stx ()
+ [(_ n) #`#,(add1 (syntax-e #'n))]))
+ (define-syntax mf4 (my-template-metafunction4 (quote-syntax myproc4)))
+
+ (check-equal? (syntax->datum (template (x (mf4 3) z)))
+ '(x 4 z)))
+
+;; must be before the definition of my-template-metafunction5
+(define (myproc5 stx)
+ (syntax-case stx ()
+ [(_ n) #`#,(* (syntax-e #'n) 2)]))
+;; must be outside of the (test-case …) form
+(begin-for-syntax
+ (struct my-template-metafunction5 ()
+ #:property prop:template-metafunction (quote-syntax myproc5)))
+(test-case "use custom prop:template-metafunction with id"
+ (define-syntax mf5 (my-template-metafunction5))
+
+ (check-equal? (syntax->datum (template (x (mf5 3) z)))
+ '(x 6 z)))
\ No newline at end of file
diff --git a/racket/collects/racket/private/prop-template-metafunction.rkt b/racket/collects/racket/private/prop-template-metafunction.rkt
new file mode 100644
index 0000000000..f66167247c
--- /dev/null
+++ b/racket/collects/racket/private/prop-template-metafunction.rkt
@@ -0,0 +1,69 @@
+(module prop-template-metafunction '#%kernel
+ (#%provide (protect metafunction
+ prop:metafunction
+ (rename prop:metafunction? metafunction?)
+ metafunction-accessor))
+
+ ;; The prop:metafunction structure type property can contain an
+ ;; identifier bound to the run-time metafunction procedure, or the index of a
+ ;; field containing such an identifier.
+ ;; At run-time, when processing the template, the syntax object whose first
+ ;; element is a metafunction identifiers is passed to this metafunction
+ ;; procedure.
+
+ (define-values (prop:metafunction-guard)
+ (lambda (val struct-type-info-list)
+ (if (exact-nonnegative-integer? val)
+ ;; Field index, the field must contain an identifier bound to the run-time
+ ;; metafunction procedure.
+ (let-values ([(make-struct-accessor) (cadddr struct-type-info-list)])
+ (let-values ([(accessor) (make-struct-field-accessor make-struct-accessor val)])
+ (λ (instance)
+ (let-values ([(metafunction-internal-id) (accessor instance)])
+ ;; Check that the value contained in the field is correct
+ ;; (if (identifier? metafunction-internal-id) ...)
+ (if (if (syntax? metafunction-internal-id)
+ (symbol? (syntax-e metafunction-internal-id))
+ #f)
+ metafunction-internal-id
+ (raise-argument-error
+ 'prop:metafunction-guard
+ (format (string-append "the value of the ~a-th field should be"
+ " an identifier")
+ val)
+ metafunction-internal-id))))))
+ ;;(if (identifier? val)
+ (if (if (syntax? val) (symbol? (syntax-e val)) #f)
+ ;; Identifier bound to the run-time metafunction procedure.
+ (λ (_instance) val)
+ ;; Otherwise, raise an error.
+ (raise-argument-error
+ 'prop:metafunction-guard
+ (string-append "an identifier, or an exact non-negative integer designating"
+ " a field index within the structure that should contain an"
+ " identifier.")
+ val)))))
+
+ (define-values (prop:metafunction
+ prop:metafunction?
+ metafunction-raw-accessor)
+ (make-struct-type-property 'metafunction
+ prop:metafunction-guard))
+
+ (define-values (metafunction-accessor)
+ (lambda (instance . more-args)
+ (let-values ([(raw) (if (null? more-args) ;; no failure-result given
+ (metafunction-raw-accessor instance)
+ (if (null? (cdr more-args))
+ (let-values ([(failure-result) (car more-args)])
+ (metafunction-raw-accessor instance failure-result))
+ (error "invalid number of arguments [TODO]")))])
+ (raw instance))))
+
+ ;; A default struct type with prop:metafunction.
+ ;; (struct template-metafunction (proc-id)
+ ;; #:property prop:template-metafunction (struct-field-index proc-id))
+ (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
+ (make-struct-type 'syntax-metafunction #f 1 0 #f
+ (list (cons prop:metafunction 0))
+ (current-inspector))))
\ No newline at end of file
diff --git a/racket/collects/racket/private/template.rkt b/racket/collects/racket/private/template.rkt
index 3d55876197..2a21b04456 100644
--- a/racket/collects/racket/private/template.rkt
+++ b/racket/collects/racket/private/template.rkt
@@ -4,6 +4,7 @@
(rename "define-et-al.rkt" define-syntax -define-syntax)
"ellipses.rkt"
(for-syntax "stx.rkt" "define-et-al.rkt" "qq-and-or.rkt" "cond.rkt"
+ "prop-template-metafunction.rkt"
(rename "define-et-al.rkt" define -define)
(rename "define-et-al.rkt" define-syntax -define-syntax)
#;"member.rkt" "sc.rkt" '#%kernel))
@@ -12,14 +13,17 @@
datum
~? ~@
~@! signal-absent-pvar
+ (for-syntax prop:metafunction
+ metafunction
+ metafunction-accessor
+ metafunction?)
(protect
(for-syntax attribute-mapping
attribute-mapping?
attribute-mapping-name
attribute-mapping-var
attribute-mapping-depth
- attribute-mapping-check
- metafunction metafunction?)))
+ attribute-mapping-check)))
;; ============================================================
;; Syntax of templates
@@ -111,11 +115,6 @@
(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
- ;; (struct metafunction (var))
- (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
- (make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector)))
- (define (metafunction-var mf) (metafunction-ref mf 0))
-
(define (guide-is? x tag) (and (pair? x) (eq? (car x) tag)))
(define (ht-guide? x) (guide-is? x 'h-t))
@@ -275,7 +274,7 @@
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
(disappeared! (stx-car t))
(define guide (parse-t (stx-cdr t) depth esc?))
- `(t-metafun ,(metafunction-var mf) ,guide
+ `(t-metafun ,(metafunction-accessor mf) ,guide
(quote-syntax
,(let ([tstx (and (syntax? t) t)])
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))]