From 6130f3551c1019c1bc035d802378c29bf574a0c1 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 7 Sep 2010 10:39:13 -0400
Subject: [PATCH] Fix polymorphic structs with mutability.

---
 .../typed-scheme/private/type-contract.rkt    | 35 ++++++++++---------
 .../typed-scheme/typecheck/tc-structs.rkt     |  3 +-
 2 files changed, 20 insertions(+), 18 deletions(-)

diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt
index 2e7d7aba92..6fcf80a974 100644
--- a/collects/typed-scheme/private/type-contract.rkt
+++ b/collects/typed-scheme/private/type-contract.rkt
@@ -117,7 +117,9 @@
         [(Univ:) (if from-typed? #'any-wrap/c #'any/c)]
         ;; we special-case lists:
         [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
-         #`(listof #,(t->c elem-ty))]
+         (if (and (not from-typed?) (type-equal? elem-ty t:Univ))
+             #'list?
+             #`(listof #,(t->c elem-ty)))]
         [(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?]
         [(Base: sym cnt) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))]
         [(Refinement: par p? cert)
@@ -168,7 +170,6 @@
                        [(name ...) name]
                        [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))]
                        [(by-name-init ...) by-name-init])
-           #;#'class?           
            #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
         [(Value: '()) #'null?]
         [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id)
@@ -185,21 +186,21 @@
                             (for/list ([fty flds]
                                        [f-acc acc-ids]
                                        [m? mut?])
-                              #`(((contract-projection
-                                   #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
-                                  blame)
-                                 (#,f-acc val)))])
-              #`(letrec ([rec 
-                          (make-contract 
-                           #:name 'cnt-name
-                           #:first-order #,pred?
-                           #:projection 
-                           (lambda (blame)
-                             (lambda (val)
-                               (unless (#,pred? val)
-                                 (raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
-                               (maker fld-cnts ...))))])
-                  rec))]
+                #`(((contract-projection
+                     #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen)))
+                    blame)
+                   (#,f-acc val)))])
+                #`(letrec ([rec 
+                            (make-contract 
+                             #:name 'cnt-name
+                             #:first-order #,pred?
+                             #:projection 
+                             (lambda (blame)
+                               (lambda (val)
+                                 (unless (#,pred? val)
+                                   (raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val))
+                                 (maker fld-cnts ...))))])
+                    rec))]
            [else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])]
         [(Syntax: (Base: 'Symbol _)) #'identifier?]
         [(Syntax: t) #`(syntax/c #,(t->c t))]
diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt
index c43bce64cb..5a9bfec91c 100644
--- a/collects/typed-scheme/typecheck/tc-structs.rkt
+++ b/collects/typed-scheme/typecheck/tc-structs.rkt
@@ -211,7 +211,7 @@
 
 ;; check and register types for a polymorphic define struct
 ;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
-(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f])
+(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f] #:mutable [mutable #f])
   ;; parent field types can't actually be determined here
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
   ;; create type variables for the new type parameters
@@ -236,6 +236,7 @@
   ;; then register them
   (mk/register-sty nm flds parent-name parent-field-types types
                    #:maker maker
+                   #:mutable mutable
                    ;; wrap everything in the approriate forall
                    #:wrapper (λ (t) (make-Poly tvars t))
                    #:type-wrapper (λ (t) (make-App t new-tvars #f))