R6RS: disallow assignment to exported identifier

svn: r14695

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 ()

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)
+  (syntax-case* stx (r6rs:set!) (lambda (a b)
-                             (free-template-identifier=? a b))
+                                  (free-template-identifier=? a b))
     [(identifier-syntax template)
      #'(...
         (make-set!-transformer
          (lambda (stx)
            (syntax-case stx (set!)
              [(set! . _) (raise-syntax-error
-                          #f
+                               #f
-                          "cannot assign to identifier macro"
+                               "cannot assign to identifier macro"
-                          stx)]
+                               stx)]
              [(_ arg ...) #'(template arg ...)]
              [_ #'template]))))]
     [(identifier-syntax
       [id1 template1]
-      [(set! id2 pat) template2])
+      [(r6rs:set! id2 pat) template2])
      (and (identifier? #'id1)
           (identifier? #'id2))
      #'(...

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))]))

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!)
+         (syntax-case stx (r6rs:set!)
-           [(set! . _)
+           [(r6rs:set! . _)
             (raise-syntax-error #f
                                 "cannot mutate imported identifier"
                                 stx)]

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))