make splicing-syntax-parameterize' work with begin-for-syntax'

More generally, a `splicing-syntax-parameterize' wrapping immediate
compile-time code effectively parameterizes the compile-time code as
well as any macro-triggered compile-time code. This is implemented by
using a compile-time parameter that complements each syntax binding.

collects/racket/private/stxparam.rkt

@@ -8,7 +8,7 @@
 
   (#%provide (for-syntax do-syntax-parameterize))
 
-  (define-for-syntax (do-syntax-parameterize stx let-syntaxes-id empty-body-ok?)
+  (define-for-syntax (do-syntax-parameterize stx let-syntaxes-id empty-body-ok? keep-orig?)
     (syntax-case stx ()
       [(_ ([id val] ...) body ...)
        (let ([ids (syntax->list #'(id ...))])
@@ -46,7 +46,11 @@
                 #f
                 "missing body expression(s)"
                 stx)))
-           (with-syntax ([let-syntaxes let-syntaxes-id])
+           (with-syntax ([let-syntaxes let-syntaxes-id]
+                         [(orig ...) (if keep-orig?
+                                         (list ids)
+                                         #'())])
              (syntax/loc stx
                (let-syntaxes ([(gen-id) (convert-renamer val)] ...)
+                 orig ...
                  body ...)))))])))

collects/racket/private/stxparamkey.rkt

@@ -4,6 +4,7 @@
              "stxcase.rkt" "stxloc.rkt" "with-stx.rkt")
 
   (-define-struct wrapped-renamer (renamer))
+  (-define-struct parameter-binding (val param))
   
   (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!)
     (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0))
@@ -11,21 +12,37 @@
   (define (syntax-parameter-target sp)
     (syntax-parameter-ref sp 1))
 
+  (define (target-value target)
+    (syntax-local-value (syntax-local-get-shadower target)
+                        (lambda ()
+                          (syntax-local-value 
+                           target
+                           (lambda () #f)))))
+
   (define (syntax-parameter-target-value target)
-    (let ([v (syntax-local-value (syntax-local-get-shadower target)
+    (let* ([v (target-value target)]
-				 (lambda ()
+           [v (if (parameter-binding? v)
-				   #f
+                  (or (let ([id ((parameter-binding-param v))])
-				   (syntax-local-value 
+                        (and id
-				    target
+                             (let ([v (syntax-local-value id)])
-				    (lambda () #f))))])
+                               (parameter-binding-val v))))
+                      (parameter-binding-val v))
+                  v)])
       (if (wrapped-renamer? v)
 	  (wrapped-renamer-renamer v)
-	  v)))
+          v)))
+
+  (define (syntax-parameter-target-parameter target)
+    (let ([v (target-value target)])
+      (parameter-binding-param v)))
 
   (define (convert-renamer v)
-    (if (rename-transformer? v)
+    (make-parameter-binding
-	(make-wrapped-renamer v)
+     (if (rename-transformer? v)
-	v))
+         (make-wrapped-renamer v)
+         v)
+     ;; comile-time parameter needed for `splicing-syntax-parameterize':
+     (make-parameter #f)))
 
   (define (apply-transformer v stx set!-stx)
     (cond
@@ -68,4 +85,5 @@
              syntax-parameter?
              make-syntax-parameter
              syntax-parameter-target
-             syntax-parameter-target-value))
+             syntax-parameter-target-value
+             syntax-parameter-target-parameter))

collects/racket/splicing.rkt

@@ -1,7 +1,11 @@
 #lang racket/base
 (require (for-syntax racket/base
                      syntax/kerncase
-                     racket/syntax)
+                     racket/syntax
+                     "private/stxparamkey.rkt")
+         (for-meta 2  ; for wrap-et-param
+                   racket/base
+                   syntax/kerncase)
          "private/stxparam.rkt"
          "private/local.rkt")
 
