Implements and provides prop:template-metafunction

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)

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)))

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))))

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
+                        attribute-mapping-check)))
-                        metafunction metafunction?)))
 
 ;; ============================================================
 ;; 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)))))]