From 2456dcc18b10a10a7bad3b1f9af8e33fad03231f Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Sun, 13 Jul 2008 17:31:58 -0400
Subject: [PATCH] Fix handling of mutable structs (setters != getters) Allow
 use of #:mutable as define-typed-struct arg Fix types of random andmap ormap

---
 collects/typed-scheme/private/base-env.ss    |  8 ++++----
 collects/typed-scheme/private/prims.ss       | 11 +++++++----
 collects/typed-scheme/private/tc-structs.ss  |  7 ++++---
 collects/typed-scheme/private/tc-toplevel.ss |  2 ++
 4 files changed, 17 insertions(+), 11 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 00c6d8e784..348d36af3c 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -105,8 +105,8 @@
      [read (cl-> 
             [(-Port) -Sexp]
             [() -Sexp])]
-     [ormap (-polydots (a b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))]
-     [andmap (-polydots (a b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))]
+     [ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
+     [andmap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
      [newline (cl-> [() -Void]
                     [(-Port) -Void])]
      [not (-> Univ B)]
@@ -256,8 +256,8 @@
                  [(-Pathlike (-> a) Sym) a]))]
      
      [random (cl->
-              [(N) N]
-              [() N])]
+              [(-Integer) -Integer]
+              [() -Integer])]
      
      [assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
      [assf  (-poly (a b)
diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss
index 2414b55290..5c838d631c 100644
--- a/collects/typed-scheme/private/prims.ss
+++ b/collects/typed-scheme/private/prims.ss
@@ -305,10 +305,13 @@ This file defines two sorts of primitives. All of them are provided into any mod
 (define-syntax (define-typed-struct stx)
   (syntax-case stx (:)
     [(_ nm ([fld : ty] ...) . opts)
-     (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
-                                         'typechecker:ignore #t)]
-                   [dtsi (internal (syntax/loc stx (define-typed-struct-internal nm ([fld : ty] ...))))])
-       #'(begin d-s dtsi))]
+     (let ([mutable (if (memq '#:mutable (syntax->datum #'opts))
+                        '(#:mutable)
+                        '())])
+       (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
+                                           'typechecker:ignore #t)]
+                     [dtsi (internal (quasisyntax/loc stx (define-typed-struct-internal nm ([fld : ty] ...) #,@mutable)))])
+         #'(begin d-s dtsi)))]
     [(_ (vars ...) nm ([fld : ty] ...) . opts)
      (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
                                          'typechecker:ignore #t)]
diff --git a/collects/typed-scheme/private/tc-structs.ss b/collects/typed-scheme/private/tc-structs.ss
index eeb760ee56..23c8a43038 100644
--- a/collects/typed-scheme/private/tc-structs.ss
+++ b/collects/typed-scheme/private/tc-structs.ss
@@ -129,7 +129,7 @@
                  (make-pred-ty (wrapper name))))
      (map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent)
      (if setters?
-         (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) getters external-fld-types/no-parent)
+         (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent)
          null)))
   (register-type-name nm (wrapper sty))
   (for/list ([e bindings])
@@ -171,7 +171,7 @@
 
 ;; typecheck a non-polymophic struct and register the approriate types
 ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
-(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f])
+(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f])
   ;; get the parent info and create some types and type variables
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
   ;; parse the field types, and determine if the type is recursive
@@ -186,7 +186,8 @@
                    ;; procedure
                    #:proc-ty proc-ty-parsed
                    #:maker maker
-		   #:constructor-return (and cret (parse-type cret))))
+		   #:constructor-return (and cret (parse-type cret))
+                   #:mutable mutable))
 
 ;; register a struct type
 ;; convenience function for built-in structs
diff --git a/collects/typed-scheme/private/tc-toplevel.ss b/collects/typed-scheme/private/tc-toplevel.ss
index e5f4fbbc13..b1b22e8791 100644
--- a/collects/typed-scheme/private/tc-toplevel.ss
+++ b/collects/typed-scheme/private/tc-toplevel.ss
@@ -54,6 +54,8 @@
       ;; define-typed-struct
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t)) 
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]