From f5b86c1dddf09034c80b7fdd2be3d6f9c347da79 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 19 Aug 2012 14:38:30 -0400
Subject: [PATCH] added make-variable-like-transformer

---
 collects/unstable/scribblings/syntax.scrbl | 27 ++++++++++++++++++++
 collects/unstable/syntax.rkt               | 29 ++++++++++++++++++++--
 2 files changed, 54 insertions(+), 2 deletions(-)

diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl
index f594be5635..01c57bcef8 100644
--- a/collects/unstable/scribblings/syntax.scrbl
+++ b/collects/unstable/scribblings/syntax.scrbl
@@ -43,6 +43,33 @@ phase level is 1.
 ]
 }
 
+@defproc[(make-variable-like-transformer [reference-stx syntax?]
+                                         [setter-stx (or/c syntax? #f) #f])
+         set!-transformer?]{
+
+Creates a transformer that replaces references to the macro identifier
+with @racket[reference-stx]. Uses of the macro in operator position
+are interpreted as an application with @racket[reference-stx] as the
+function and the arguments as given.
+
+If the macro identifier is used as the target of a @racket[set!] form,
+then the @racket[set!] form expands into the application of
+@racket[setter-stx] to the @racket[set!] expression's right-hand side,
+if @racket[setter-stx] is syntax; otherwise, the identifier is
+considered immutable and a syntax error is raised.
+
+@examples[#:eval the-eval
+(define the-box (box add1))
+(define-syntax op
+  (make-variable-like-transformer
+   #'(unbox the-box)
+   #'(lambda (v) (set-box! the-box v))))
+(op 5)
+(set! op 0)
+op
+]
+
+}
 
 @;{----}
 
diff --git a/collects/unstable/syntax.rkt b/collects/unstable/syntax.rkt
index de1c34ee38..a96214430a 100644
--- a/collects/unstable/syntax.rkt
+++ b/collects/unstable/syntax.rkt
@@ -2,7 +2,8 @@
 ;; owner: ryanc (and cce and stamourv, where noted)
 (require racket/syntax
          syntax/stx
-         (for-syntax racket/base))
+         (for-syntax racket/base)
+         (for-template racket/base))
 
 (provide (rename-out [stx-map syntax-map])
 
@@ -16,7 +17,8 @@
 
          ;; by ryanc
          explode-module-path-index
-         phase-of-enclosing-module)
+         phase-of-enclosing-module
+         make-variable-like-transformer)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -78,3 +80,26 @@
 (define-syntax-rule (phase-of-enclosing-module)
   (variable-reference->module-base-phase
    (#%variable-reference)))
+
+(define (make-variable-like-transformer ref-stx [set!-handler #f])
+  (unless (syntax? ref-stx)
+    (raise-type-error 'make-variable-like-transformer "syntax?" ref-stx))
+  (unless (or (syntax? set!-handler) (procedure? set!-handler) (eq? set!-handler #f))
+    (raise-type-error 'make-variable-like-transformer "(or/c syntax? procedure? #f)" set!-handler))
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [id
+        (identifier? #'id)
+        ref-stx]
+       [(set! id val)
+        (cond [(procedure? set!-handler)
+               (set!-handler stx)]
+              [(syntax? set!-handler)
+               (with-syntax ([setter set!-handler])
+                 (syntax/loc stx (setter val)))]
+              [else
+               (raise-syntax-error #f "cannot mutate identifier" stx #'id)])]
+       [(id . args)
+        (let ([stx* (cons #'(#%expression id) (cdr (syntax-e stx)))])
+          (datum->syntax stx stx* stx))]))))