Properly handling immutable invariant structs.

original commit: 7df8e3279396e7483a5645603726afa5424a071a

collects/tests/typed-scheme/succeed/hari-vector-bug.rkt

@@ -0,0 +1,20 @@
+#lang typed/racket
+(define-struct: (A) Base ([prevbase : (Block A)]
+                          [elems : (Vectorof A)]))
+(define-struct: Mt ())
+
+(define-type-alias Block (All (A) (U Mt (Base A))))
+
+(: get-base : (All (A) ((Block A) -> (Base A))))
+(define (get-base block)
+ (if (Mt? block)
+     (error "" 'get-base)
+     (make-Base (Base-prevbase block)
+                (Base-elems block))))
+
+(: get-base2 : (All (A) ((Block A) -> (Base A))))
+(define (get-base2 block)
+ (if (Base? block)
+     (make-Base (Base-prevbase block)
+                (Base-elems block))
+     (error "" 'get-base)))

collects/typed-scheme/typecheck/tc-structs.rkt

@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require "../utils/utils.rkt" 
-	 (rep type-rep)
+	 (except-in (rep type-rep free-variance) Dotted)
          (private parse-type)
 	 (types convenience utils union resolve abbrev)
 	 (env type-env type-environments type-name-env)
@@ -131,6 +131,16 @@
   (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
   ;; the type name that is used in all the types
   (define name (type-wrapper (make-Name nm)))
+  ;; is this structure covariant in *all* arguments?
+  (define covariant? (if (and setters? poly?)
+                         #f
+                         (if poly?
+                             (for*/and ([var (in-list poly?)]
+                                        [t (in-list external-fld-types)])
+                               (let ([variance (hash-ref (free-vars* t) var Constant)])
+                                 (or (eq? variance Constant)
+                                     (eq? variance Covariant))))
+                             #t)))
   ;; the list of names w/ types
   (define bindings
     (append 
@@ -140,7 +150,7 @@
       (cons (or maker* maker)
             (wrapper (->* external-fld-types (if cret cret name))))
       (cons (or pred* pred)
-            (make-pred-ty (if (and setters? poly?)
+            (make-pred-ty (if (not covariant?)
                               (make-StructTop sty)
                               (pred-wrapper name)))))
      (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
@@ -190,7 +200,7 @@
                    #:wrapper (lambda (t) (make-Poly tvars t))
                    #:type-wrapper (lambda (t) (make-App t new-tvars #f))
                    #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (list t Univ)) t))
-                   #:poly? #t))
+                   #:poly? tvars))
 
 
 ;; typecheck a non-polymophic struct and register the approriate types

collects/typed-scheme/types/remove-intersect.rkt

@@ -56,10 +56,16 @@
          [(list (Struct: n _ flds _ _ _ _ _ _)
                 (Struct: n _ flds* _ _ _ _ _ _))
           (for/and ([f flds] [f* flds*]) (overlap f f*))]
+         [(list (Struct: n #f _ _ _ _ _ _ _)
+                (StructTop: (Struct: n #f _ _ _ _ _ _ _)))
+          #t]
          ;; n and n* must be different, so there's no overlap
          [(list (Struct: n #f flds _ _ _ _ _ _)
                 (Struct: n* #f flds* _ _ _ _ _ _))
           #f]
+         [(list (Struct: n #f flds _ _ _ _ _ _)
+                (StructTop: (Struct: n* #f flds* _ _ _ _ _ _)))
+          #f]
          [(list (Struct: n p flds _ _ _ _ _ _)
                 (Struct: n* p* flds* _ _ _ _ _ _))
           (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))]