Add define-rename-transformer-parameter and friends

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.3.0.13")
+(define version "6.3.0.14")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/stx-param.scrbl

@@ -79,6 +79,34 @@ the target's value.
          (if t then else)))]))
 ]}
 
+@defform[(define-rename-transformer-parameter id expr)]{
+
+Binds @racket[id] as syntax to a @tech{syntax parameter} that must
+be bound to a @racket[make-rename-transformer] result and, unlike
+@racket[define-syntax-parameter], @racket[syntax-local-value] of
+@racket[id] @emph{does} produce the target's value, including inside
+of @racket[syntax-parameterize].
+
+@examples[#:eval the-eval #:escape UNSYNTAX
+ (define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ t)
+     #`#,(syntax-local-value #'t)]))
+ (define-syntax one 1)
+ (define-syntax two 2)
+ (define-syntax-parameter not-num
+   (make-rename-transformer #'one))
+ (test not-num)
+
+ (define-rename-transformer-parameter num
+   (make-rename-transformer #'one))
+ (test num)
+ (syntax-parameterize ([num (make-rename-transformer #'two)])
+   (test num))
+]
+
+@history[#:added "6.3.0.14"]}
+
 @; ----------------------------------------------------------------------
 
 @section{Syntax Parameter Inspection}

pkgs/racket-doc/scribblings/reference/stx-trans.scrbl

@@ -198,10 +198,12 @@ the target identifier is extracted from the structure instance; if the
 field value is not an identifier, then an identifier @racketidfont{?}
 with an empty context is used, instead.
 
-If the property value is a procedure that takes one argument, then the procedure
+If the property value is a procedure that takes one argument, then the
-is called to obtain the identifier that the rename transformer will use
+procedure is called to obtain the identifier that the rename
-as a target identifier. If the procedure returns any value that is not
+transformer will use as a target identifier. The returned identifier
-an identifier, the @racket[exn:fail:contract] exception is raised.
+should probably have the @racket['not-free-identifier=?] syntax
+property. If the procedure returns any value that is not an
+identifier, the @racket[exn:fail:contract] exception is raised.
 
 @examples[#:eval stx-eval #:escape UNSYNTAX
   (code:comment "Example of a procedure argument for prop:rename-transformer")

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

@@ -2926,8 +2926,8 @@ Similar to @racket[quote], but produces a @tech{syntax object}
 that preserves the @tech{lexical information} and source-location
 information attached to @racket[datum] at expansion time.
 
-When @racket[#:local] is specified, than all @tech{scopes} in the
+When @racket[#:local] is specified, then all @tech{scopes} in the
-syntax object's @tech{lexical information} is preserved. When
+syntax object's @tech{lexical information} are preserved. When
 @racket[#:local] is omitted, then the @tech{scope sets} within
 @racket[datum] are pruned to omit the @tech{scope} for any binding
 form that appears between the @racket[quote-syntax] form and the

pkgs/racket-test-core/tests/racket/stxparam.rktl

@@ -132,5 +132,23 @@
 
 ;; ----------------------------------------
 
+(let ()
+  (define-syntax (slv stx)
+    (syntax-case stx ()
+      [(_ t)
+       #`#,(syntax-local-value #'t)]))
+  (define-syntax one 1)
+  (define-syntax two 2)
+  (define-rename-transformer-parameter num
+    (make-rename-transformer #'one))
+  (test #t = (slv num) 1)
+  (syntax-parameterize ([num (make-rename-transformer #'two)])
+    (test #t = (slv num) 2))
+  (splicing-syntax-parameterize ([num (make-rename-transformer #'two)])
+    (define too (slv num)))
+  (test #t = too 2))
+
+;; ----------------------------------------
+
 (report-errs)
 

racket/collects/racket/private/stxparam.rkt

@@ -12,7 +12,7 @@
     (syntax-case stx ()
       [(_ ([id val] ...) body ...)
        (let ([ids (syntax->list #'(id ...))])
-	 (with-syntax ([(gen-id ...)
+	 (with-syntax ([((gen-id must-be-renamer?) ...)
 			(map (lambda (id)
 			       (unless (identifier? id)
 				 (raise-syntax-error
@@ -20,19 +20,29 @@
 				  "not an identifier"
 				  stx
 				  id))
-			       (let* ([rt (syntax-local-value id (lambda () #f))]
+			       (let*-values
-				      [sp (if (set!-transformer? rt)
+                    ;; If it is a rename-transformer-parameter, then
-					      (set!-transformer-procedure rt)
+                    ;; we need to get the parameter and not what it
-					      rt)])
+                    ;; points to, otherwise, we can keep going.
+                    ([(rt* rt-target)
+                      (syntax-local-value/immediate id (lambda () #f))]
+                     [(rt) (if (syntax-parameter? rt*)
+                               rt*
+                               (or rt-target rt*))]
+                     [(sp) (if (set!-transformer? rt)
+                               (set!-transformer-procedure rt)
+                               rt)])
 				 (unless (syntax-parameter? sp)
 				   (raise-syntax-error
 				    #f
 				    "not bound as a syntax parameter"
 				    stx
 				    id))
-				 (syntax-local-get-shadower
+				 (list
-				  (syntax-local-introduce (syntax-parameter-target sp))
+                  (syntax-local-get-shadower
-                                  #t)))
+                   (syntax-local-introduce (syntax-parameter-target sp))
+                   #t)
+                  (rename-transformer-parameter? sp))))
 			     ids)])
 	   (let ([dup (check-duplicate-identifier ids)])
 	     (when dup
@@ -52,6 +62,10 @@
                                          (list ids)
                                          #'())])
              (syntax/loc stx
-               (let-syntaxes ([(gen-id) (convert-renamer val)] ...)
+               (let-syntaxes ([(gen-id)
+                               (convert-renamer
+                                (if must-be-renamer? (quote-syntax val) #f)
+                                val)]
+                              ...)
                  orig ...
                  body ...)))))])))

racket/collects/racket/private/stxparamkey.rkt

@@ -4,10 +4,34 @@
              "stxcase.rkt" "stxloc.rkt" "with-stx.rkt")
 
   (-define-struct wrapped-renamer (renamer))
-  (-define-struct parameter-binding (val param))
+
+  (define-values (struct:parameter-binding make-parameter-binding parameter-binding? parameter-binding-ref parameter-binding-set!)
+    (make-struct-type 'parameter-binding #f 2 0 #f null (current-inspector) #f '(0 1)))
+  (define parameter-binding-val (make-struct-field-accessor parameter-binding-ref 0))
+  (define parameter-binding-param (make-struct-field-accessor parameter-binding-ref 1))
+
+  (define (parameter-binding-rt-target pbr)
+    (rename-transformer-target (wrapped-renamer-renamer (parameter-binding-val pbr))))
   
+  (define-values (struct:parameter-binding-rt make-parameter-binding-rt parameter-binding-rt? parameter-binding-rt-ref parameter-binding-rt-set!)
+    (make-struct-type 'parameter-binding-rt struct:parameter-binding 0 0 #f (list (cons prop:rename-transformer parameter-binding-rt-target)) (current-inspector) #f))
+    
   (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))
+    (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0 '(0 1)))
+
+  (define (rename-transformer-parameter-target rtp)
+    (define t (syntax-parameter-target rtp))
+    ;; XXX (syntax-transforming?) is not always true when the
+    ;; prop:rename-transformer procedure is evaluated. I think this is
+    ;; because it used to test rename-transformer?
+    (define lt
+      (if (syntax-transforming?)
+          (syntax-local-get-shadower t #t)
+          t))
+    (syntax-property lt 'not-free-identifier=? #t))
+  
+  (define-values (struct:rename-transformer-parameter make-rename-transformer-parameter rename-transformer-parameter? rename-transformer-parameter-ref rename-transformer-parameter-set!)
+    (make-struct-type 'rename-transformer-parameter struct:syntax-parameter 0 0 #f (list (cons prop:rename-transformer rename-transformer-parameter-target)) (current-inspector) #f))
 
   (define (syntax-parameter-target sp)
     (syntax-parameter-ref sp 1))
@@ -36,12 +60,17 @@
     (let ([v (target-value target)])
       (parameter-binding-param v)))
 
-  (define (convert-renamer v)
+  (define (convert-renamer must-be-renamer?-stx v)
-    (make-parameter-binding
+    (when must-be-renamer?-stx
+      (unless (rename-transformer? v)
+        (raise-syntax-error #f "rename-transformer-parameter must be bound to rename-transformer" must-be-renamer?-stx)))
+    ((if must-be-renamer?-stx
+         make-parameter-binding-rt
+         make-parameter-binding)
      (if (rename-transformer? v)
          (make-wrapped-renamer v)
          v)
-     ;; comile-time parameter needed for `splicing-syntax-parameterize':
+     ;; compile-time parameter needed for `splicing-syntax-parameterize':
      (make-parameter #f)))
 
   (define (apply-transformer v stx set!-stx)
@@ -84,6 +113,8 @@
              apply-transformer
              syntax-parameter?
              make-syntax-parameter
+             rename-transformer-parameter?
+             make-rename-transformer-parameter
              syntax-parameter-target
              syntax-parameter-target-value
              syntax-parameter-target-parameter))

racket/collects/racket/stxparam.rkt

@@ -10,6 +10,7 @@
                          "private/stxloc.rkt" "private/stxparamkey.rkt"))
 
   (#%provide define-syntax-parameter
+             define-rename-transformer-parameter
              syntax-parameterize
              (for-syntax syntax-parameter-value
                          make-parameter-rename-transformer))
@@ -18,16 +19,28 @@
     (syntax-case stx ()
       [(_ id init-val)
        (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
-	 #'(begin
+         #'(begin
-	     (define-syntax gen-id (convert-renamer init-val))
+             (define-syntax gen-id (convert-renamer #f init-val))
-	     (define-syntax id 
+             (define-syntax id 
-	       (let ([gen-id #'gen-id])
+               (let ([gen-id #'gen-id])
-		 (make-set!-transformer
+                 (make-set!-transformer
-		  (make-syntax-parameter 
+                  (make-syntax-parameter 
-		   (lambda (stx)
+                   (lambda (stx)
-		     (let ([v (syntax-parameter-target-value gen-id)])
+                     (let ([v (syntax-parameter-target-value gen-id)])
-		       (apply-transformer v stx #'set!)))
+                       (apply-transformer v stx #'set!)))
-		   gen-id))))))]))
+                   gen-id))))))]))
+
+  (define-syntax (define-rename-transformer-parameter stx)
+    (syntax-case stx ()
+      [(_ id init-val)
+       (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
+         #'(begin
+             (define-syntax gen-id (convert-renamer #'init-val init-val))
+             (define-syntax id 
+               (let ([gen-id #'gen-id])
+                 (make-rename-transformer-parameter 
+                  #f
+                  gen-id)))))]))
 
   (define-syntax (syntax-parameterize stx)
     (do-syntax-parameterize stx #'let-syntaxes #f #f)))

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.3.0.13"
+#define MZSCHEME_VERSION "6.3.0.14"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 13
+#define MZSCHEME_VERSION_W 14
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)