@@ -159,24 +163,24 @@
 (define-syntax (splicing-syntax-parameterize stx)
   (if (eq? 'expression (syntax-local-context))
       ;; Splicing is no help in an expression context:
-      (do-syntax-parameterize stx #'let-syntaxes #f)
+      (do-syntax-parameterize stx #'let-syntaxes #f #f)
       ;; Let `syntax-parameterize' check syntax, then continue
-      (do-syntax-parameterize stx #'ssp-let-syntaxes #t)))
+      (do-syntax-parameterize stx #'ssp-let-syntaxes #t #t)))
 
 (define-syntax (ssp-let-syntaxes stx)
   (syntax-case stx ()
-    [(_ ([(id) rhs] ...) body ...)
+    [(_ ([(id) rhs] ...) (orig-id ...) body ...)
      (with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))])
        #'(begin
            ;; Evaluate each RHS only once:
            (define-syntax splicing-temp rhs) ...
            ;; Partially expand `body' to push down `let-syntax':
-           (expand-ssp-body (id ...) (splicing-temp ...) body)
+           (expand-ssp-body (id ...) (splicing-temp ...) (orig-id ...) body)
            ...))]))
 
 (define-syntax (expand-ssp-body stx)
   (syntax-case stx ()
-    [(_ (sp-id ...) (temp-id ...) body)
+    [(_ (sp-id ...) (temp-id ...) (orig-id ...) body)
      (let ([body (local-expand #'(letrec-syntaxes/trans ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
                                                          ...)
                                     (force-expand body))
@@ -197,14 +201,18 @@
                                 #%provide )
               [(begin expr ...)
                (syntax/loc body
-                 (begin (expand-ssp-body (sp-id ...) (temp-id ...) expr) ...))]
+                 (begin (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) expr) ...))]
               [(define-values (id ...) rhs)
                (syntax/loc body
                  (define-values (id ...)
                    (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
                      rhs)))]
-              [(define-syntaxes . _) body]
+              [(define-syntaxes ids rhs)
-              [(begin-for-syntax . _) body]
+               (syntax/loc body
+                 (define-syntaxes ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))]
+              [(begin-for-syntax e ...)
+               (syntax/loc body
+                 (begin-for-syntax (wrap-param-et e (orig-id ...) (temp-id ...)) ...))]
               [(module . _) body]
               [(module* . _) body]
               [(#%require . _) body]
@@ -233,3 +241,48 @@
                                #f))
       'certify-mode
       'transparent)]))
+
+(define-for-syntax (parameter-of id)
+  (let* ([rt (syntax-local-value id)]
+         [sp (if (set!-transformer? rt)
+                 (set!-transformer-procedure rt)
+                 rt)])
+    (syntax-parameter-target-parameter
+     (syntax-parameter-target sp))))
+
+(begin-for-syntax
+ (define-syntax (wrap-param-et stx)
+   (syntax-case stx ()
+     [(_ e (orig-id ...) (temp-id ...))
+      (let ([as-expression
+             (lambda ()
+               #'(parameterize ([(parameter-of (quote-syntax orig-id)) 
+                                 (quote-syntax temp-id)]
+                                ...)
+                   e))])
+        (if (eq? (syntax-local-context) 'expression)
+            (as-expression)
+            (let ([e (local-expand #'e
+                                   (syntax-local-context)
+                                   (kernel-form-identifier-list)
+                                   #f)])
+              (syntax-case e (begin
+                               define-syntaxes define-values
+                               begin-for-syntax
+                               module module*
+                               #%require #%provide
+                               quote-syntax)
+                [(begin form ...)
+                 (syntax/loc e
+                   (begin (wrap-param-et form (orig-id ...) (temp-id ...)) ...))]
+                [(define-syntaxes . _) e]
+                [(begin-for-syntax . _) e]
+                [(define-values ids rhs)
+                 (syntax/loc e
+                   (define-values ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))]
+                [(module . _) e]
+                [(module* . _) e]
+                [(#%require . _) e]
+                [(#%provide . _) e]
+                [(quote-syntax . _) e]
+                [else (as-expression)]))))])))

collects/racket/stxparam.rkt

@@ -30,4 +30,4 @@
 		   gen-id))))))]))
 
   (define-syntax (syntax-parameterize stx)
-    (do-syntax-parameterize stx #'let-syntaxes #f)))
+    (do-syntax-parameterize stx #'let-syntaxes #f #f)))

collects/tests/racket/mz-tests.rktl

@@ -12,6 +12,7 @@
 (load-relative "stx.rktl")
 (load-relative "module.rktl")
 (load-relative "submodule.rktl")
+(load-relative "stxparam.rktl")
 (load-relative "number.rktl")
 (load-relative "unsafe.rktl")
 (load-relative "object.rktl")

collects/tests/racket/stxparam.rktl

@@ -0,0 +1,94 @@
+
+(load-relative "loadtest.rktl")
+
+(Section 'stxparam)
+
+(require racket/stxparam
+         racket/splicing)
+
+(define-syntax-parameter tHIs (lambda (stx) #'(quote orig)))
+(define-syntax-rule (inDIRECt) tHIs)
+
+(test 'orig values tHIs)
+(test 'orig values (inDIRECt))
+
+(test 'sub values (syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))])
+                    tHIs))
+(test 'sub values (syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))])
+                    (inDIRECt)))
+(test 'sub values (splicing-syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))])
+                    (inDIRECt)))
+
+(module check-splicing-stxparam-1 racket/base
+  (require (for-syntax racket/base)
+           racket/stxparam
+           racket/splicing)
+  (define-syntax-parameter sp 'orig)
+  (define-syntax (m stx)
+    (define v (syntax-parameter-value #'sp))
+    (syntax-case stx ()
+      [(_ id) #`(define id (quote #,v))]))
+  (m x)
+  (splicing-syntax-parameterize ([sp 'sub])
+    (begin
+     (define other 'other)
+     (m y)))
+
+  (begin-for-syntax (define sp-val-1 (syntax-parameter-value #'sp)))
+  (define-syntax (m1 stx)
+    (syntax-case stx ()
+      [(_ id) #`(define id (quote #,sp-val-1))]))
+  (m1 z)
+  
+  (splicing-syntax-parameterize ([sp 'sub2])
+    (begin-for-syntax (define sp-val-2 (syntax-parameter-value #'sp))))
+  (define-syntax (m2 stx)
+    (syntax-case stx ()
+      [(_ id) #`(define id (quote #,sp-val-2))]))
+  (m2 w)
+
+  (splicing-syntax-parameterize ([sp 'unused])
+    ;; make sure that `splicing-syntax-parameterize' can
+    ;; deal with a variety of compile-time forms
+    (begin-for-syntax
+     (require racket/base)
+     (define x 11)
+     (provide x)))
+
+  (define (f)
+    (splicing-syntax-parameterize ([sp 'nested])
+      (define-syntax m (let ([v (syntax-parameter-value #'sp)])
+                         (lambda (stx)
+                           #`(quote #,v)))))
+    (m))
+   
+  (define (g)
+    (syntax-parameterize ([sp 'hidden])
+      (splicing-syntax-parameterize ([sp 'also-nested])
+        (define-syntax m (let ([v (syntax-parameter-value #'sp)])
+                           (lambda (stx)
+                             #`(quote #,v)))))
+      (m)))
+   
+  (provide x y z w f g))
+
+(test 'orig dynamic-require ''check-splicing-stxparam-1 'x)
+(test 'sub dynamic-require ''check-splicing-stxparam-1 'y)
+(test 'orig dynamic-require ''check-splicing-stxparam-1 'z)
+(test 'sub2 dynamic-require ''check-splicing-stxparam-1 'w)
+(test 'nested values ((dynamic-require ''check-splicing-stxparam-1 'f)))
+(test 'also-nested values ((dynamic-require ''check-splicing-stxparam-1 'g)))
+
+(module check-splicing-stxparam-et racket/base
+  (require (for-syntax racket/base)
+           'check-splicing-stxparam-1)
+  (define-syntax (m stx) (datum->syntax stx x))
+  (define q (m))
+  (provide q))
+
+(test 11 dynamic-require ''check-splicing-stxparam-et 'q)
+
+;; ----------------------------------------
+
+(report-errs)
+