www

commit ad27231d00c9bdae618e0b8af5121d31a9bfd38f
parent de60a419e243927c58cce0a27b754eb55f655adc
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Thu, 26 Jan 2017 05:27:34 +0100

Support #:properties on all four of (quasi)template(/loc), instead of just template.

Diffstat:
M
current-pvars.rkt
 | 
25
+++++++++++++++----------
M
parse/experimental/template.rkt
 | 
19
+++++++++++++++++--
M
scribblings/stxparse-info.scrbl
 | 
4
++--

3 files changed, 34 insertions(+), 14 deletions(-)
diff --git a/current-pvars.rkt b/current-pvars.rkt
@@ -136,11 +136,11 @@
           (void))
       (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))]
              [unique-at-runtime (map gensym (map syntax-e pvars))]
-             [stxquoted-pvars (map (λ (v unique)
-                                     `(cons (quote-syntax ,v)
-                                            (quote-syntax ,unique)))
-                                   pvars
-                                   unique-at-runtime)]
+             [stxquoted-pvars+unique (map (λ (v unique)
+                                            `(cons (quote-syntax ,v)
+                                                   (quote-syntax ,unique)))
+                                          pvars
+                                          unique-at-runtime)]
              [body (stx-cdr (stx-cdr stx))]
              [old-pvars-index (find-last-current-pvars)]
              [old-pvars (try-nth-current-pvars old-pvars-index)]
@@ -158,10 +158,10 @@
          (quote-syntax here)
          `(let-values (,@do-unique-at-runtime)
             (letrec-syntaxes+values
-                ([(,binding) (list* ,@stxquoted-pvars
+                ([(,binding) (list* ,@stxquoted-pvars+unique
                                     (try-nth-current-pvars ,old-pvars-index))]
                  [(,lower-bound-binding) ,(+ old-pvars-index 1)])
-                ()
+              ()
               . ,body))))))
 
   (define-syntaxes (define-pvars)
@@ -173,8 +173,13 @@
                             (syntax*->list (stx-cdr stx)))))
           (raise-syntax-error 'with-pvars "bad syntax" stx)
           (void))
-      (let* ([pvars (syntax*->list (stx-cdr stx))]
-             [quoted-pvars (reverse (map (λ (v) `(quote-syntax ,v)) pvars))]
+      (let* ([pvars (reverse (syntax*->list (stx-cdr stx)))]
+             [unique-at-runtime (map gensym (map syntax-e pvars))]
+             [stxquoted-pvars+unique (map (λ (v unique)
+                                            `(cons (quote-syntax ,v)
+                                                   (quote-syntax ,unique)))
+                                          pvars
+                                          unique-at-runtime)]
              [old-pvars-index (find-last-current-pvars)]
              [old-pvars (try-nth-current-pvars old-pvars-index)]
              [binding (syntax-local-identifier-as-binding
@@ -182,5 +187,5 @@
         (datum->syntax
          (quote-syntax here)
          `(define-syntaxes (,binding)
-            (list* ,@quoted-pvars
+            (list* ,@stxquoted-pvars+unique
                    (try-nth-current-pvars ,old-pvars-index))))))))
 \ No newline at end of file
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -92,7 +92,13 @@ A HeadTemplate (H) is one of:
 (define-syntax (quasitemplate stx)
   (syntax-case stx ()
     [(quasitemplate t)
-     (do-template stx #'t #t #f)]))
+     (do-template stx #'t #t #f)]
+    [(quasitemplate t #:properties (prop ...))
+     (andmap identifier? (syntax->list #'(prop ...)))
+     (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
+                    (props-to-transfer (syntax->datum #'(prop ...))))
+       ;; Same as above
+       (do-template stx #'t #t #f))]))
 
 (define-syntaxes (template/loc quasitemplate/loc)
   ;; FIXME: better to replace unsyntax form, shrink template syntax constant
@@ -104,7 +110,16 @@ A HeadTemplate (H) is one of:
                 (syntax-arm
                  (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
                    #'(let ([loc-stx (handle-loc '?/loc loc-expr)])
-                       main-expr)))])))])
+                       main-expr)))]
+               [(?/loc loc-expr t #:properties (prop ...))
+                (andmap identifier? (syntax->list #'(prop ...)))
+                (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
+                               (props-to-transfer (syntax->datum #'(prop ...))))
+                  ;; Same as above
+                  (syntax-arm
+                   (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
+                     #'(let ([loc-stx (handle-loc '?/loc loc-expr)])
+                         main-expr))))])))])
     (values (make-tx #f) (make-tx #t))))
 
 (define (handle-loc who x)
diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl
@@ -115,9 +115,9 @@ track which syntax or datum pattern variables are bound.
  (let ([my-valvar (quote-syntax x)])
    (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
      (with-pvars (x)
-       (get-current-pvars+unique)) (code:comment '([x . g123]))
+       (get-current-pvars+unique)) (code:comment "'([x . g123])")
      (with-pvars (x)
-                 (get-current-pvars+unique)))) (code:comment '([x . g124]))]
+                 (get-current-pvars+unique)))) (code:comment "'([x . g124])")]
 
  Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
  be called immediately after binding the syntax pattern variable, but the code