From fba3c3b9ca74f8adc5acc2f6539837aec05e5a3f Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 8 Sep 2010 10:46:44 -0400
Subject: [PATCH] Propogate #:mutable for polymorphic structs.

 Closes PR 11127

original commit: a0e77705e578927e5d8180e6bc811461173580ab
---
 .../typed-scheme/succeed/mutable-poly-struct.rkt   |  9 +++++++++
 collects/typed-scheme/private/prims.rkt            | 14 ++++++++------
 collects/typed-scheme/typecheck/tc-toplevel.rkt    |  7 +++++++
 3 files changed, 24 insertions(+), 6 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt

diff --git a/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt b/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt
new file mode 100644
index 00000000..4c1f16bd
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt
@@ -0,0 +1,9 @@
+#lang typed/racket
+
+(define-struct: (A) X ([b : A]) #:mutable)
+
+set-X-b!
+
+(struct: (A) Foo ([x : Integer]) #:mutable)
+(define x (Foo 10))
+(set-Foo-x! x 100)
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index c30c9419..8abe9f81 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -347,10 +347,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
                           [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
               #'(begin d-s dtsi)))]
          [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
-          (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
-                                              'typechecker:ignore #t)]
-                        [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))])
-            #'(begin d-s dtsi))]))
+          (let ([mutable (mutable? #'opts)])
+            (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
+                                                'typechecker:ignore #t)]
+                          [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm (fs ...)  #,@mutable))])
+              #'(begin d-s dtsi)))]))
      (lambda (stx)
        (syntax-parse stx
          [(_ nm:struct-name/new (fs:fld-spec ...) . opts)
@@ -364,13 +365,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
                           [dtsi (quasisyntax/loc stx (dtsi* () nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
               #'(begin d-s dtsi)))]
          [(_ (vars:id ...) nm:struct-name/new (fs:fld-spec ...) . opts)
-          (let ([cname (datum->syntax #f (syntax-e #'nm.name))])
+          (let ([cname (datum->syntax #f (syntax-e #'nm.name))]
+                [mutable (mutable? #'opts)])
             (with-syntax ([d-s (syntax-property (quasisyntax/loc stx 
                                                   (struct #,@(attribute nm.new-spec) (fs.fld ...)
                                                           #:extra-constructor-name #,cname
                                                           . opts))
                                                 'typechecker:ignore #t)]
-                          [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname))])
+                          [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
               #'(begin d-s dtsi)))])))))
 
 (define-syntax (require-typed-struct stx)
diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt
index bb330b89..011410fd 100644
--- a/collects/typed-scheme/typecheck/tc-toplevel.rkt
+++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt
@@ -107,10 +107,17 @@
                                 (#%plain-app values)))
        (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
                        #:maker #'m)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...)
+						#:maker m #:mutable)) 
+                                (#%plain-app values)))
+       (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
+                       #:maker #'m #:mutable #t)]
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
       ;; define-typed-struct w/ polymorphism
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
+       (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]
       [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values)))
        (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
       ;; error in other cases