From c17c267f481d0e755a06e42091682e7f06b68316 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 3 May 2009 17:40:31 +0000
Subject: [PATCH] R6RS: disallow assignment to exported identifier

svn: r14695
---
 collects/r6rs/main.ss                      |  9 +++++-
 collects/r6rs/private/identifier-syntax.ss | 15 +++++-----
 collects/r6rs/private/no-set.ss            | 33 ++++++++++++++++++++++
 collects/rnrs/base-6.ss                    |  7 +++--
 collects/rnrs/syntax-case-6.ss             | 11 ++++++--
 5 files changed, 62 insertions(+), 13 deletions(-)
 create mode 100644 collects/r6rs/private/no-set.ss

diff --git a/collects/r6rs/main.ss b/collects/r6rs/main.ss
index a2e9ea79c0..3cb88cbb92 100644
--- a/collects/r6rs/main.ss
+++ b/collects/r6rs/main.ss
@@ -9,7 +9,8 @@ FIXME:
 (require (for-syntax scheme/base
                      syntax/kerncase
                      "private/parse-ref.ss"
-                     scheme/provide-transform))
+                     scheme/provide-transform)
+         "private/no-set.ss")
 
 (provide (rename-out [module-begin #%module-begin]))
 
@@ -232,6 +233,12 @@ FIXME:
                                               orig
                                               ex)])))
                    exs)
+         (add-no-set!-identifiers (map (lambda (ex)
+                                         (syntax-case ex ()
+                                           [(rename (id ex-id))
+                                            #'id]
+                                           [id ex]))
+                                       exs))
          (with-syntax ([((ex ...) ...)
                         (map (lambda (ex)
                                (syntax-case ex ()
diff --git a/collects/r6rs/private/identifier-syntax.ss b/collects/r6rs/private/identifier-syntax.ss
index a84350f18a..dfc87c79e3 100644
--- a/collects/r6rs/private/identifier-syntax.ss
+++ b/collects/r6rs/private/identifier-syntax.ss
@@ -1,26 +1,27 @@
 #lang scheme/base
 (require (for-syntax scheme/base)
-         (for-template (only-in scheme/base set! #%app)))
+         (for-template "no-set.ss"
+                       (only-in scheme/base #%app set!)))
 
 (provide identifier-syntax)
 
 (define-syntax (identifier-syntax stx)
-  (syntax-case* stx (set!) (lambda (a b)
-                             (free-template-identifier=? a b))
+  (syntax-case* stx (r6rs:set!) (lambda (a b)
+                                  (free-template-identifier=? a b))
     [(identifier-syntax template)
      #'(...
         (make-set!-transformer
          (lambda (stx)
            (syntax-case stx (set!)
              [(set! . _) (raise-syntax-error
-                          #f
-                          "cannot assign to identifier macro"
-                          stx)]
+                               #f
+                               "cannot assign to identifier macro"
+                               stx)]
              [(_ arg ...) #'(template arg ...)]
              [_ #'template]))))]
     [(identifier-syntax
       [id1 template1]
-      [(set! id2 pat) template2])
+      [(r6rs:set! id2 pat) template2])
      (and (identifier? #'id1)
           (identifier? #'id2))
      #'(...
diff --git a/collects/r6rs/private/no-set.ss b/collects/r6rs/private/no-set.ss
new file mode 100644
index 0000000000..fe3b43b567
--- /dev/null
+++ b/collects/r6rs/private/no-set.ss
@@ -0,0 +1,33 @@
+#lang scheme/base
+(require (for-syntax scheme/base
+                     syntax/boundmap))
+
+(provide (for-syntax add-no-set!-identifiers)
+         r6rs:set!)
+
+;; Provided identifier cannot be `set!'ed. The list
+;; is relevant only within the module being compiled.
+(define-for-syntax no-set!-identifiers (make-free-identifier-mapping))
+
+(define-for-syntax (add-no-set!-identifiers ids)
+  (for ([id (in-list ids)])
+    (free-identifier-mapping-put! no-set!-identifiers id #t)))
+
+(define-for-syntax (no-set!-identifier? id)
+  (free-identifier-mapping-get no-set!-identifiers id (lambda () #f)))
+
+;; ----------------------------------------
+
+(define-syntax (r6rs:set! stx)
+  (syntax-case stx ()
+    [(_ id rhs)
+     (identifier? #'id)
+     (if (no-set!-identifier? #'id)
+         (raise-syntax-error
+          #f
+          "cannot mutate exported identifier"
+          stx
+          #'id)
+         (syntax/loc stx (set! id rhs)))]
+    [(_ . rest)
+     (syntax/loc stx (set! . rest))]))
diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss
index 40c4facd7a..998af489ba 100644
--- a/collects/rnrs/base-6.ss
+++ b/collects/rnrs/base-6.ss
@@ -7,6 +7,7 @@
          scheme/splicing
          r6rs/private/qq-gen
          r6rs/private/exns
+         r6rs/private/no-set
          (for-syntax r6rs/private/reconstruct)
          (prefix-in r5rs: r5rs)
          (only-in r6rs/private/readtable rx:number)
@@ -28,7 +29,7 @@
  (rename-out [r5rs:if if])
 
  ;; 11.4.4
- set!
+ (rename-out [r6rs:set! set!])
 
  ;; 11.4.5
  cond else => case
@@ -269,8 +270,8 @@
    (lambda (stx)
      (if (identifier? stx)
          (syntax/loc stx r6rs-/)
-         (syntax-case stx (set!)
-           [(set! . _)
+         (syntax-case stx (r6rs:set!)
+           [(r6rs:set! . _)
             (raise-syntax-error #f
                                 "cannot mutate imported identifier"
                                 stx)]
diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss
index 05f9e0bae9..03eb0af3c6 100644
--- a/collects/rnrs/syntax-case-6.ss
+++ b/collects/rnrs/syntax-case-6.ss
@@ -6,7 +6,9 @@
          scheme/mpair
          r6rs/private/exns
          (for-syntax syntax/template
-                     r6rs/private/check-pattern))
+                     r6rs/private/check-pattern)
+         (for-template (only-in scheme/base set!)
+                       r6rs/private/no-set))
 
 (provide make-variable-transformer
          (rename-out [r6rs:syntax-case syntax-case]
@@ -105,7 +107,12 @@
                               l)])))))
 
 (define (make-variable-transformer proc)
-  (make-set!-transformer proc))
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case* stx (set!) free-template-identifier=?
+       [(set! . rest)
+        (proc (syntax/loc stx (r6rs:set! . rest)))]
+       [else (proc stx)]))))
 
 (define unwrapped-tag (gensym))