diff --git a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt b/collects/tests/typed-scheme/fail/all-bad-syntax.rkt
index c076f4d3..daf10f54 100644
--- a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt
+++ b/collects/tests/typed-scheme/fail/all-bad-syntax.rkt
@@ -1,5 +1,5 @@
 #;
-(exn-pred 1)
+(exn-pred 2)
 #lang typed-scheme
 
 (require scheme/list)
@@ -22,4 +22,4 @@
                         (list key)
                         (rt)))
               #;empty))
-(+ 'foo)
\ No newline at end of file
+(+ 'foo)
diff --git a/collects/tests/typed-scheme/fail/inexact-complex.rkt b/collects/tests/typed-scheme/fail/inexact-complex.rkt
new file mode 100644
index 00000000..1619911c
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/inexact-complex.rkt
@@ -0,0 +1,9 @@
+#;
+(exn-pred 2)
+#lang typed/scheme
+
+(ann 1+2i Inexact-Complex)
+
+(: f (Real -> Inexact-Complex))
+(define (f x)
+  (* x 2.0)) ; x can be exact 0
diff --git a/collects/tests/typed-scheme/fail/multi-arr-parse.rkt b/collects/tests/typed-scheme/fail/multi-arr-parse.rkt
new file mode 100644
index 00000000..10e1171c
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/multi-arr-parse.rkt
@@ -0,0 +1,6 @@
+#;
+(exn-pred #rx".*once in a form.*")
+#lang typed/scheme
+
+(: foo : (Integer -> Integer -> Integer))
+(define foo 1)
diff --git a/collects/tests/typed-scheme/fail/nonnegative-float.rkt b/collects/tests/typed-scheme/fail/nonnegative-float.rkt
new file mode 100644
index 00000000..ac797481
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/nonnegative-float.rkt
@@ -0,0 +1,5 @@
+#;
+(exn-pred 1)
+#lang typed/scheme
+
+(ann (- 1.0 0.5) Nonnegative-Float) ; can't prove it's nonnegative
diff --git a/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt b/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt
new file mode 100644
index 00000000..e4734368
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt
@@ -0,0 +1,19 @@
+#;
+(exn-pred 7)
+#lang typed/scheme
+(require racket/unsafe/ops)
+
+(define-struct: foo ((x : Integer) (y : String)))
+(define-struct: (bar foo) ((z : Float)))
+
+(define a (make-foo 1 "1"))
+(define b (make-bar 2 "2" 2.0))
+
+(+ (unsafe-struct-ref a 1) 2)
+(+ (unsafe-struct-ref b 1) 2)
+
+(unsafe-struct-set! a 0 "2")
+(unsafe-struct-set! a 1 2)
+(unsafe-struct-set! b 0 3.0)
+(unsafe-struct-set! b 1 3)
+(unsafe-struct-set! b 2 "3")
diff --git a/collects/tests/typed-scheme/fail/unsafe-struct.rkt b/collects/tests/typed-scheme/fail/unsafe-struct.rkt
new file mode 100644
index 00000000..a185937b
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/unsafe-struct.rkt
@@ -0,0 +1,13 @@
+#;
+(exn-pred 3)
+#lang typed/scheme
+(require racket/unsafe/ops)
+
+(define-struct: x ((a : Integer) (b : String)) #:mutable)
+
+(define x1 (make-x 1 "1"))
+
+(+ (unsafe-struct-ref x1 1) 1)
+
+(unsafe-struct-set! x1 0 "2")
+(unsafe-struct-set! x1 1 1)
diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt
index 96fb394b..9fb96757 100644
--- a/collects/tests/typed-scheme/main.rkt
+++ b/collects/tests/typed-scheme/main.rkt
@@ -5,12 +5,12 @@
 (require rackunit rackunit/text-ui
          mzlib/etc scheme/port
          compiler/compiler
-         scheme/match
+         scheme/match mzlib/compile
          "unit-tests/all-tests.ss"
          "unit-tests/test-utils.ss")
 
 (define (scheme-file? s)
-  (regexp-match ".*[.](rkt|ss|scm)" (path->string s)))
+  (regexp-match ".*[.](rkt|ss|scm)$" (path->string s)))
 
 (define-namespace-anchor a)
 
@@ -23,9 +23,13 @@
                          [(number? e)
                           (and (exn:fail:syntax? val)
                                (= e (length (exn:fail:syntax-exprs val))))]
-                         [else                          
-                          (regexp-match e (exn-message val))]))))
+                         [(or (string? e) (regexp? e))
+                          (regexp-match e (exn-message val))]
+                         [else (error 'exn-pred "bad argument" e)]))))
    args))
+
+(define (cfile file)
+  ((compile-zos #f) (list file) 'auto))
   
 (define (exn-pred p)
   (let ([sexp (with-handlers
@@ -61,9 +65,8 @@
     (make-test-suite dir tests)))
 
 (define (dr p)
-  #;((compile-zos #f) (list p) 'auto)
   (parameterize ([current-namespace (make-base-empty-namespace)])    
-    (dynamic-require `(file ,(path->string p)) #f)))
+    (dynamic-require `(file ,(if (string? p) p (path->string p))) #f)))
 
 (define succ-tests (mk-tests "succeed" 
                              dr
@@ -86,10 +89,54 @@
   (test-suite "Typed Scheme Tests"
               unit-tests int-tests))
 
-(define (go [unit? #f]) (test/gui (if unit? unit-tests tests)))
-(define (go/text [unit? #f]) (run-tests (if unit? unit-tests tests) 'verbose))
+(provide tests int-tests unit-tests)
 
-(provide go go/text)
+(define (go tests) (test/gui tests))
+(define (go/text tests) (run-tests tests 'verbose))
+
+(define (just-one p*)
+  (define-values (path p b) (split-path p*))
+  (define f
+    (if (equal? "fail/" (path->string path))
+        (lambda (p thnk)
+          (define-values (pred info) (exn-pred p))
+          (parameterize ([error-display-handler void])
+            (with-check-info
+             (['predicates info])
+             (check-exn pred thnk))))
+        (lambda (p thnk) (check-not-exn thnk))))
+  (test-suite 
+   (path->string p)
+   (f
+    (build-path path p)
+    (lambda ()
+      (parameterize ([read-accept-reader #t]
+                     [current-load-relative-directory
+                      (path->complete-path path)]
+                     [current-directory path]
+                     [current-output-port (open-output-nowhere)])
+        (dr p))))))
+
+(define (compile-benchmarks)
+  (define (find dir)
+    (for/list ([d (directory-list dir)]
+               #:when (scheme-file? d))
+      d))
+  (define shootout (collection-path "tests" "racket" "benchmarks" "shootout" "typed"))
+  (define common (collection-path "tests" "racket" "benchmarks" "common" "typed"))
+  (define (mk path)
+    (make-test-suite (path->string path)
+                     (for/list ([p (find path)])                       
+                       (parameterize ([current-load-relative-directory
+                                       (path->complete-path path)]
+                                      [current-directory path])
+                         (test-suite (path->string p)
+                                     (check-not-exn (λ () (cfile (build-path path p)))))))))
+  (test-suite "compiling"
+              (mk shootout)
+              (mk common)))
+
+(provide go go/text just-one compile-benchmarks)
 
 
 
diff --git a/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt
new file mode 100644
index 00000000..a3bb961e
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt
@@ -0,0 +1,4 @@
+(module begin-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (begin (- 2.0 3.0)
+         (* 2.0 3.0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt
new file mode 100644
index 00000000..6c1dcba3
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt
@@ -0,0 +1,5 @@
+(module binary-fixnum typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f (All (X) ((Vectorof X) -> Natural)))
+  (define (f v)
+    (bitwise-and (vector-length v) 1)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt
new file mode 100644
index 00000000..0e5c46a6
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt
@@ -0,0 +1,3 @@
+(module binary-nonzero-fixnum typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (quotient (vector-length '#(1 2 3)) 2))
diff --git a/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt
new file mode 100644
index 00000000..508bd0e5
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt
@@ -0,0 +1,4 @@
+(module define-begin-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define a (begin (display (- 2.0 3.0))
+                   (* 2.0 3.0))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt
new file mode 100644
index 00000000..fe2ff165
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt
@@ -0,0 +1,3 @@
+(module define-call-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (cons (+ 1.0 2.0) 3.0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/define-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-float.rkt
new file mode 100644
index 00000000..9dfeb431
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/define-float.rkt
@@ -0,0 +1,3 @@
+(module define-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (+ 1.0 2.0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt b/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt
new file mode 100644
index 00000000..ec30e20c
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt
@@ -0,0 +1,3 @@
+(module define-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (car '(1 3))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt b/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt
new file mode 100644
index 00000000..9754b392
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt
@@ -0,0 +1,4 @@
+;; to see if the harness supports having the 2 versions of a test being
+;; written in different languages
+(module different-langs typed/scheme #:optimize
+  (+ 1 2))
diff --git a/collects/tests/typed-scheme/optimizer/generic/double-float.rkt b/collects/tests/typed-scheme/optimizer/generic/double-float.rkt
new file mode 100644
index 00000000..1d686451
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/double-float.rkt
@@ -0,0 +1,3 @@
+(module double-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 2.0 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt
new file mode 100644
index 00000000..f19e3812
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt
@@ -0,0 +1,3 @@
+(module exact-inexact typed/scheme #:optimize
+  (require racket/flonum)
+  (exact->inexact (expt 10 100))) ; must not be a fixnum
diff --git a/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt b/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt
new file mode 100644
index 00000000..905b4c8b
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt
@@ -0,0 +1,3 @@
+(module fixnum-comparison typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (< (vector-length '#(1 2 3)) (string-length "asdf")))
diff --git a/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt b/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt
new file mode 100644
index 00000000..d644a1c9
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt
@@ -0,0 +1,3 @@
+(module float-comp typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (< 1.0 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt b/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt
new file mode 100644
index 00000000..788a2181
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt
@@ -0,0 +1,5 @@
+(module float-fun typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f (Float -> Float))
+  (define (f x)
+    (+ x 1.0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt
new file mode 100644
index 00000000..1fc32fa9
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt
@@ -0,0 +1,4 @@
+(module float-promotion typed/scheme #:optimize
+  (require racket/unsafe/ops racket/flonum)
+  (+ 1 2.0)
+  (+ (expt 100 100) 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt
new file mode 100644
index 00000000..34add429
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt
@@ -0,0 +1,3 @@
+(module flvector-length typed/scheme #:optimize
+  (require racket/unsafe/ops racket/flonum)
+  (flvector-length (flvector 0.0 1.2)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt
new file mode 100644
index 00000000..ee505dfd
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt
@@ -0,0 +1,3 @@
+(module fx-fl typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (exact->inexact 1))
diff --git a/collects/tests/typed-scheme/optimizer/generic/in-list.rkt b/collects/tests/typed-scheme/optimizer/generic/in-list.rkt
new file mode 100644
index 00000000..6d9dde83
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/in-list.rkt
@@ -0,0 +1,4 @@
+(module in-list typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (for: ((i : Natural '(1 2 3)))
+    (display i)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt
new file mode 100644
index 00000000..e1e94c47
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt
@@ -0,0 +1,4 @@
+(module invalid-binary-nonzero-fixnum typed/scheme #:optimize
+  (: f ( -> Void))
+  (define (f) ; in a function, to prevent evaluation
+    (display (quotient 4 0)))) ; 2 fixnums, but the second is 0, cannot optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt
new file mode 100644
index 00000000..f0fec025
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt
@@ -0,0 +1,2 @@
+(module exact-inexact typed/scheme #:optimize
+  (exact->inexact 1.0)) ; not an integer, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt
new file mode 100644
index 00000000..1f972d6b
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt
@@ -0,0 +1,3 @@
+(module float-comp typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (< 1.0 2))
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt
new file mode 100644
index 00000000..169909be
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt
@@ -0,0 +1,2 @@
+(module float-promotion typed/scheme #:optimize
+  (/ 1 2.0)) ; result is not a float, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt
new file mode 100644
index 00000000..b0a2ab9d
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt
@@ -0,0 +1,2 @@
+(module invalid-inexact-complex-parts.rkt typed/scheme #:optimize
+  (real-part 1+2i))
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt
new file mode 100644
index 00000000..ce166151
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt
@@ -0,0 +1,2 @@
+(module invalid-make-flrectangular typed/scheme #:optimize
+  (make-rectangular 1 2))
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt
new file mode 100644
index 00000000..39b0336c
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt
@@ -0,0 +1,2 @@
+(module invalid-sqrt typed/scheme #:optimize
+  (sqrt -2.0)) ; not a nonnegative flonum, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt
new file mode 100644
index 00000000..74714405
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt
@@ -0,0 +1,4 @@
+(module invalid-vector-ref typed/scheme #:optimize
+  (: f ((Vectorof Integer) -> Integer))
+  (define (f x)
+    (vector-ref x 0))) ; type is (Vectorof Integer), length is unknown, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt
new file mode 100644
index 00000000..b02fbdc0
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt
@@ -0,0 +1,4 @@
+(module invalid-vector-set typed/scheme #:optimize
+  (: f ((Vectorof Integer) -> Void))
+  (define (f x)
+    (vector-set! x 0 2))) ; type is (Vectorof Integer), length is ot known, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt
new file mode 100644
index 00000000..083d8730
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt
@@ -0,0 +1,3 @@
+(module known-vector-length typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2 (vector-length (ann (vector 1 2) (Vector Integer Integer)))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/let-float.rkt b/collects/tests/typed-scheme/optimizer/generic/let-float.rkt
new file mode 100644
index 00000000..98e6a9fe
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/let-float.rkt
@@ -0,0 +1,4 @@
+(module let-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (let ((x (+ 3.0 2.0)))
+    (* 9.0 x)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt
new file mode 100644
index 00000000..b9250d0e
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt
@@ -0,0 +1,4 @@
+(module make-flrectangular typed/scheme #:optimize
+  (require racket/unsafe/ops racket/flonum)
+  (make-rectangular 1.0 2.2)
+  (make-flrectangular 1.0 2.2))
diff --git a/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt
new file mode 100644
index 00000000..54b59581
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt
@@ -0,0 +1,3 @@
+(module n-ary-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 1.0 2.0 3.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt
new file mode 100644
index 00000000..04950423
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt
@@ -0,0 +1,3 @@
+(module nested-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 (+ 3.0 4.0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt
new file mode 100644
index 00000000..ebe30a18
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt
@@ -0,0 +1,3 @@
+(module nested-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 (* 3.0 4.0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt
new file mode 100644
index 00000000..744d0c83
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt
@@ -0,0 +1,3 @@
+(module nested-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (car (cdr '(1 2))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt
new file mode 100644
index 00000000..a4c429d1
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt
@@ -0,0 +1,3 @@
+(module nested-pair2 typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (car (cdr (cons 3 (cons (cons 2 '()) 1)))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt b/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt
new file mode 100644
index 00000000..2fea5497
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt
@@ -0,0 +1,7 @@
+(module pair-fun typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f ((Listof Integer) -> Integer))
+  (define (f x)
+    (if (null? x)
+        1
+        (car x))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/quote.rkt b/collects/tests/typed-scheme/optimizer/generic/quote.rkt
new file mode 100644
index 00000000..2d62416f
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/quote.rkt
@@ -0,0 +1,2 @@
+(module quote typed/scheme #:optimize
+  '(+ 1.0 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt
new file mode 100644
index 00000000..90676b7a
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt
@@ -0,0 +1,3 @@
+(module simple-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 3.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt
new file mode 100644
index 00000000..e5f69f70
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt
@@ -0,0 +1,3 @@
+(module simple-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (car (cons 1 2)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt
new file mode 100644
index 00000000..411ff900
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt
@@ -0,0 +1,5 @@
+(module sqrt typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f (Nonnegative-Float -> Nonnegative-Float))
+  (define (f x)
+    (sqrt x)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/structs.rkt b/collects/tests/typed-scheme/optimizer/generic/structs.rkt
new file mode 100644
index 00000000..4fb39c9d
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/structs.rkt
@@ -0,0 +1,6 @@
+(module structs typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define-struct: pt ((x : Integer) (y : Integer)) #:mutable)
+  (define a (pt 3 4))
+  (pt-x a)
+  (set-pt-y! a 5))
diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt
new file mode 100644
index 00000000..710197af
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt
@@ -0,0 +1,3 @@
+(module unary-fixnum-nested typed/scheme #:optimize
+  (require racket/unsafe/ops racket/fixnum)
+  (abs (bitwise-not (length '(1 2 3)))))
diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt
new file mode 100644
index 00000000..b9309084
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt
@@ -0,0 +1,3 @@
+(module unary-fixnum typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (bitwise-not 4))
diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt
new file mode 100644
index 00000000..d57f3950
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt
@@ -0,0 +1,3 @@
+(module float-unary typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (sin 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt
new file mode 100644
index 00000000..ade363e1
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt
@@ -0,0 +1,7 @@
+(module vector-length typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-length
+   (vector-ref
+    (ann (vector (vector 1 2) 2 3)
+         (Vector (Vectorof Integer) Integer Integer))
+    0)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt
new file mode 100644
index 00000000..51093a09
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt
@@ -0,0 +1,3 @@
+(module vector-length typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-length (vector 1 2 3)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt
new file mode 100644
index 00000000..711633ea
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt
@@ -0,0 +1,7 @@
+(module vector-ref-set-ref typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: x (Vector Integer String))
+  (define x (vector 1 "1"))
+  (vector-ref x 0)
+  (vector-set! x 1 "2")
+  (vector-ref x 1))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt
new file mode 100644
index 00000000..00261f8a
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt
@@ -0,0 +1,3 @@
+(module vector-ref typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-ref (ann (vector 1 2) (Vector Integer Integer)) 0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt
new file mode 100644
index 00000000..434fa07c
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt
@@ -0,0 +1,3 @@
+(module vector-ref2 typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-ref (vector 1 2 3) 0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt
new file mode 100644
index 00000000..063b78d3
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt
@@ -0,0 +1,5 @@
+(module vector-set-quote typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-set! (ann (vector '(1 2)) (Vector Any))
+               0
+               '(+ 1.0 2.0))) ; we should not optimize under quote
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt
new file mode 100644
index 00000000..5f29aa5e
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt
@@ -0,0 +1,5 @@
+(module vector-set typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-set! (ann (vector 1 2) (Vector Integer Integer))
+               0
+               1))
diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt
new file mode 100644
index 00000000..910575d5
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt
@@ -0,0 +1,3 @@
+(module invalid-vector-set typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (vector-set! (vector 1 2) 0 2)) ; type is (Vectorof Integer), length is ot known, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt
new file mode 100644
index 00000000..b4139e25
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/run.rkt
@@ -0,0 +1,44 @@
+#lang racket
+(require racket/runtime-path)
+
+;; since Typed Scheme's optimizer does source to source transformations,
+;; we compare the expansion of automatically optimized and hand optimized
+;; modules
+(define (read-and-expand file)
+  ;; drop the type tables added by typed scheme, since they can be in a
+  ;; different order each time, and that would make tests fail when they
+  ;; shouldn't
+  (filter
+   ;; drop the "module", its name and its language, so that we can write
+   ;; the 2 versions of each test in different languages (typed and
+   ;; untyped) if need be
+   (match-lambda [(list 'define-values-for-syntax '() _ ...) #f] [_ #t])
+   (cadddr
+    (syntax->datum
+     (parameterize ([current-namespace (make-base-namespace)])
+       (with-handlers
+           ([exn:fail? (lambda (exn)
+                         (printf "~a\n" (exn-message exn))
+                         #'(#f #f #f (#f)))]) ; for cadddr
+         (expand (with-input-from-file file read-syntax))))))))
+
+(define (test gen)
+  (let-values (((base name _) (split-path gen)))
+    (or (regexp-match ".*~" name) ; we ignore backup files
+        (equal? (read-and-expand gen)
+                (read-and-expand (build-path base "../hand-optimized/" name)))
+        (begin (printf "~a failed\n\n" name)
+               #f))))
+
+(define-runtime-path here ".")
+
+(let ((n-failures
+       (if (> (vector-length (current-command-line-arguments)) 0)
+           (if (test (format "generic/~a.rkt"
+                             (vector-ref (current-command-line-arguments) 0)))
+               0 1)
+           (for/fold ((n-failures 0))
+             ((gen (in-directory (build-path here "generic"))))
+             (+ n-failures (if (test gen) 0 1))))))
+  (unless (= n-failures 0)
+    (error (format "~a tests failed." n-failures))))
diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt
index f2ff3c10..0266f180 100644
--- a/collects/tests/typed-scheme/run.rkt
+++ b/collects/tests/typed-scheme/run.rkt
@@ -1,7 +1,37 @@
-#lang racket/base
-(require racket/vector)
+#lang racket
+(require racket/vector racket/gui/dynamic)
 
 (require "main.ss")
+
+(define exec (make-parameter go/text))
+(define the-tests (make-parameter tests))
+(define skip-all? #f)
+(define nightly? (make-parameter #f))
+(define opt? (make-parameter #f))
+(define bench? (make-parameter #f))
 (current-namespace (make-base-namespace))
-(unless (= 0 (go/text (vector-member "unit" (current-command-line-arguments))))
-  (error "Typed Scheme Tests did not pass."))
+(command-line
+ #:once-each
+ ["--unit" "run just the unit tests" (the-tests unit-tests)]
+ ["--int" "run just the integration tests" (the-tests int-tests)]
+ ["--nightly" "for the nightly builds" (nightly? #t)]
+ ["--just" path "run only this test" (the-tests (just-one path))]
+ ["--opt" "run the optimizer tests" (opt? #t)]
+ ["--benchmarks" "compile the typed benchmarks" (bench? #t)]
+ ["--gui" "run using the gui" 
+          (if (gui-available?)
+              (begin (exec go))
+              (error "GUI not available"))]
+ )
+
+(cond [(and (nightly?) (eq? 'cgc (system-type 'gc)))
+       (printf "Skipping Typed Racket tests.\n")]
+      [(unless (= 0 ((exec) (the-tests)))
+         (error "Typed Racket Tests did not pass."))
+       (when (opt?)
+         (parameterize ([current-command-line-arguments #()])
+           (dynamic-require '(file "optimizer/run.rkt") #f))
+         (printf "Typed Racket Optimizer tests passed"))
+       (when (bench?)
+         (unless (= 0 ((exec) (compile-benchmarks)))
+           (error "Typed Racket Tests did not pass.")))])
diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt b/collects/tests/typed-scheme/succeed/apply-dots-list.rkt
index 85af5196..ec5c25fe 100644
--- a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt
+++ b/collects/tests/typed-scheme/succeed/apply-dots-list.rkt
@@ -1,4 +1,3 @@
-
 ;; Change the lang to scheme for untyped version
 #lang typed-scheme
 
diff --git a/collects/tests/typed-scheme/fail/dotted-identity.rkt b/collects/tests/typed-scheme/succeed/dotted-identity2.rkt
similarity index 100%
rename from collects/tests/typed-scheme/fail/dotted-identity.rkt
rename to collects/tests/typed-scheme/succeed/dotted-identity2.rkt
diff --git a/collects/tests/typed-scheme/succeed/for-ann.rkt b/collects/tests/typed-scheme/succeed/for-ann.rkt
new file mode 100644
index 00000000..a400999a
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/for-ann.rkt
@@ -0,0 +1,3 @@
+#lang typed/racket
+
+(ann (for ([#{i : Integer} '(1 2 3)]) (display i)) Void)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/for-in-range.rkt b/collects/tests/typed-scheme/succeed/for-in-range.rkt
new file mode 100644
index 00000000..213e14dd
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/for-in-range.rkt
@@ -0,0 +1,3 @@
+#lang typed/racket
+
+(for: ([i : Integer (in-range 10 0 -1)]) i)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/for-seq.rkt b/collects/tests/typed-scheme/succeed/for-seq.rkt
new file mode 100644
index 00000000..a5e11bea
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/for-seq.rkt
@@ -0,0 +1,19 @@
+#lang typed/racket
+
+(: Approximate (Natural -> Void))
+(define (Approximate n) ; works
+ (for: : Void ([i : Integer (in-range 10)])
+     (display i)))
+
+(for: : Void ((i : Integer (ann '(1 2 3) (Sequenceof Integer))) ; doesn't
+             (j : Char "abc"))
+     (display (list i j)))
+
+
+(for: : Void ; doesn't
+     ([from-to : (List Symbol Symbol)
+               (ann '([a t] [c g]) (Sequenceof (List Symbol Symbol)))])
+     #t)
+
+
+(for/list: : (Listof Integer) ([i : Integer (in-range 10)]) i) ; works
diff --git a/collects/tests/typed-scheme/succeed/for.rkt b/collects/tests/typed-scheme/succeed/for.rkt
index cdd22c1c..5569e268 100644
--- a/collects/tests/typed-scheme/succeed/for.rkt
+++ b/collects/tests/typed-scheme/succeed/for.rkt
@@ -18,7 +18,7 @@
        (with-output-to-string
          (lambda ()
            (for: : Void
-                 ((i : Exact-Positive-Integer '(1 2 3))
+                 ((i : Integer '(1 2 3))
                   (j : Char "abc")
                   #:when (odd? i)
                   (k : True #(#t #t))
@@ -32,22 +32,22 @@
 
 (check equal?
        (for/list: : (Listof Integer)
-                  ((i : Exact-Positive-Integer '(1 2 3))
-                   (j : Exact-Positive-Integer '(10 20 30))
+                  ((i : Integer '(1 2 3))
+                   (j : Integer '(10 20 30))
                    #:when (odd? i))
                   (+ i j 10))
        '(21 43))
 
 (check equal?
        (for/or: : Boolean
-                ((i : Exact-Positive-Integer '(1 2 3)))
+                ((i : Integer '(1 2 3)))
                 (>= i 3))
        #t)
 
 (check equal?
        (for/or: : Boolean
-                ((i : Exact-Positive-Integer '(1 2 3))
-                 (j : Exact-Positive-Integer '(2 1 3)))
+                ((i : Integer '(1 2 3))
+                 (j : Integer '(2 1 3)))
                 (>= i j))
        #t)
 
@@ -56,9 +56,9 @@
                       (for/lists: : (values (Listof Integer) (Listof Integer))
                                   ((x : (Listof Integer))
                                    (y : (Listof Integer)))
-                                  ((i : Exact-Positive-Integer '(1 2 3))
+                                  ((i : Integer '(1 2 3))
                                    #:when #t
-                                   (j : Exact-Positive-Integer '(10 20 30))
+                                   (j : Integer '(10 20 30))
                                    #:when (> j 12))
                                   (values i j))])
                     (append x y))
@@ -67,19 +67,19 @@
 (check =
        (for/fold: : Integer
                   ((acc : Integer 0))
-                  ((i : Exact-Positive-Integer '(1 2 3))
-                   (j : Exact-Positive-Integer '(10 20 30)))
+                  ((i : Integer '(1 2 3))
+                   (j : Integer '(10 20 30)))
                   (+ acc i j))
        66)
 
 (check =
        (for/fold: : Integer
                   ((acc : Integer 0))
-                  ((i : Exact-Positive-Integer '(1 2 3))
+                  ((i : Integer '(1 2 3))
                    #:when (even? i)
-                   (j : Exact-Positive-Integer '(10 20 30))
+                   (j : Integer '(10 20 30))
                    #:when #t
-                   (k : Exact-Positive-Integer '(100 200 300)))
+                   (k : Integer '(100 200 300)))
                   (+ acc i j k))
        1998)
 
@@ -87,8 +87,8 @@
        (with-output-to-string
          (lambda ()
            (for*: : Void
-                  ((i : Exact-Positive-Integer '(1 2 3))
-                   (j : Exact-Positive-Integer '(10 20 30)))
+                  ((i : Integer '(1 2 3))
+                   (j : Integer '(10 20 30)))
                   (display (list i j)))))
        "(1 10)(1 20)(1 30)(2 10)(2 20)(2 30)(3 10)(3 20)(3 30)")
 
@@ -97,8 +97,8 @@
                       (for*/lists: : (values (Listof Integer) (Listof Integer))
                                    ((x : (Listof Integer))
                                     (y : (Listof Integer)))
-                                   ((i : Exact-Positive-Integer '(1 2 3))
-                                    (j : Exact-Positive-Integer '(10 20 30))
+                                   ((i : Integer '(1 2 3))
+                                    (j : Integer '(10 20 30))
                                     #:when (> j 12))
                                    (values i j))])
                     (append x y))
@@ -107,9 +107,9 @@
 (check =
        (for*/fold: : Integer
                    ((acc : Integer 0))
-                   ((i : Exact-Positive-Integer '(1 2 3))
+                   ((i : Integer '(1 2 3))
                     #:when (even? i)
-                    (j : Exact-Positive-Integer '(10 20 30))
-                    (k : Exact-Positive-Integer '(100 200 300)))
+                    (j : Integer '(10 20 30))
+                    (k : Integer '(100 200 300)))
                    (+ acc i j k))
        1998)
diff --git a/collects/tests/typed-scheme/succeed/generalize-vectors.rkt b/collects/tests/typed-scheme/succeed/generalize-vectors.rkt
new file mode 100644
index 00000000..7ac26beb
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/generalize-vectors.rkt
@@ -0,0 +1,13 @@
+#lang typed/scheme
+
+(define x (vector 1.0 2.0)) ; should generalize to (Vectorof Float) even though it only contains Nonnegative-Floats
+(vector-set! x 0 -2.0)
+
+(define y (make-vector 2 1.0))
+(vector-set! y 0 -2.0)
+
+(define z #(1.0 2.0))
+(ann z (Vectorof Float))
+
+(define w (build-vector 3 (lambda: ((x : Integer)) (add1 x))))
+(vector-set! w 0 -2)
diff --git a/collects/tests/typed-scheme/succeed/hari-vector-bug.rkt b/collects/tests/typed-scheme/succeed/hari-vector-bug.rkt
new file mode 100644
index 00000000..69bc7efd
--- /dev/null
+++ b/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)))
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/inexact-complex.rkt b/collects/tests/typed-scheme/succeed/inexact-complex.rkt
new file mode 100644
index 00000000..04e1c1b5
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/inexact-complex.rkt
@@ -0,0 +1,9 @@
+#lang typed/scheme
+
+(ann 1.1+2.0i Inexact-Complex)
+(ann 1+2.0i Inexact-Complex)
+(ann (real-part 1.1+2.0i) Float)
+(ann (real-part 1+2.0i) Float)
+(ann (imag-part 1.1+2.0i) Float)
+(ann (+ 2.0 2.0+2.0i) Inexact-Complex)
+(ann (+ 2 2.0+2.0i) Inexact-Complex)
diff --git a/collects/tests/typed-scheme/succeed/kw.rkt b/collects/tests/typed-scheme/succeed/kw.rkt
index 0d95c87c..a7a4ec81 100644
--- a/collects/tests/typed-scheme/succeed/kw.rkt
+++ b/collects/tests/typed-scheme/succeed/kw.rkt
@@ -4,3 +4,11 @@
   (open-input-file "foo" #:mode 'binary)  
   (open-input-file "foo" #:mode 'text)
   (open-input-file "foo"))
+
+((inst sort Real Real) (list 1 2 3) >)
+
+((inst sort Real Real) (list 1 2 3) #:key (λ: ([x : Real]) (/ 1 x)) >)
+
+((inst sort Real String) (list 1 2 3) #:key number->string string<?)
+
+((inst sort Real String) (list 1 2 3) #:key number->string string<? #:cache-keys? #t)
diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-scheme/succeed/list-dots.rkt
new file mode 100644
index 00000000..1c19fff0
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/list-dots.rkt
@@ -0,0 +1,35 @@
+#lang typed/racket
+
+;; tests for the new iteration of ...
+
+(: f (All (a ...) ((List a ...) -> (List a ... a))))
+(define (f x) x)
+
+(: g (All (a ...) (a ... -> (List a ...))))
+(define (g . x) x)
+
+(g 7 7 7)
+
+(: h (All (a ...) (a ... -> (Listof Any))))
+(define (h . x) x)
+
+(: h2 (All (a ...) ((Pair String a) ... -> (Listof (Pair String Any)))))
+(define (h2 . x) x)
+
+(: h3 (All (a ...) ((Pair String a) ... -> (Listof Any))))
+(define (h3 . x) x)
+
+(: h4 (All (a ...) (a ... -> Number)))
+(define (h4 . x) (length x))
+
+(: i (All (a ...) (List a ...) (a ... -> Number) -> Number))
+(define (i xs f) (apply f xs))
+
+(: i2 (All (a ...) (List a ...) (Any * -> Number) -> Number))
+(define (i2 xs f) (apply f xs))
+
+(: i3 (All (a ...) (List a ...) (List a ...) ((Pairof a a) ... -> Number) -> Number))
+(define (i3 xs ys f) (apply f (map cons xs ys)))
+
+(: i4 (All (a ...) (List a ...) (Listof Number) ((Pairof a Number) ... -> Number) -> Number))
+(define (i4 xs ys f) (apply f (map cons xs ys)))
diff --git a/collects/tests/typed-scheme/succeed/manual-examples.rkt b/collects/tests/typed-scheme/succeed/manual-examples.rkt
index 5c6f9731..7541ae74 100644
--- a/collects/tests/typed-scheme/succeed/manual-examples.rkt
+++ b/collects/tests/typed-scheme/succeed/manual-examples.rkt
@@ -30,7 +30,7 @@
   (define-typed-struct leaf ([val : Number]))
   (define-typed-struct node ([left : (Un node leaf)] [right : (Un node leaf)]))
   
-  (define: (tree-height [t : (Un node leaf)]) : Number
+  (define: (tree-height [t : (Un node leaf)]) : Integer
     (cond [(leaf? t) 1]
           [else (max (tree-height (node-left t))
                      (tree-height (node-right t)))]))
@@ -46,7 +46,7 @@
   
   (define-type-alias tree (Un node leaf))
   
-  (define: (tree-height [t : tree]) : Number
+  (define: (tree-height [t : tree]) : Integer
     (cond [(leaf? t) 1]
           [else (max (tree-height (node-left t))
                      (tree-height (node-right t)))]))
diff --git a/collects/tests/typed-scheme/succeed/map-nonempty.rkt b/collects/tests/typed-scheme/succeed/map-nonempty.rkt
index 0fddf079..a501bb0a 100644
--- a/collects/tests/typed-scheme/succeed/map-nonempty.rkt
+++ b/collects/tests/typed-scheme/succeed/map-nonempty.rkt
@@ -1,6 +1,6 @@
 #lang typed/scheme
 
-(: x (Pair Number (Listof Number)))
+(: x (Pair Integer (Listof Integer)))
 (define x (cons 1 (list 1 2 3 4)))
 
-(apply max (ann (map add1 x) : (Pair Number (Listof Number))))
\ No newline at end of file
+(apply max (ann (map add1 x) : (Pair Integer (Listof Integer))))
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/mpair.rkt b/collects/tests/typed-scheme/succeed/mpair.rkt
new file mode 100644
index 00000000..72475e8e
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/mpair.rkt
@@ -0,0 +1,6 @@
+#lang typed/racket
+
+(define: x : (MPairof Integer Integer) (mcons 1 2))
+(set-mcar! x -7)
+(mcar x)
+(mcdr x)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/new-metrics.rkt b/collects/tests/typed-scheme/succeed/new-metrics.rkt
index a3316300..5513eda8 100644
--- a/collects/tests/typed-scheme/succeed/new-metrics.rkt
+++ b/collects/tests/typed-scheme/succeed/new-metrics.rkt
@@ -93,16 +93,16 @@
 ;; ----------------------------------------
 ;; depth
 
-(: sexp-depth (Any -> Number))
+(: sexp-depth (Any -> Integer))
 (define (sexp-depth sexp)
   (cond
     [(pair? sexp)
      (+ (max-sexp-depth sexp) 1)]
     [else 0]))
 
-(: max-sexp-depth (Any -> Number))
+(: max-sexp-depth (Any -> Integer))
 (define (max-sexp-depth losx)
-  (improper-foldr (λ: ([t : Any] [r : Number]) (max (sexp-depth t) r)) 0 losx))
+  (improper-foldr (λ: ([t : Any] [r : Integer]) (max (sexp-depth t) r)) 0 losx))
 
 (: avg-sexp-depth ((Listof Any) -> Number))
 (define (avg-sexp-depth sexps)
@@ -201,7 +201,7 @@
 ;; ----------------------------------------
 ;; expression size
 
-(: atoms (Any -> Number))
+(: atoms (Any -> Integer))
 (define (atoms sexp)
   (cond
     [(null? sexp) 0]
diff --git a/collects/tests/typed-scheme/succeed/nonnegative-float.rkt b/collects/tests/typed-scheme/succeed/nonnegative-float.rkt
new file mode 100644
index 00000000..de361d76
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/nonnegative-float.rkt
@@ -0,0 +1,6 @@
+#lang typed/scheme
+
+(ann (+ 1.0 2.1) Nonnegative-Float)
+(ann (+ 1 2.1) Nonnegative-Float)
+(ann (* 1.2 3.1) Nonnegative-Float)
+(ann (sqrt 3.5) Nonnegative-Float)
diff --git a/collects/tests/typed-scheme/succeed/optimize-simple.rkt b/collects/tests/typed-scheme/succeed/optimize-simple.rkt
new file mode 100644
index 00000000..035a3c75
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/optimize-simple.rkt
@@ -0,0 +1,3 @@
+#lang typed/racket #:optimize
+
+(+ 3 4)
diff --git a/collects/tests/typed-scheme/succeed/pair-test3.rkt b/collects/tests/typed-scheme/succeed/pair-test3.rkt
index 460b6cf9..e45bd796 100644
--- a/collects/tests/typed-scheme/succeed/pair-test3.rkt
+++ b/collects/tests/typed-scheme/succeed/pair-test3.rkt
@@ -11,7 +11,7 @@
   '((((1 . "1") . (#t))
      . ((#f . #\f) . ("2")))
     . ((("3" . 4) . (1.0))
-       . ((#(2.0 3.0 4.0) . #t)
+       . ((#(2.0 3.0 -4.0) . #t)
           . ((2.0 3.0 4.0) . #f)))))
 
 
diff --git a/collects/tests/typed-scheme/succeed/pr10057.rkt b/collects/tests/typed-scheme/succeed/pr10057.rkt
new file mode 100644
index 00000000..a4f1829d
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/pr10057.rkt
@@ -0,0 +1,5 @@
+#lang typed-scheme
+(require scheme/match)
+(ann (match '(a b c)
+       [(list sym more ...) 1]
+       [else 1]) Integer)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/priority-queue.scm b/collects/tests/typed-scheme/succeed/priority-queue.scm
index e2d7e57c..091a284d 100644
--- a/collects/tests/typed-scheme/succeed/priority-queue.scm
+++ b/collects/tests/typed-scheme/succeed/priority-queue.scm
@@ -76,7 +76,7 @@
 		(error "priority queue empty"))))
 
 (pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a)
-	  (make (heap:insert (#{cons :: (case-lambda (a (list-of a) -> (list-of a)) (number a -> (cons number a)))} p x) (heap pq))))
+	  (make (heap:insert (cons p x) (heap pq))))
 
 ;; FIXME -- too many annotations needed on cons
 (pdefine: (a) (insert* [xs : (list-of a)] [ps : (list-of number)] [pq : (priority-queue a)]) : (priority-queue a)
diff --git a/collects/tests/typed-scheme/succeed/provide-case-rest.rkt b/collects/tests/typed-scheme/succeed/provide-case-rest.rkt
new file mode 100644
index 00000000..02681eb3
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/provide-case-rest.rkt
@@ -0,0 +1,8 @@
+#lang typed/racket
+
+(provide foo)
+
+(define foo
+ (case-lambda:
+   (((x : Number)) x)
+   (((x : Number) (y : Number) z : Number *) y)))
diff --git a/collects/tests/typed-scheme/succeed/racket-struct.rkt b/collects/tests/typed-scheme/succeed/racket-struct.rkt
new file mode 100644
index 00000000..354a6698
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/racket-struct.rkt
@@ -0,0 +1,7 @@
+#lang typed/racket
+
+(struct: x ([y : Number]))
+
+(x 1)
+(x-y (x 7))
+(ann x? (Any -> Boolean : x))
diff --git a/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt b/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt
new file mode 100644
index 00000000..72c33824
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt
@@ -0,0 +1,9 @@
+#lang typed/racket
+
+(define-type (Set X) (Rec Set (U Null (Vector X Set))))
+
+(: get-set-root (All (X) ((Set X) -> X)))
+(define (get-set-root s) (error 'fail))
+
+(: set-size (All (X) ((Set X) -> X)))
+(define (set-size x) (get-set-root x))
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/test-child-field.rkt b/collects/tests/typed-scheme/succeed/test-child-field.rkt
new file mode 100644
index 00000000..40f36fe6
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/test-child-field.rkt
@@ -0,0 +1,10 @@
+#lang typed/racket
+
+(define-struct:  x ([a : Any]))
+(define-struct: (A) (y x) ([b : A]))
+
+(: f : (y Any) -> String)
+(define (f v)
+  (if (string? (y-b v))
+      (y-b v)
+      "foo"))
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/succeed/threads-and-channels.rkt b/collects/tests/typed-scheme/succeed/threads-and-channels.rkt
new file mode 100644
index 00000000..6261363e
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/threads-and-channels.rkt
@@ -0,0 +1,50 @@
+#lang typed/scheme
+
+(: chan (Channelof Symbol))
+(define chan (make-channel))
+
+(define (reader)
+  (thread
+   (lambda ()
+     (let: loop : True ((i : Integer 10))
+       (if (= i 0)
+           #t
+           (begin (channel-get chan)
+                  (loop (- i 1))))))))
+
+(: writer (Symbol -> Thread))
+(define (writer x)
+  (thread
+   (lambda ()
+     (channel-put chan x)
+     (channel-put chan x))))
+
+(reader)
+(writer 'a)
+(writer 'b)
+(writer 'c)
+(writer 'd)
+(writer 'e)
+
+
+(define-type JumpingChannel (Rec JumpingChannel (Channelof (Pair JumpingChannel Symbol))))
+(: jump-chan JumpingChannel)
+(define jump-chan (make-channel))
+
+(define (jumping-reader)
+  (thread
+   (lambda ()
+     (let: loop : True ((i : Integer 3)
+                        (c : JumpingChannel jump-chan))
+       (if (= i 0)
+           #t
+           (loop (- i 1)
+                 (car (channel-get c))))))))
+
+(jumping-reader)
+(let: ((c2 : JumpingChannel (make-channel)))
+  (channel-put jump-chan (cons c2 'a))
+  (let: ((c3 : JumpingChannel (make-channel)))
+    (channel-put c2 (cons c3 'b))
+    (let: ((c4 : JumpingChannel (make-channel)))
+      (channel-put c3 (cons c4 'c)))))
diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt b/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt
new file mode 100644
index 00000000..82ecf767
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt
@@ -0,0 +1,26 @@
+#lang typed/scheme
+(require racket/unsafe/ops)
+
+(define-struct: foo ((x : Integer) (y : String)))
+(define-struct: (bar foo) ((z : Float)))
+
+(define a (make-foo 1 "1"))
+(define b (make-bar 2 "2" 2.0))
+
+(= (+ (unsafe-struct-ref a 0) 2) 3)
+(string=? (string-append (unsafe-struct-ref a 1) "\n") "1\n")
+(= (+ (unsafe-struct-ref b 0) 2) 4)
+(string=? (string-append (unsafe-struct-ref b 1) "\n") "2\n")
+(= (+ (unsafe-struct-ref b 2) 2.0) 4.0)
+
+(unsafe-struct-set! a 0 2)
+(unsafe-struct-set! a 1 "2")
+(unsafe-struct-set! b 0 3)
+(unsafe-struct-set! b 1 "3")
+(unsafe-struct-set! b 2 3.0)
+
+(= (+ (unsafe-struct-ref a 0) 2) 4)
+(string=? (string-append (unsafe-struct-ref a 1) "\n") "2\n")
+(= (+ (unsafe-struct-ref b 0) 2) 5)
+(string=? (string-append (unsafe-struct-ref b 1) "\n") "3\n")
+(= (+ (unsafe-struct-ref b 2) 2.0) 5.0)
diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct.rkt b/collects/tests/typed-scheme/succeed/unsafe-struct.rkt
new file mode 100644
index 00000000..df6bff14
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/unsafe-struct.rkt
@@ -0,0 +1,14 @@
+#lang typed/scheme
+(require racket/unsafe/ops)
+
+(define-struct: x ((a : Integer) (b : String)) #:mutable)
+
+(define x1 (make-x 1 "1"))
+
+(= (+ (unsafe-struct-ref x1 0) 2) 3)
+(string=? (string-append (unsafe-struct-ref x1 1) "\n") "1\n")
+
+(unsafe-struct-set! x1 0 2)
+(unsafe-struct-set! x1 1 "2")
+(= (+ (unsafe-struct-ref x1 0) 2) 4)
+(string=? (string-append (unsafe-struct-ref x1 1) "\n") "2\n")
diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt
index b365336b..ac32ab7e 100644
--- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt
@@ -1,12 +1,13 @@
 #lang scheme/base
 (require "test-utils.ss" (for-syntax scheme/base)
+         racket/set
          (utils tc-utils)
-	 (env type-alias-env type-environments type-name-env init-envs)
+	 (env type-alias-env type-env-structs tvar-env type-name-env init-envs)
 	 (rep type-rep)
 	 (rename-in (types comparison subtype union utils convenience)
                     [Un t:Un] [-> t:->])
-         (private base-types-new base-types-extra colon)
-         (for-template (private base-types-new base-types-extra base-env colon))
+         (private base-types base-types-extra colon)
+         (for-template (private base-types base-types-extra base-env colon))
          (private parse-type)
          rackunit)
 
@@ -74,6 +75,11 @@
    [(-> (values Number Boolean Number)) (t:-> (-values (list N B N)))]
    [(Number -> Number) (t:-> N N)]
    [(Number -> Number) (t:-> N N)]
+   [(All (A) Number -> Number) (-poly (a) (t:-> N N))]
+   [(All (A) (Number -> Number)) (-poly (a) (t:-> N N))]
+   [(All (A) A -> A) (-poly (a) (t:-> a a))]
+   [(All (A) A → A) (-poly (a) (t:-> a a))]
+   [(All (A) (A -> A)) (-poly (a) (t:-> a a))]
    ;; requires transformer time stuff that doesn't work
    #;[(Refinement even?) (make-Refinement #'even?)]
    [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)]
@@ -100,8 +106,7 @@
    
    [(Listof Number) (make-Listof  N)]
    
-   [a (-v a) (extend-env (list 'a) (list (-v a))
-                            initial-tvar-env)]
+   [a (-v a) (set-add initial-tvar-env 'a)]
    [(All (a ...) (a ... -> Number))
     (-polydots (a) ((list) [a a] . ->... . N))]
    
diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.rkt b/collects/tests/typed-scheme/unit-tests/subst-tests.rkt
index 6bb8593c..42332056 100644
--- a/collects/tests/typed-scheme/unit-tests/subst-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/subst-tests.rkt
@@ -2,7 +2,7 @@
 
 (require "test-utils.ss" (for-syntax scheme/base)
          (rep type-rep)
-	 (types utils abbrev)
+	 (types utils abbrev substitute)
          rackunit)
 
 (define-syntax-rule (s img var tgt result)
diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
index 6248771a..b6f5cf92 100644
--- a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
@@ -3,7 +3,7 @@
 (require "test-utils.ss"
          (types subtype convenience union)
 	 (rep type-rep)
-	 (env init-envs type-environments)
+	 (env init-envs type-env-structs)
 	 (r:infer infer infer-dummy)
          rackunit
          (for-syntax scheme/base))
@@ -112,11 +112,15 @@
    
    [(-values (list -Number)) (-values (list Univ))]
    
-   [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a) null #'values)) . -> . (-lst a)))
-    ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values)) 
+   [(-poly (b) ((Un (make-Base 'foo #'dummy)
+                    (-struct 'bar #f 
+                             (list (make-fld -Number #'values #f) (make-fld b #'values #f))
+                             #'values))
+                . -> . (-lst b)))
+    ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values))
      . -> . (-lst (-pair -Number (-v a))))]
-   [(-poly (a) ((-struct 'bar #f (list -Number a) null #'values) . -> . (-lst a)))
-    ((-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values) . -> . (-lst (-pair -Number (-v a))))]
+   [(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b)))
+    ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))]
    
    [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))]
    [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))]
@@ -128,6 +132,9 @@
    (FAIL (-> Univ) (null Univ . ->* . Univ))
 
    [(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)]
+   [(-struct 'a #f null #'values) (-struct 'a #f null #'values)]
+   [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld -String #'values #f)) #'values)]
+   [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld Univ #'values #f)) #'values)]
    ))
 
 (define-go 
diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
index eaaa1939..3aa1b6f6 100644
--- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
@@ -24,6 +24,8 @@
        #'(test-suite "Tests for type equality"
                      cl1 ... cl2 ...))]))
 
+(define (fld* t) (make-fld t (datum->syntax #'here 'values) #f))
+
 (define (type-equal-tests)
   (te-tests
    [-Number -Number]
@@ -38,13 +40,12 @@
    ;; found bug
    [FAIL (Un (-mu heap-node 
                   (-struct 'heap-node #f
-                           (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))
-                           null #'values)) 
+                           (map fld* (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))))
+                           #'values)) 
              (-base 'heap-empty))
          (Un (-mu heap-node 
                   (-struct 'heap-node #f
-                           (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))
-                           null #'values)) 
+                           (map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values))
              (-base 'heap-empty))]))
 
 (define-go
diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
index 74608a25..406dc955 100644
--- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
@@ -15,17 +15,18 @@
                     [true-lfilter -true-lfilter]
                     [true-filter -true-filter]
                     [-> t:->])
-         (utils tc-utils utils)
+         (except-in (utils tc-utils utils) infer)
+         typed-scheme/infer/infer-dummy typed-scheme/infer/infer
          unstable/mutated-vars
-         (env type-name-env type-environments init-envs)
+         (env type-name-env type-env-structs init-envs)
          rackunit rackunit/text-ui
          syntax/parse
          (for-syntax (utils tc-utils)
                      (typecheck typechecker)
-	             (env type-env)
+	             (env global-env)
 	             (private base-env base-env-numeric
 			      base-env-indexing))
-         (for-template (private base-env base-types-new base-types-extra
+         (for-template (private base-env base-types base-types-extra
 				base-env-numeric
 				base-env-indexing))
          (for-syntax syntax/kerncase syntax/parse))
@@ -37,7 +38,6 @@
 (define Sym -Symbol)
 (define -Pos -ExactPositiveInteger)
 (define R -Real)
-(define F -Flonum)
 
 (define (g) (run typecheck-tests))
 
@@ -62,20 +62,24 @@
     [(_ e)
      #`(parameterize ([delay-errors? #f]
                       [current-namespace (namespace-anchor->namespace anch)]
+                      [custom-printer #t]
+                      [infer-param infer]
                       [orig-module-stx (quote-syntax e)])
          (let ([ex (expand 'e)])
-           (find-mutated-vars ex)
-           (values (lambda () (tc-expr ex)) ex)))]))
+           (parameterize ([mutated-vars (find-mutated-vars ex)])
+             (values (lambda () (tc-expr ex)) ex))))]))
 
 (define-syntax (tc-expr/expand stx)
   (syntax-case stx ()
     [(_ e)
      #`(parameterize ([delay-errors? #f]
                       [current-namespace (namespace-anchor->namespace anch)]
+                      [custom-printer #t]
+                      [infer-param infer]
                       [orig-module-stx (quote-syntax e)])
          (let ([ex (expand 'e)])
-           (find-mutated-vars ex)
-           (tc-expr ex)))]))
+           (parameterize ([mutated-vars (find-mutated-vars ex)])
+             (tc-expr ex))))]))
 
 ;; check that an expression typechecks correctly
 (define-syntax (tc-e stx)
@@ -136,24 +140,24 @@
                    (+ 1 (car x))
                    5))
          N]
-        (tc-e/t (if (let ([y 12]) y) 3 4) -Pos)
-        (tc-e/t 3 -Pos)
+        (tc-e/t (if (let ([y 12]) y) 3 4) -PositiveFixnum)
+        (tc-e/t 3 -PositiveFixnum)
         (tc-e/t "foo" -String)
         (tc-e (+ 3 4) -Pos)
-        [tc-e/t (lambda: () 3) (t:-> -Pos : -true-lfilter)]
-        [tc-e/t (lambda: ([x : Number]) 3) (t:-> N -Pos : -true-lfilter)]
-        [tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (t:-> N B -Pos : -true-lfilter)]
-        [tc-e/t (lambda () 3) (t:-> -Pos : -true-lfilter)]
-        [tc-e (values 3 4) #:ret (ret (list -Pos -Pos) (list -true-filter -true-filter))]
-        [tc-e (cons 3 4) (-pair -Pos -Pos)]
+        [tc-e/t (lambda: () 3) (t:-> -PositiveFixnum : -true-lfilter)]
+        [tc-e/t (lambda: ([x : Number]) 3) (t:-> N -PositiveFixnum : -true-lfilter)]
+        [tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (t:-> N B -PositiveFixnum : -true-lfilter)]
+        [tc-e/t (lambda () 3) (t:-> -PositiveFixnum : -true-lfilter)]
+        [tc-e (values 3 4) #:ret (ret (list -PositiveFixnum -PositiveFixnum) (list -true-filter -true-filter))]
+        [tc-e (cons 3 4) (-pair -PositiveFixnum -PositiveFixnum)]
         [tc-e (cons 3 (ann '() : (Listof Integer))) (make-Listof -Integer)]
         [tc-e (void) -Void]
         [tc-e (void 3 4) -Void]
         [tc-e (void #t #f '(1 2 3)) -Void]
-        [tc-e/t #(3 4 5) (make-Vector -Pos)]
-        [tc-e/t '(2 3 4) (-lst* -Pos -Pos -Pos)]
-        [tc-e/t '(2 3 #t) (-lst* -Pos -Pos (-val #t))]
-        [tc-e/t #(2 3 #t) (make-Vector (t:Un -Pos (-val #t)))]
+        [tc-e/t #(3 4 5) (make-HeterogenousVector (list -Nat -Nat -Nat))]
+        [tc-e/t '(2 3 4) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum)]
+        [tc-e/t '(2 3 #t) (-lst* -PositiveFixnum -PositiveFixnum (-val #t))]
+        [tc-e/t #(2 3 #t) (make-HeterogenousVector (list -Nat -Nat (-val #t)))]
         [tc-e/t '(#t #f) (-lst* (-val #t) (-val #f))]
         [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l))
                 (make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))]
@@ -164,9 +168,9 @@
         [tc-e (let-values ([(x) 4]) (+ x 1)) -Pos]
         [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) 
               #:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS -top -top))])]
-        [tc-e/t (values 3) -Pos]
+        [tc-e/t (values 3) -PositiveFixnum]
         [tc-e (values) #:ret (ret null)]
-        [tc-e (values 3 #f) #:ret (ret (list -Pos (-val #f)) (list (-FS -top -bot) (-FS -bot -top)))]
+        [tc-e (values 3 #f) #:ret (ret (list -PositiveFixnum (-val #f)) (list (-FS -top -bot) (-FS -bot -top)))]
         [tc-e (map #{values @ Symbol} '(a b c)) (-pair Sym (make-Listof  Sym))]
         [tc-e (letrec: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))])
                        (fact 20))
@@ -196,8 +200,8 @@
 			'bc))
 	      N]
         [tc-e/t (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)]
-        [tc-e/t (begin 3) -Pos]
-        [tc-e/t (begin #f 3) -Pos]
+        [tc-e/t (begin 3) -PositiveFixnum]
+        [tc-e/t (begin #f 3) -PositiveFixnum]
         [tc-e/t (begin #t) (-val #t)]
         [tc-e/t (begin0 #t) (-val #t)]
         [tc-e/t (begin0 #t 3) (-val #t)]
@@ -205,14 +209,14 @@
         [tc-e #f #:ret (ret (-val #f) (-FS -bot -top))]
         [tc-e/t '#t (-val #t)]
         [tc-e '#f #:ret (ret (-val #f) (-FS -bot -top))]
-        [tc-e/t (if #f 'a 3) -Pos]
+        [tc-e/t (if #f 'a 3) -PositiveFixnum]
         [tc-e/t (if #f #f #t) (t:Un (-val #t))]
         [tc-e (when #f 3) -Void]
         [tc-e/t '() (-val '())]
         [tc-e/t (let: ([x : (Listof Number) '(1)]) 
                       (cond [(pair? x) 1]
                             [(null? x) 1]))
-              -Pos]
+              -PositiveFixnum]
         [tc-e/t (lambda: ([x : Number] . [y : Number *]) (car y)) (->* (list N) N N)]
         [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3) N]
         [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4 5) N]
@@ -236,7 +240,7 @@
                     (if (list? x)
                         (begin (car x) 1)
                         2))
-              -Pos]
+              -PositiveFixnum]
         
         
         [tc-e (let: ([x : (U Number Boolean) 3])
@@ -245,7 +249,7 @@
                         3))
               N]
         
-        [tc-e (let ([x 1]) x) -Pos]
+        [tc-e (let ([x 1]) x) -PositiveFixnum]
         [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS -bot -top))]
         [tc-e (boolean? number?) #:ret (ret -Boolean (-FS -bot -top))]
         
@@ -266,9 +270,9 @@
                 (if (eq? x 1)
                     12
                     14))
-              -Pos]
+              -PositiveFixnum]
         
-        [tc-e (car (append (list 1 2) (list 3 4))) -Pos]
+        [tc-e (car (append (list 1 2) (list 3 4))) -PositiveFixnum]
         
         [tc-e 
          (let-syntax ([a 
@@ -278,8 +282,8 @@
                  (string-append "foo" (a v))))
          -String]
         
-        [tc-e (apply (plambda: (a) [x : a *] x) '(5)) (-lst -Pos)]
-        [tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst -Pos)]
+        [tc-e (apply (plambda: (a) [x : a *] x) '(5)) (-lst -PositiveFixnum)]
+        [tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst -PositiveFixnum)]
         
         [tc-err ((case-lambda: [([x : Number]) x]
                                [([y : Number] [x : Number]) x])
@@ -315,9 +319,9 @@
         [tc-e (let* ([sym 'squarf]
                      [x (if (= 1 2) 3 sym)])
                 x)
-              (t:Un (-val 'squarf) -Pos)]
+              (t:Un (-val 'squarf) -PositiveFixnum)]
         
-        [tc-e/t (if #t 1 2) -Pos]
+        [tc-e/t (if #t 1 2) -PositiveFixnum]
         
         
         ;; eq? as predicate
@@ -342,12 +346,12 @@
                      [x (if (= 1 2) 3 sym)])
                 (if (eq? x sym) 3 x))
               #:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
-                                     (ret -Pos (-FS -top -top))])]
+                                     (ret -PositiveFixnum (-FS -top -top))])]
         [tc-e (let* ([sym 'squarf]
                      [x (if (= 1 2) 3 sym)])
                 (if (eq? sym x) 3 x))
                #:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
-                                      (ret -Pos (-FS -top -top))])]
+                                      (ret -PositiveFixnum (-FS -top -top))])]
         ;; equal? as predicate for symbols
         [tc-e (let: ([x : (Un 'foo Number) 'foo])
                     (if (equal? x 'foo) 3 x))
@@ -360,22 +364,22 @@
                      [x (if (= 1 2) 3 sym)])
                 (if (equal? x sym) 3 x))
                #:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
-                                      (ret -Pos (-FS -top -top))])]
+                                      (ret -PositiveFixnum (-FS -top -top))])]
         [tc-e (let* ([sym 'squarf]
                      [x (if (= 1 2) 3 sym)])
                 (if (equal? sym x) 3 x))
               #:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
-                                     (ret -Pos (-FS -top -top))])]
+                                     (ret -PositiveFixnum (-FS -top -top))])]
         
         [tc-e (let: ([x : (Listof Symbol)'(a b c)])
                     (cond [(memq 'a x) => car]
                           [else 'foo]))
               Sym]
         
-        [tc-e (list 1 2 3) (-lst* -Pos -Pos -Pos)]
-        [tc-e (list 1 2 3 'a) (-lst* -Pos -Pos -Pos (-val 'a))]
+        [tc-e (list 1 2 3) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum)]
+        [tc-e (list 1 2 3 'a) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum (-val 'a))]
         
-        [tc-e `(1 2 ,(+ 3 4)) (-lst* -Pos -Pos -Pos)]
+        [tc-e `(1 2 ,(+ 3 4)) (-lst* -PositiveFixnum -PositiveFixnum -Pos)]
         
         [tc-e (let: ([x : Any 1])
                     (when (and (list? x) (not (null? x)))
@@ -394,7 +398,7 @@
                       'foo))
                 (t:Un (-val 'foo) (-pair Univ (-lst Univ)))]
         
-        [tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) -Pos]
+        [tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) -PositiveFixnum]
         
         
         
@@ -409,7 +413,7 @@
         [tc-e/t (let: ([x : Any 3])
                       (if (and (list? x) (not (null? x)))
                           (begin (car x) 1) 2))
-              -Pos]
+              -PositiveFixnum]
         
         ;; set! tests
         [tc-e (let: ([x : Any 3])
@@ -466,7 +470,7 @@
         [tc-e/t (let* ([z 1]
                        [p? (lambda: ([x : Any]) (number? z))])
                   (lambda: ([x : Any]) (if (p? x) 11 12)))
-                (t:-> Univ -Pos : -true-lfilter)]
+                (t:-> Univ -PositiveFixnum : -true-lfilter)]
         [tc-e/t (let* ([z 1]
                        [p? (lambda: ([x : Any]) (number? z))])
                   (lambda: ([x : Any]) (if (p? x) x 12)))
@@ -479,7 +483,7 @@
         [tc-e/t (let* ([z 1]
                        [p? (lambda: ([x : Any]) (not (number? z)))])
                   (lambda: ([x : Any]) (if (p? x) x 12)))
-                (t:-> Univ -Pos : -true-lfilter)]
+                (t:-> Univ -PositiveFixnum : -true-lfilter)]
         [tc-e/t (let* ([z 1]
                        [p? (lambda: ([x : Any]) z)])
                   (lambda: ([x : Any]) (if (p? x) x 12)))
@@ -510,7 +514,7 @@
         ;; w-c-m
         [tc-e/t (with-continuation-mark 'key 'mark 
                 3)
-              -Pos]
+              -PositiveFixnum]
         [tc-err (with-continuation-mark (5 4) 1
                   3)]
         [tc-err (with-continuation-mark 1 (5 4) 
@@ -539,14 +543,14 @@
         [tc-err (call-with-values (lambda () (values 2 1))
                                   (lambda: ([x : String] [y : Number]) (+ x y)))]
         ;; quote-syntax
-        [tc-e/t #'3 (-Syntax -Pos)]
-        [tc-e/t #'(1 2 3) (-Syntax (-lst* -Pos -Pos -Pos))]
+        [tc-e/t #'3 (-Syntax -PositiveFixnum)]
+        [tc-e/t #'(1 2 3) (-Syntax (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum))]
         
         ;; testing some primitives
         [tc-e (let ([app apply]
                     [f (lambda: [x : Number *] 3)])
                 (app f (list 1 2 3)))
-              -Pos]
+              -PositiveFixnum]
         [tc-e ((lambda () (call/cc (lambda: ([k : (Number -> (U))]) (if (read) 5 (k 10))))))
               N]
         
@@ -584,7 +588,7 @@
                         (+ z w)))
                     (g 4))
                   5)
-                -Pos]
+                -PositiveFixnum]
         
         [tc-err (let ()
                   (define x x)
@@ -615,11 +619,11 @@
         
         [tc-e/t (if #f 1 'foo) (-val 'foo)]
         
-        [tc-e (list* 1 2 3) (-pair -Pos (-pair -Pos -Pos))]
+        [tc-e (list* 1 2 3) (-pair -PositiveFixnum (-pair -PositiveFixnum -PositiveFixnum))]
         
         [tc-err (apply append (list 1) (list 2) (list 3) (list (list 1) "foo"))]
-        [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -Pos)]
-        [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (t:Un -String -Pos))]
+        [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -PositiveFixnum)]
+        [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (t:Un -String -PositiveFixnum))]
         [tc-err (plambda: (b ...) [y : b ... b] (apply append (map list y)))]
         [tc-e/t (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y))
                 (-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))]
@@ -647,12 +651,12 @@
         
         ;; instantiating dotted terms
         [tc-e/t (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer)
-                (-Integer B -Integer . t:-> . -Pos : -true-lfilter)]
+                (-Integer B -Integer . t:-> . -PositiveFixnum : -true-lfilter)]
         [tc-e/t (inst (plambda: (a ...) [xs : (a ... a -> Integer) ... a] 3) Integer Boolean Integer)
                 ((-Integer B -Integer . t:-> . -Integer)
                  (-Integer B -Integer . t:-> . -Integer)
                  (-Integer B -Integer . t:-> . -Integer)
-                 . t:-> . -Pos : -true-filter)]
+                 . t:-> . -PositiveFixnum : -true-filter)]
         
         [tc-e/t (plambda: (z x y ...) () (inst map z x y ... y))
               (-polydots (z x y) (t:-> (cl->*
@@ -739,7 +743,7 @@
         
         [tc-e/t (ann (lambda (x) x) (All (a) (a -> a)))
                 (-poly (a) (a . t:-> . a))]
-        [tc-e (apply values (list 1 2 3)) #:ret (ret (list -Pos -Pos -Pos))]
+        [tc-e (apply values (list 1 2 3)) #:ret (ret (list -PositiveFixnum -PositiveFixnum -PositiveFixnum))]
         
         [tc-e/t (ann (if #t 3 "foo") Integer) -Integer]
         
@@ -779,7 +783,7 @@
         (tc-e (or (string->number "7") 7) 
               #:ret (ret -Number -true-filter))
         [tc-e (let ([x 1]) (if x x (add1 x))) 
-              #:ret (ret -Pos (-FS -top -top))]
+              #:ret (ret -PositiveFixnum (-FS -top -top))]
         [tc-e (let: ([x : (U (Vectorof Number) String) (vector 1 2 3)])
                 (if (vector? x) (vector-ref x 0) (string-length x)))
          -Number]
@@ -793,7 +797,8 @@
               Univ]        
         [tc-e (floor 1/2) -Integer]
         [tc-e (ceiling 1/2) -Integer]
-        [tc-e (truncate 0.5) -Flonum]
+        [tc-e (truncate 0.5) -NonnegativeFlonum]
+        [tc-e (truncate -0.5) -Flonum]
         [tc-e/t (ann (lambda (x) (lambda (x) x))
                      (Integer -> (All (X) (X -> X))))
                 (t:-> -Integer (-poly (x) (t:-> x x)))]
@@ -802,6 +807,25 @@
                              (eq? 'r x)
                              (eq? 's x)))
                 (make-pred-ty (t:Un (-val 'q) (-val 'r) (-val 's)))]
+        [tc-e (let: ([x : Exact-Positive-Integer 1])
+                (vector-ref #("a" "b") x)
+                (vector-ref #("a" "b") (sub1 x))
+                (vector-ref #("a" "b") (- x 1)))
+              -String]
+        [tc-err (string-append "bar" (if (zero? (ann 0.0 Float)) #f "foo"))]
+        [tc-err (do: : Void
+                     ([j : Natural (+ i 'a) (+ j i)])
+                     ((>= j 10))
+                     #f)]
+        [tc-err (apply +)]
+        [tc-e/t
+         (let ([x eof])
+           (if (procedure? x)
+               x
+               (lambda (z) (eq? x z))))
+         (make-pred-ty (-val eof))]
+        [tc-e ((inst map Number (Pairof Number Number)) car (ann (list (cons 1 2) (cons 2 3) (cons 4 5)) (Listof (Pairof Number Number))))
+              (-lst -Number)]
         )
   (test-suite
    "check-type tests"
@@ -811,10 +835,21 @@
    (test-not-exn "Doesn't fail on equal types" (lambda () (check-type #'here N N))))
   (test-suite
    "tc-literal tests"
-   (tc-l 5 -ExactPositiveInteger)
-   (tc-l 5# -Flonum)
-   (tc-l 5.0 -Flonum)
-   (tc-l 5.1 -Flonum)
+   (tc-l 5 -PositiveFixnum)
+   (tc-l -5 -NegativeFixnum)
+   (tc-l 0 -Zero)
+   (tc-l 0.0 -NonnegativeFlonum)
+   (tc-l -0.0 -Flonum)
+   (tc-l 5# -NonnegativeFlonum)
+   (tc-l 5.0 -NonnegativeFlonum)
+   (tc-l 5.1 -NonnegativeFlonum)
+   (tc-l -5# -Flonum)
+   (tc-l -5.0 -Flonum)
+   (tc-l -5.1 -Flonum)
+   (tc-l 1+1i N)
+   (tc-l 1+1.0i -InexactComplex)
+   (tc-l 1.0+1i -InexactComplex)
+   (tc-l 1.0+1.1i -InexactComplex)
    (tc-l #t (-val #t))
    (tc-l "foo" -String)
    (tc-l foo (-val 'foo))
@@ -822,8 +857,8 @@
    (tc-l #f (-val #f))
    (tc-l #"foo" -Bytes)
    [tc-l () (-val null)]
-   [tc-l (3 . 4) (-pair -Pos -Pos)]
-   [tc-l #hash((1 . 2) (3 . 4)) (make-Hashtable -Pos -Pos)])
+   [tc-l (3 . 4) (-pair -PositiveFixnum -PositiveFixnum)]
+   [tc-l #hash((1 . 2) (3 . 4)) (make-Hashtable -PositiveFixnum -PositiveFixnum)])
   ))
 
 
diff --git a/collects/tests/typed-scheme/xfail/for-inference.rkt b/collects/tests/typed-scheme/xfail/for-inference.rkt
index faa0154b..14a3a70d 100644
--- a/collects/tests/typed-scheme/xfail/for-inference.rkt
+++ b/collects/tests/typed-scheme/xfail/for-inference.rkt
@@ -59,3 +59,23 @@
 (for/last: : (Option Integer)
            ((i : Exact-Positive-Integer '(1 2 3)))
            i)
+
+;; unlike the usual cases with #:when clauses, inference does something, but does it wrong
+(for/list: : (Listof Integer)
+           (#:when #t
+            (i : Exact-Positive-Integer '(1 2 3))
+            (j : Exact-Positive-Integer '(10 20 30)))
+           (+ i j 10))
+
+;; that same bug makes for/hash:, for/hasheq: and for/hasheqv: unusable
+;; this infers Nothing for the type of the elements of the HashTable
+;; since they don't work, these functions are not currently documented
+(for/hash: : (HashTable Integer Char)
+           ((i : Exact-Positive-Integer '(1 2 3))
+            (j : Char "abc"))
+           (values i j))
+
+;; same thing for for/and:
+(for/and: : Boolean
+          ((i : Exact-Positive-Integer '(1 2 3)))
+          (< i 3))
diff --git a/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt b/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt
new file mode 100644
index 00000000..fb8dfc4f
--- /dev/null
+++ b/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt
@@ -0,0 +1,19 @@
+#lang racket/load
+
+(module m typed/racket
+  (: x Any)
+  (define x "foo")
+  (: f (-> Void))
+  (define (f) (set! x 1))
+  (provide f x))
+
+(module n typed/racket
+  (require 'm)
+  (if (string? x)
+      (begin
+        (f)
+        ;; this should be a type error!
+        (string-append x "foo"))
+      0))
+
+(require 'n)
diff --git a/collects/typed-scheme/env/type-env.rkt b/collects/typed-scheme/env/global-env.rkt
similarity index 97%
rename from collects/typed-scheme/env/type-env.rkt
rename to collects/typed-scheme/env/global-env.rkt
index 0cb028b8..369f6cfd 100644
--- a/collects/typed-scheme/env/type-env.rkt
+++ b/collects/typed-scheme/env/global-env.rkt
@@ -1,5 +1,8 @@
 #lang scheme/base
 
+;; Top-level type environment
+;; maps identifiers to their types, updated by mutation
+
 (require "../utils/utils.rkt" 
 	 syntax/id-table
          (utils tc-utils)
diff --git a/collects/typed-scheme/env/index-env.rkt b/collects/typed-scheme/env/index-env.rkt
new file mode 100644
index 00000000..4a6218ec
--- /dev/null
+++ b/collects/typed-scheme/env/index-env.rkt
@@ -0,0 +1,31 @@
+#lang racket/base
+
+;; this implements the Theta environment from the TOPLAS paper
+
+;; this environment maps type variables names (symbols)
+;; to types representing the type variable
+;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe?
+
+(require racket/require racket/set (path-up "utils/tc-utils.rkt"))
+(provide (all-defined-out))
+
+;; the initial type variable environment - empty
+;; this is used in the parsing of types
+(define initial-index-env (seteq))
+
+;; a parameter for the current type variables
+(define current-indexes (make-parameter initial-index-env))
+
+;; takes a single index
+(define-syntax-rule (extend-indexes index . body)
+ (parameterize ([current-indexes (set-add (current-indexes) index)]) . body))
+
+(define (bound-index? v) (set-member? (current-indexes) v))
+
+(define (infer-index stx)
+  (define bounds (set-map (current-indexes) values))
+  (when (null? bounds)
+    (tc-error/stx stx "No type variable bound with ... in scope for ... type"))
+  (unless (null? (cdr bounds))
+    (tc-error/stx stx "Cannot infer bound for ... type"))
+  (car bounds))
\ No newline at end of file
diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt
index 9fbf1a51..d9a3729c 100644
--- a/collects/typed-scheme/env/init-envs.rkt
+++ b/collects/typed-scheme/env/init-envs.rkt
@@ -1,10 +1,10 @@
 #lang scheme/base
 (provide (all-defined-out))
 (require "../utils/utils.rkt"
-         "type-env.rkt" 
+         "global-env.rkt" 
 	 "type-name-env.rkt"
 	 "type-alias-env.rkt"
-         unstable/struct
+         unstable/struct racket/dict
          (rep type-rep object-rep filter-rep rep-utils)
 	 (for-template (rep type-rep object-rep filter-rep) 
 		       (types union)
@@ -25,11 +25,11 @@
     [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
     [(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
     [(Name: stx) `(make-Name (quote-syntax ,stx))]
-    [(Struct: name parent flds proc poly? pred-id cert acc-ids maker-id)
+    [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax ,acc) ,mut)]
+    [(Struct: name parent flds proc poly? pred-id cert maker-id)
      `(make-Struct ,(sub name) ,(sub parent) 
                    ,(sub flds) ,(sub proc) ,(sub poly?)
                    (quote-syntax ,pred-id) (syntax-local-certifier)
-                   (list ,@(for/list ([a acc-ids]) `(quote-syntax ,a)))
                    (quote-syntax ,maker-id))]
     [(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
     [(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))]
@@ -80,7 +80,7 @@
                  (show-sharing #f)
                  (booleans-as-true/false #f))                   
     (with-syntax ([registers (filter (lambda (x) x) (type-name-env-map f))])
-      #'(begin (begin-for-syntax  . registers)))))
+      #'(begin-for-syntax  . registers))))
 
 (define (talias-env-init-code)    
   (define (f id ty)
@@ -91,18 +91,20 @@
                  (show-sharing #f)
                  (booleans-as-true/false #f))                   
     (with-syntax ([registers (filter (lambda (x) x) (type-alias-env-map f))])
-      #'(begin (begin-for-syntax  . registers)))))
+      #'(begin-for-syntax  . registers))))
 
-(define (env-init-code)    
+(define (env-init-code syntax-provide? provide-tbl def-tbl)
   (define (f id ty)
-    (if (bound-in-this-module id)
+    (if (and (bound-in-this-module id)
+             ;; if there are no syntax provides, then we only need this identifier if it's provided
+             #;(or syntax-provide? (dict-ref provide-tbl id #f)))     
         #`(register-type #'#,id #,(datum->syntax #'here (print-convert ty)))
         #f))
   (parameterize ((current-print-convert-hook converter)
                  (show-sharing #f)
                  (booleans-as-true/false #f))                   
-    (with-syntax ([registers (filter (lambda (x) x) (type-env-map f))])
-      #'(begin (begin-for-syntax  . registers)))))
+    (with-syntax ([registers (filter values (type-env-map f))])
+      #'(begin-for-syntax . registers))))
 
 
 
diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt
index 15f9e25b..1445435d 100644
--- a/collects/typed-scheme/env/lexical-env.rkt
+++ b/collects/typed-scheme/env/lexical-env.rkt
@@ -1,9 +1,15 @@
 #lang scheme/base
 
+;; this environment maps *lexical* variables to types
+;; it also contains the proposition environment
+
+;; these environments are unified in "Logical Types for Scheme"
+;; but split here for performance
+
 (require "../utils/utils.rkt"
-	 "type-environments.rkt" 
-	 "type-env.rkt"
-	 unstable/mutated-vars
+	 "type-env-structs.rkt"
+         "global-env.rkt"
+	 unstable/mutated-vars syntax/id-table
          (only-in scheme/contract ->* -> or/c any/c listof cons/c)
          (utils tc-utils)
          (only-in (rep type-rep) Type/c)
@@ -13,11 +19,11 @@
 (provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical
          with-lexical-env/extend/props)
 (p/c
- [lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]
- [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)])
+ [lookup-type/lexical ((identifier?) (prop-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]
+ [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (prop-env?) . ->* . env?)])
 
 ;; the current lexical environment
-(define lexical-env (make-parameter (make-empty-env free-identifier=?)))
+(define lexical-env (make-parameter (make-empty-prop-env (make-immutable-free-id-table))))
 
 ;; run code in a new env
 (define-syntax-rule (with-lexical-env e . b)
@@ -34,14 +40,7 @@
 ;; find the type of identifier i, looking first in the lexical env, then in the top-level env
 ;; identifer -> Type
 (define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f])
-  (lookup env i 
-          (lambda (i) (lookup-type 
-                       i (lambda () 
-                           (cond [(lookup (dotted-env) i (lambda _ #f))
-                                  =>
-                                  (lambda (a)
-                                    (-lst (substitute Univ (cdr a) (car a))))]
-                                 [else ((or fail lookup-fail) i)]))))))
+  (lookup env i (λ (i) (lookup-type i (λ () ((or fail lookup-fail) i))))))
 
 ;; refine the type of i in the lexical env
 ;; (identifier type -> type) identifier -> environment
diff --git a/collects/typed-scheme/env/tvar-env.rkt b/collects/typed-scheme/env/tvar-env.rkt
new file mode 100644
index 00000000..88e933e0
--- /dev/null
+++ b/collects/typed-scheme/env/tvar-env.rkt
@@ -0,0 +1,24 @@
+#lang racket/base
+
+;; this implements the Delta environment from the TOPLAS paper 
+;; (as well as every other paper on System F)
+
+;; this environment maps type variables names (symbols)
+;; to types representing the type variable
+;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe?
+
+(require racket/set)
+(provide (all-defined-out))
+
+;; the initial type variable environment - empty
+;; this is used in the parsing of types
+(define initial-tvar-env (seteq))
+
+;; a parameter for the current type variables
+(define current-tvars (make-parameter initial-tvar-env))
+
+;; takes a list of vars
+(define-syntax-rule (extend-tvars vars . body)
+ (parameterize ([current-tvars (foldr (λ (v s) (set-add s v)) (current-tvars) vars)]) . body))
+
+(define (bound-tvar? v) (set-member? (current-tvars) v))
\ No newline at end of file
diff --git a/collects/typed-scheme/env/type-env-structs.rkt b/collects/typed-scheme/env/type-env-structs.rkt
new file mode 100644
index 00000000..1d9047b9
--- /dev/null
+++ b/collects/typed-scheme/env/type-env-structs.rkt
@@ -0,0 +1,93 @@
+#lang scheme/base  
+
+(require scheme/contract unstable/sequence racket/dict syntax/id-table
+         (prefix-in r: "../utils/utils.rkt")
+         scheme/match (r:rep filter-rep rep-utils type-rep) unstable/struct
+         (except-in (r:utils tc-utils) make-env))
+
+(provide extend
+         env?
+         lookup
+         extend-env
+         extend/values
+         env-map
+         make-empty-env
+         env-filter
+         env-keys+vals
+         env-props
+         replace-props
+         prop-env? make-empty-prop-env)
+
+;; eq? has the type of equal?, and l is an alist (with conses!)
+;; props is a list of known propositions
+(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)]) #:transparent)
+(r:d-s/c (prop-env env) ([props (listof Filter/c)]) #:transparent)
+
+(define (mk-env orig dict)
+  (match orig
+    [(prop-env _ p) (prop-env dict p)]
+    [_ (env dict)]))
+
+(define (env-filter f e)
+  (match e
+    [(env l)
+     (mk-env e 
+             (for/fold ([h l])
+               ([(k v) (in-dict l)]
+                #:when (not (f (cons k v))))
+               (dict-remove h k)))]))
+
+(r:d/c (make-empty-env dict)
+       (dict? . -> . env?)
+       (env dict))
+
+(r:d/c (make-empty-prop-env dict)
+       (dict? . -> . prop-env?)
+       (prop-env dict null))
+
+(r:d/c (env-props e)
+       (prop-env? . -> . (listof Filter/c))
+       (prop-env-props e))
+
+(define (env-keys+vals e)
+  (match e
+    [(env l) (for/list ([(k v) (in-dict l)]) (cons k v))]))  
+
+(r:d/c (env-map f e)
+  ((any/c any/c . -> . any/c) env? . -> . env?)
+  (mk-env e (dict-map f (env-l e))))
+
+;; extend that works on single arguments
+(define (extend e k v) 
+  (match e
+    [(env l) (mk-env e (dict-set l k v))]
+    [_ (int-err "extend: expected environment, got ~a" e)]))
+
+(define (extend-env ks vs e)
+  (match e
+    [(env l) (mk-env e (for/fold ([h l])
+                         ([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)))]
+    [_ (int-err "extend-env: expected environment, got ~a" e)]))
+
+(define (replace-props e props)
+  (match e
+    [(prop-env l p)
+     (prop-env l props)]))
+
+(define (lookup e key fail)
+  (match e
+    [(env l) (dict-ref l key (λ () (fail key)))]
+    [_ (int-err "lookup: expected environment, got ~a" e)]))
+
+
+;; takes two lists of sets to be added, which are either added one at a time, if the 
+;; elements are not lists, or all at once, if the elements are lists
+(define (extend/values kss vss env)
+  (foldr (lambda (ks vs env) 
+           (cond [(and (list? ks) (list? vs))
+                  (extend-env ks vs env)]
+                 [(or (list? ks) (list? vs))
+                  (int-err "not both lists in extend/values: ~a ~a" ks vs)]
+                 [else (extend env ks vs)]))
+         env kss vss))
+
diff --git a/collects/typed-scheme/env/type-environments.rkt b/collects/typed-scheme/env/type-environments.rkt
deleted file mode 100644
index 2254d948..00000000
--- a/collects/typed-scheme/env/type-environments.rkt
+++ /dev/null
@@ -1,98 +0,0 @@
-#lang scheme/base  
-
-(require scheme/contract
-         (prefix-in r: "../utils/utils.rkt")
-         scheme/match (r:rep filter-rep rep-utils type-rep) unstable/struct
-         (except-in (r:utils tc-utils) make-env)
-         #;(r:typecheck tc-metafunctions))
-
-(provide current-tvars
-         extend
-         env?
-         lookup
-         extend-env
-         extend/values
-         dotted-env
-         initial-tvar-env
-         env-map
-         env-filter
-         env-vals
-         env-keys+vals
-         env-props
-         replace-props
-         with-dotted-env/extend)
-
-;; eq? has the type of equal?, and l is an alist (with conses!)
-;; props is a list of known propositions
-(r:d-s/c env ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)] [props (listof Filter/c)]) #:transparent)
-
-(define (env-vals e)
-  (map cdr (env-l e)))
-
-(define (env-keys+vals e)
-  (env-l e))
-
-(define (env-filter f e)
-  (match e
-    [(struct env (eq? l props))
-    (make-env eq? (filter f l) props)]))
-
-(define (make-empty-env p?) (make-env p? null null))
-
-;; the initial type variable environment - empty
-;; this is used in the parsing of types
-(define initial-tvar-env (make-empty-env eq?))
-
-;; a parameter for the current type variables
-(define current-tvars (make-parameter initial-tvar-env))  
-
-;; the environment for types of ... variables
-(define dotted-env (make-parameter (make-empty-env free-identifier=?)))
-
-(r:d/c (env-map f e)
-  ((pair? . -> . pair?) env? . -> . env?)
-  (make-env (env-eq? e) (map f (env-l e)) (env-props e)))
-
-;; extend that works on single arguments
-(define (extend e k v) 
-  (match e
-    [(struct env (f l p)) (make-env f (cons (cons k v) l) p)]
-    [_ (int-err "extend: expected environment, got ~a" e)]))
-
-(define (extend-env ks vs e)
-  (match e
-    [(struct env (f l p)) (make-env f (append (map cons ks vs) l) p)]
-    [_ (int-err "extend-env: expected environment, got ~a" e)]))
-
-(define (replace-props e props)
-  (match e
-    [(struct env (f l p))
-     (make-env f l props)]))
-
-(define (lookup e key fail)
-  (match e
-    [(struct env (f? l p))
-     (let loop ([l l])
-       (cond [(null? l) (fail key)]
-             [(f? (caar l) key) (cdar l)]
-             [else (loop (cdr l))]))]
-    [_ (int-err "lookup: expected environment, got ~a" e)]))
-
-
-;; takes two lists of sets to be added, which are either added one at a time, if the 
-;; elements are not lists, or all at once, if the elements are lists
-(define (extend/values kss vss env)
-  (foldr (lambda (ks vs env) 
-           (cond [(and (list? ks) (list? vs))
-                  (extend-env ks vs env)]
-                 [(or (list? ks) (list? vs))
-                  (int-err "not both lists in extend/values: ~a ~a" ks vs)]
-                 [else (extend-env (list ks) (list vs) env)]))
-         env kss vss))
-
-;; run code in an extended dotted env
-(define-syntax with-dotted-env/extend
-  (syntax-rules ()
-    [(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)]))
-
-(r:p/c [make-empty-env ((-> any/c any/c any/c) . -> . env?)])
diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt
index ea946d98..82e65033 100644
--- a/collects/typed-scheme/infer/constraint-structs.rkt
+++ b/collects/typed-scheme/infer/constraint-structs.rkt
@@ -4,22 +4,29 @@
 
 ;; S, T types
 ;; X a var
-(define-struct c (S X T) #:prefab)
+;; represents S <: X <: T
+(d-s/c c ([S Type/c] [X symbol?] [T Type/c]) #:transparent)
 
 ;; fixed : Listof[c]
 ;; rest : option[c]
-(define-struct dcon (fixed rest) #:prefab)
+;; a constraint on an index variable
+;; the index variable must be instantiated with |fixed| arguments, each meeting the appropriate constraint
+;; and further instantions of the index variable must respect the rest constraint, if it exists
+(d-s/c dcon ([fixed (listof c?)] [rest (or/c c? #f)]) #:transparent)
 
 ;; fixed : Listof[c]
 ;; rest : c
-(define-struct dcon-exact (fixed rest) #:prefab)
+(d-s/c dcon-exact ([fixed (listof c?)] [rest c?]) #:transparent)
 
+;; fixed : Listof[c]
 ;; type : c
 ;; bound : var
-(define-struct dcon-dotted (type bound) #:prefab)
+(d-s/c dcon-dotted ([fixed (listof c?)] [type c?] [bound symbol?]) #:transparent)
 
-;; map : hash mapping variable to dcon or dcon-dotted
-(define-struct dmap (map) #:prefab)
+(define dcon/c (or/c dcon? dcon-exact? dcon-dotted?))
+
+;; map : hash mapping index variables to dcons
+(d-s/c dmap ([map (hash/c symbol? dcon/c)]) #:transparent)
 
 ;; maps is a list of pairs of
 ;;    - functional maps from vars to c's
@@ -27,17 +34,13 @@
 ;; we need a bunch of mappings for each cset to handle case-lambda
 ;; because case-lambda can generate multiple possible solutions, and we
 ;; don't want to rule them out too early
-(define-struct cset (maps) #:prefab)
+(d-s/c cset ([maps (listof (cons/c (hash/c symbol? c? #:immutable #t) dmap?))]) #:transparent)
 
 (define-match-expander c:
   (lambda (stx)
     (syntax-parse stx
       [(_ s x t)
-       #'(struct c ((app (lambda (v) (if (Type? v) v (Un))) s) x (app (lambda (v) (if (Type? v) v Univ)) t)))])))
+       #'(struct c (s x t))])))
 
-(p/c (struct c ([S (or/c boolean? Type?)] [X symbol?] [T (or/c boolean? Type?)]))
-     (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
-     (struct dcon-exact ([fixed (listof c?)] [rest c?]))
-     (struct dcon-dotted ([type c?] [bound symbol?]))
-     (struct dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
-     (struct cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))])))
+(provide (struct-out cset) (struct-out dmap) (struct-out dcon) (struct-out dcon-dotted) (struct-out dcon-exact) (struct-out c)
+         c: dcon/c)
diff --git a/collects/typed-scheme/infer/constraints.rkt b/collects/typed-scheme/infer/constraints.rkt
index 2626eb2f..444ddca9 100644
--- a/collects/typed-scheme/infer/constraints.rkt
+++ b/collects/typed-scheme/infer/constraints.rkt
@@ -14,19 +14,22 @@
 
 (define-values (fail-sym exn:infer?)
   (let ([sym (gensym 'infer-fail)])
-    (values sym (lambda (s) (eq? s sym)))))
+    (values sym (λ (s) (and (pair? s) (eq? (car s) sym))))))
 
 ;; why does this have to be duplicated?
 ;; inference failure - masked before it gets to the user program
 (define-syntaxes (fail!)
   (syntax-rules ()
-    [(_ s t) (raise fail-sym)]))
+    [(_ s t) (raise (list fail-sym s t))]))
 
 ;; Widest constraint possible
 (define (no-constraint v)
   (make-c (Un) v Univ))
 
-(define (empty-cset X)
+;; Create an empty constraint map from a set of type variables X and
+;; index variables Y.  For now, we add the widest constraints for
+;; variables in X to the cmap and create an empty dmap.
+(define (empty-cset X Y)
   (make-cset (list (cons (for/hash ([x X]) (values x (no-constraint x)))
                          (make-dmap (make-immutable-hash null))))))
 
@@ -59,13 +62,6 @@
          (fail! S T))
        (make-c S (or var X) T))]))
 
-(define (subst-all/c sub -c)
-  (match -c
-    [(struct c (S X T))
-     (make-c (subst-all sub S)
-             (F-n (subst-all sub (make-F X)))
-             (subst-all sub T))]))
-
 (define (cset-meet x y)
   (match* (x y)
    [((struct cset (maps1)) (struct cset (maps2)))
diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt
index 7e2e3b39..c76702bf 100644
--- a/collects/typed-scheme/infer/dmap.rkt
+++ b/collects/typed-scheme/infer/dmap.rkt
@@ -2,14 +2,15 @@
 
 (require "../utils/utils.rkt" 
 	 "signatures.rkt" "constraint-structs.rkt"
-	 (utils tc-utils)
+	 (utils tc-utils) racket/contract
 	 unstable/sequence unstable/hash scheme/match)
 
 (import constraints^)
 (export dmap^)
 
 ;; dcon-meet : dcon dcon -> dcon
-(define (dcon-meet dc1 dc2)
+(d/c (dcon-meet dc1 dc2)
+  (dcon/c dcon/c . -> . dcon/c)
   (match* (dc1 dc2)
     [((struct dcon-exact (fixed1 rest1)) (or (struct dcon (fixed2 rest2))
                                              (struct dcon-exact (fixed2 rest2))))
@@ -20,6 +21,7 @@
                  [c2 fixed2])
         (c-meet c1 c2 (c-X c1)))
       (c-meet rest1 rest2 (c-X rest1)))]
+    ;; redo in the other order to call the first case
     [((struct dcon (fixed1 rest1)) (struct dcon-exact (fixed2 rest2)))
      (dcon-meet dc2 dc1)]
     [((struct dcon (fixed1 #f)) (struct dcon (fixed2 #f)))
@@ -50,10 +52,13 @@
                    [c2 (in-sequence-forever shorter srest)])
           (c-meet c1 c2 (c-X c1)))
         (c-meet lrest srest (c-X lrest))))]
-    [((struct dcon-dotted (c1 bound1)) (struct dcon-dotted (c2 bound2)))
-     (unless (eq? bound1 bound2)
+    [((struct dcon-dotted (fixed1 c1 bound1)) (struct dcon-dotted (fixed2 c2 bound2)))
+     (unless (and (= (length fixed1) (length fixed2))
+                  (eq? bound1 bound2))
        (fail! bound1 bound2))
-     (make-dcon-dotted (c-meet c1 c2 bound1) bound1)]
+     (make-dcon-dotted (for/list ([c1 fixed1] [c2 fixed2])
+                         (c-meet c1 c2 (c-X c1)))
+                       (c-meet c1 c2 bound1) bound1)]
     [((struct dcon _) (struct dcon-dotted _))
      (fail! dc1 dc2)]
     [((struct dcon-dotted _) (struct dcon _))
diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt
index 165bcdc3..e5fff323 100644
--- a/collects/typed-scheme/infer/infer-unit.rkt
+++ b/collects/typed-scheme/infer/infer-unit.rkt
@@ -1,21 +1,20 @@
 #lang scheme/unit
 
-(require scheme/require
+(require scheme/require (path-up "utils/utils.rkt")
          (except-in 
-          (path-up
-           "utils/utils.rkt" "utils/tc-utils.rkt"
-           "rep/free-variance.rkt" "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/rep-utils.rkt"
-           "types/convenience.rkt" "types/union.rkt" "types/subtype.rkt" "types/remove-intersect.rkt" "types/resolve.rkt"
-           "env/type-name-env.rkt")
-          make-env)
-         (except-in (path-up "types/utils.rkt") Dotted)
-         (only-in (path-up "env/type-environments.rkt") lookup current-tvars)
+          (combine-in
+           (utils tc-utils)
+           (rep free-variance type-rep filter-rep rep-utils)
+           (types utils convenience union subtype remove-intersect resolve
+                  substitute)
+           (env type-name-env index-env tvar-env))
+          make-env -> ->* one-of/c)
          "constraint-structs.rkt"
 	 "signatures.rkt"                  
          scheme/match
          mzlib/etc
-         mzlib/trace
-	 unstable/sequence unstable/list unstable/debug
+         racket/trace racket/contract
+	 unstable/sequence unstable/list unstable/debug unstable/hash
          scheme/list)
 
 (import dmap^ constraints^ promote-demote^)
@@ -23,30 +22,13 @@
 
 (define (empty-set) '())  
 
-(define current-seen (make-parameter (empty-set) #;pair?))
+(define current-seen (make-parameter (empty-set)))
 
 (define (seen-before s t) (cons (Type-seq s) (Type-seq t)))
 (define (remember s t A) (cons (seen-before s t) A))
 (define (seen? s t) (member (seen-before s t) (current-seen)))
 
 
-(define (dmap-constraint dmap dbound v)
-  (let ([dc (hash-ref dmap dbound #f)])
-    (match dc
-      [(struct dcon (fixed #f))
-       (if (eq? dbound v)
-           (no-constraint v)
-           (hash-ref fixed v (no-constraint v)))]
-      [(struct dcon (fixed rest))
-       (if (eq? dbound v)
-           rest
-           (hash-ref fixed v (no-constraint v)))]
-      [(struct dcon-dotted (type bound))
-       (if (eq? bound v)
-           type
-           (no-constraint v))]
-      [_ (no-constraint v)])))
-
 (define (map/cset f cset)
   (make-cset (for/list ([(cmap dmap) (in-pairs (cset-maps cset))])
                (f cmap dmap))))
@@ -60,432 +42,607 @@
 (define (mover cset dbound vars f)
   (map/cset
    (lambda (cmap dmap)
-     (cons (hash-remove* cmap vars)           
+     (cons (hash-remove* cmap (cons dbound vars))           
            (dmap-meet 
             (singleton-dmap 
              dbound
-             (f cmap))
-            dmap)))
+             (f cmap dmap))
+            (make-dmap (hash-remove (dmap-map dmap) dbound)))))
    cset))
 
-(define (move-vars-to-dmap cset dbound vars)
+;; dbound : index variable
+;; vars : listof[type variable] - temporary variables
+;; cset : the constraints being manipulated
+;; takes the constraints on vars and creates a dmap entry contstraining dbound to be |vars| 
+;; with the constraints that cset places on vars
+(d/c (move-vars-to-dmap cset dbound vars)
+  (cset? symbol? (listof symbol?) . -> . cset?)
   (mover cset dbound vars
-         (lambda (cmap)
+         (λ (cmap dmap)
            (make-dcon (for/list ([v vars])
                         (hash-ref cmap v 
-                                  (lambda () (int-err "No constraint for new var ~a" v))))
+                                  (λ () (int-err "No constraint for new var ~a" v))))
                       #f))))
 
-(define (move-rest-to-dmap cset dbound #:exact [exact? #f])
-  (mover cset dbound (list dbound)
-         (lambda (cmap)
+;; dbound : index variable
+;; cset : the constraints being manipulated
+;; 
+(d/c (move-rest-to-dmap cset dbound #:exact [exact? #f])
+  ((cset? symbol?) (#:exact boolean?) . ->* . cset?)
+  (mover cset dbound null
+         (λ (cmap dmap)
            ((if exact? make-dcon-exact make-dcon)
             null
             (hash-ref cmap dbound
-                      (lambda () (int-err "No constraint for bound ~a" dbound)))))))
+                      (λ () (int-err "No constraint for bound ~a" dbound)))))))
 
-(define (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f])
-  (map/cset
-   (lambda (cmap dmap)
-     (cons (hash-remove* cmap vars)           
-            (dmap-meet 
-             (singleton-dmap 
-              dbound
-              ((if exact? make-dcon-exact make-dcon)
-               (for/list ([v vars])
-                 (hash-ref cmap v 
-                           (lambda () (int-err "No constraint for new var ~a" v))))
-               (hash-ref cmap dbound
-                         (lambda () (int-err "No constraint for bound ~a" dbound)))))
-             dmap)))
-   cset))
+;; dbound : index variable
+;; cset : the constraints being manipulated
+;; 
+(d/c (move-dotted-rest-to-dmap cset dbound)
+  (cset? symbol? . -> . cset?)
+  (mover cset dbound null
+         (λ (cmap dmap)
+           (make-dcon-dotted
+            null
+            (hash-ref cmap dbound
+                      (λ () (int-err "No constraint for bound ~a" dbound)))
+            dbound))))
 
-;; t and s must be *latent* filters
-(define (cgen/filter V X t s)
-  (match* (t s)
-    [(e e) (empty-cset X)]
-    [(e (Top:)) (empty-cset X)]
+;; This one's weird, because the way we set it up, the rest is already in the dmap.
+;; This is because we create all the vars, then recall cgen/arr with the new vars
+;; in place, and the "simple" case will then call move-rest-to-dmap.  This means
+;; we need to extract that result from the dmap and merge it with the fixed vars
+;; we now handled.  So I've extended the mover to give access to the dmap, which we use here.
+(d/c (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f])
+  ((cset? symbol? (listof symbol?)) (#:exact boolean?) . ->* . cset?)
+  (mover cset dbound vars
+         (λ (cmap dmap)
+           ((if exact? make-dcon-exact make-dcon)
+            (for/list ([v vars])
+              (hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v))))
+            (match (hash-ref (dmap-map dmap) dbound
+                             (λ () (int-err "No constraint for bound ~a" dbound)))
+              [(dcon null rest) rest]
+              [(dcon-exact null rest) rest]
+              [_ (int-err "did not get a rest-only dcon when moving to the dmap")])))))
+
+(define (cgen/filter V X Y s t)
+  (match* (s t)
+    [(e e) (empty-cset X Y)]
+    [(e (Top:)) (empty-cset X Y)]
     ;; FIXME - is there something to be said about the logical ones?
-    [((TypeFilter: t p i) (TypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))]
-    [((NotTypeFilter: t p i) (NotTypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))]
-    [(_ _) (fail! t s)]))
+    [((TypeFilter: s p i) (TypeFilter: t p i)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))]
+    [((NotTypeFilter: s p i) (NotTypeFilter: t p i)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))]
+    [(_ _) (fail! s t)]))
 
-#;
-(define (cgen/filters V X ts ss)
-  (cond 
-    [(null? ss) (empty-cset X)]
-    ;; FIXME - this can be less conservative
-    [(= (length ts) (length ss))
-     (cset-meet* (for/list ([t ts] [s ss]) (cgen/filter V X t s)))]
-    [else (fail! ts ss)]))
+;; s and t must be *latent* filter sets
+(define (cgen/filter-set V X Y s t)
+  (match* (s t)
+    [(e e) (empty-cset X Y)]
+    [((FilterSet: s+ s-) (FilterSet: t+ t-))
+     (cset-meet (cgen/filter V X Y s+ t+) (cgen/filter V X Y s- t-))]
+    [(_ _) (fail! s t)]))
 
-
-;; t and s must be *latent* filter sets
-(define (cgen/filter-set V X t s)
-  (match* (t s)
-    [(e e) (empty-cset X)]
-    [((FilterSet: t+ t-) (FilterSet: s+ s-))
-     (cset-meet (cgen/filter V X t+ s+) (cgen/filter V X t- s-))]
-    [(_ _) (fail! t s)]))
-
-(define (cgen/object V X t s)
-  (match* (t s)
-    [(e e) (empty-cset X)]
-    [(e (Empty:)) (empty-cset X)]
+(define (cgen/object V X Y s t)
+  (match* (s t)
+    [(e e) (empty-cset X Y)]
+    [(e (Empty:)) (empty-cset X Y)]
     ;; FIXME - do something here    
-    [(_ _) (fail! t s)]))
+    [(_ _) (fail! s t)]))
 
-(define (cgen/arr V X t-arr s-arr)
-  (define (cg S T) (cgen V X S T))
-  (match* (t-arr s-arr)
-    [((arr: ts t #f #f '())
-      (arr: ss s #f #f '()))
-     (cset-meet* 
-      (list (cgen/list V X ss ts)
-            (cg t s)))]
-    [((arr: ts t t-rest #f '())
-      (arr: ss s s-rest #f '()))
+(define (cgen/arr V X Y s-arr t-arr)
+  (define (cg S T) (cgen V X Y S T))
+  (match* (s-arr t-arr)
+    ;; the simplest case - no rests, drests, keywords
+    [((arr: ss s #f #f '())
+      (arr: ts t #f #f '()))
+     (cset-meet* (list 
+                  ;; contravariant
+                  (cgen/list V X Y ts ss)
+                  ;; covariant
+                  (cg s t)))]
+    ;; just a rest arg, no drest, no keywords
+    [((arr: ss s s-rest #f '())
+      (arr: ts t t-rest #f '()))
      (let ([arg-mapping 
-            (cond [(and t-rest s-rest (<= (length ts) (length ss)))
-                   (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))]
-                  [(and t-rest s-rest (>= (length ts) (length ss)))
-                   (cgen/list V X (cons s-rest (extend ts ss s-rest)) (cons t-rest ts))]
-                  [(and t-rest (not s-rest) (<= (length ts) (length ss)))
-                   (cgen/list V X ss (extend ss ts t-rest))]
-                  [(and s-rest (not t-rest) (>= (length ts) (length ss)))
-                   (cgen/list V X (extend ts ss s-rest) ts)]
-                  [else (fail! S T)])]
-           [ret-mapping (cg t s)])
-       (cset-meet*
-        (list arg-mapping ret-mapping)))]
-    [((arr: ts t #f (cons dty dbound) '())
-      (arr: ss s #f #f                '()))
-     (unless (memq dbound X)
-       (fail! S T))
-     (unless (<= (length ts) (length ss))
-       (fail! S T))
-     (let* ([num-vars (- (length ss) (length ts))]
-            [vars     (for/list ([n (in-range num-vars)])
-                        (gensym dbound))]
-            [new-tys  (for/list ([var vars])
-                        (substitute (make-F var) dbound dty))]
-            [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null) s-arr)])
-       (move-vars-to-dmap new-cset dbound vars))]
-    [((arr: ts t #f #f                '())
-      (arr: ss s #f (cons dty dbound) '()))
-     (unless (memq dbound X)
-       (fail! S T))
+            (cond 
+              ;; both rest args are present, so make them the same length
+              [(and s-rest t-rest)
+               (cgen/list V X Y (cons t-rest (extend ss ts t-rest)) (cons s-rest (extend ts ss s-rest)))]
+              ;; no rest arg on the right, so just pad the left and forget the rest arg
+              [(and s-rest (not t-rest) (<= (length ss) (length ts)))
+               (cgen/list V X Y ts (extend ts ss s-rest))]
+              ;; no rest arg on the left, or wrong number = fail
+              [else (fail! s-arr t-arr)])]
+           [ret-mapping (cg s t)])
+       (cset-meet* (list arg-mapping ret-mapping)))]
+    ;; dotted on the left, nothing on the right
+    [((arr: ss s #f (cons dty dbound) '())
+      (arr: ts t #f #f                '()))
+     (unless (memq dbound Y)
+       (fail! s-arr t-arr))
      (unless (<= (length ss) (length ts))
-       (fail! S T))
-     (let* ([num-vars (- (length ts) (length ss))]
-            [vars     (for/list ([n (in-range num-vars)])
+       (fail! ss ts))
+     (let* ([vars      (for/list ([n (in-range (- (length ts) (length ss)))])
+                         (gensym dbound))]
+            [new-tys   (for/list ([var vars])
+                         (substitute (make-F var) dbound dty))]
+            [new-s-arr (make-arr (append ss new-tys) s #f #f null)]
+            [new-cset  (cgen/arr V (append vars X) Y new-s-arr t-arr)])
+       (move-vars-to-dmap new-cset dbound vars))]
+    ;; dotted on the right, nothing on the left
+    [((arr: ss s #f #f                '())
+      (arr: ts t #f (cons dty dbound) '()))
+     (unless (memq dbound Y)
+       (fail! s-arr t-arr))
+     (unless (<= (length ts) (length ss))
+       (fail! ss ts))
+     (let* ([vars     (for/list ([n (in-range (- (length ss) (length ts)))])
                         (gensym dbound))]
             [new-tys  (for/list ([var vars])
                         (substitute (make-F var) dbound dty))]
-            [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null))])
+            [new-t-arr (make-arr (append ts new-tys) t #f #f null)]
+            [new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)])
        (move-vars-to-dmap new-cset dbound vars))]
-    [((arr: ts t #f (cons t-dty dbound) '())
-      (arr: ss s #f (cons s-dty dbound) '()))
-     (unless (= (length ts) (length ss))
-       (fail! S T))
+    ;; this case is just for constrainting other variables, not dbound
+    [((arr: ss s #f (cons s-dty dbound) '())
+      (arr: ts t #f (cons t-dty dbound) '()))
+     (unless (= (length ss) (length ts))
+       (fail! ss ts))
      ;; If we want to infer the dotted bound, then why is it in both types?
-     (when (memq dbound X)
-       (fail! S T))
-     (let* ([arg-mapping (cgen/list V X ss ts)]
-            [darg-mapping (cgen V X s-dty t-dty)]
-            [ret-mapping (cg t s)])
+     (when (memq dbound Y)
+       (fail! s-arr t-arr))
+     (let* ([arg-mapping (cgen/list V X Y ts ss)]
+            [darg-mapping (cgen V X Y t-dty s-dty)]
+            [ret-mapping (cg s t)])
        (cset-meet* 
         (list arg-mapping darg-mapping ret-mapping)))]
-    [((arr: ts t #f (cons t-dty dbound)  '())
-      (arr: ss s #f (cons s-dty dbound*) '()))
-     (unless (= (length ts) (length ss))
-       (fail! S T))
-     (let* ([arg-mapping (cgen/list V X ss ts)]
-            [darg-mapping (cgen V (cons dbound* X) s-dty t-dty)]
-            [ret-mapping (cg t s)])
+    ;; bounds are different
+    [((arr: ss s #f (cons s-dty (? (λ (db) (memq db Y)) dbound))  '())
+      (arr: ts t #f (cons t-dty dbound*) '()))
+     (unless (= (length ss) (length ts)) (fail! ss ts))
+     (when (memq dbound* Y) (fail! s-arr t-arr))
+     (let* ([arg-mapping (cgen/list V X Y ts ss)]
+            ;; just add dbound as something that can be constrained
+            [darg-mapping (move-dotted-rest-to-dmap (cgen V (cons dbound X) Y t-dty s-dty) dbound)]
+            [ret-mapping (cg s t)])
        (cset-meet* 
         (list arg-mapping darg-mapping ret-mapping)))]
-    [((arr: ts t t-rest #f                  '())
-      (arr: ss s #f     (cons s-dty dbound) '()))
-     (unless (memq dbound X)
-       (fail! S T))
-     (if (<= (length ts) (length ss))
+    [((arr: ss s #f (cons s-dty dbound)  '())
+      (arr: ts t #f (cons t-dty (? (λ (db) (memq db Y)) dbound*)) '()))
+     (unless (= (length ss) (length ts)) (fail! ss ts))
+     (let* ([arg-mapping (cgen/list V X Y ts ss)]
+            ;; just add dbound as something that can be constrained
+            [darg-mapping (move-dotted-rest-to-dmap (cgen V (cons dbound* X) Y t-dty s-dty) dbound*)]
+            [ret-mapping (cg s t)])
+       (cset-meet* 
+        (list arg-mapping darg-mapping ret-mapping)))]
+    ;; * <: ...
+    [((arr: ss s s-rest #f                  '())
+      (arr: ts t #f     (cons t-dty dbound) '()))
+     (unless (memq dbound Y)
+       (fail! s-arr t-arr))
+     (if (<= (length ss) (length ts))
          ;; the simple case
-         (let* ([arg-mapping (cgen/list V X ss (extend ss ts t-rest))]
-                [darg-mapping (move-rest-to-dmap (cgen V X s-dty t-rest) dbound)]
-                [ret-mapping (cg t s)])
+         (let* ([arg-mapping (cgen/list V X Y ts (extend ts ss s-rest))]
+                [darg-mapping (move-rest-to-dmap (cgen V (cons dbound X) Y t-dty s-rest) dbound)]
+                [ret-mapping (cg s t)])
            (cset-meet* (list arg-mapping darg-mapping ret-mapping)))
          ;; the hard case
-         (let* ([num-vars (- (length ts) (length ss))]
-                [vars     (for/list ([n (in-range num-vars)])
+         (let* ([vars     (for/list ([n (in-range (- (length ss) (length ts)))])
                             (gensym dbound))]
                 [new-tys  (for/list ([var vars])
-                            (substitute (make-F var) dbound s-dty))]
-                [new-cset (cgen/arr V (append vars X) t-arr 
-                                    (make-arr (append ss new-tys) s #f (cons s-dty dbound) null))])
+                            (substitute (make-F var) dbound t-dty))]
+                [new-t-arr (make-arr (append ts new-tys) t #f (cons t-dty dbound) null)]
+                [new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)])
            (move-vars+rest-to-dmap new-cset dbound vars)))]
     ;; If dotted <: starred is correct, add it below.  Not sure it is.
-    [((arr: ts t #f     (cons t-dty dbound) '())
-      (arr: ss s s-rest #f                  '()))
-     (unless (memq dbound X)
-       (fail! S T))
-     (cond [(< (length ts) (length ss))
+    [((arr: ss s #f     (cons s-dty dbound) '())
+      (arr: ts t t-rest #f                  '()))
+     (unless (memq dbound Y)
+       (fail! s-arr t-arr))
+     (cond [(< (length ss) (length ts))
             ;; the hard case
-            (let* ([num-vars (- (length ss) (length ts))]
-                   [vars     (for/list ([n (in-range num-vars)])
+            (let* ([vars     (for/list ([n (in-range (- (length ts) (length ss)))])
                                (gensym dbound))]
                    [new-tys  (for/list ([var vars])
-                               (substitute (make-F var) dbound t-dty))]
-                   [arg-mapping (cgen/list V (append vars X) ss (append ts new-tys))]
-                   [darg-mapping (cgen V X s-rest t-dty)]
-                   [ret-mapping (cg t s)]
-                   [new-cset
-                    (cset-meet* (list arg-mapping darg-mapping ret-mapping))])
+                               (substitute (make-F var) dbound s-dty))]
+                   [new-s-arr (make-arr (append ss new-tys) s #f (cons s-dty dbound) null)]
+                   [new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)])
               (move-vars+rest-to-dmap new-cset dbound vars #:exact #t))]
            [else
             ;; the simple case
-            (let* ([arg-mapping (cgen/list V X (extend ts ss s-rest) ts)]
-                   [darg-mapping (move-rest-to-dmap (cgen V X s-rest t-dty) dbound #:exact #t)]
-                   [ret-mapping (cg t s)])
+            (let* ([arg-mapping (cgen/list V X Y (extend ss ts t-rest) ss)]
+                   [darg-mapping (move-rest-to-dmap (cgen V (cons dbound X) Y t-rest s-dty) dbound #:exact #t)]
+                   [ret-mapping (cg s t)])
               (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])]
-    [(_ _) (fail! S T)]))
+    [(_ _) (fail! s-arr t-arr)]))
 
-;; determine constraints on the variables in X that would make T a supertype of S
-;; the resulting constraints will not mention V
-(define (cgen V X S T)
-  (define (cg S T) (cgen V X S T))
-  (define empty (empty-cset X))
-  (define (singleton S X T)
-    (insert empty X S T))
+(define (cgen/flds V X Y flds-s flds-t)
+  (cset-meet*
+   (for/list ([s (in-list flds-s)] [t (in-list flds-t)])
+     (match* (s t)
+       ;; mutable - invariant
+       [((fld: s _ #t) (fld: t _ #t)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))]
+       ;; immutable - covariant
+       [((fld: s _ #f) (fld: t _ #f)) (cgen V X Y s t)]))))
+
+;; V : a set of variables not to mention in the constraints
+;; X : the set of type variables to be constrained
+;; Y : the set of index variables to be constrained
+;; S : a type to be the subtype of T
+;; T : a type
+;; produces a cset which determines a substitution that makes S a subtype of T
+;; implements the V |-_X S <: T => C judgment from Pierce+Turner, extended with
+;; the index variables from the TOPLAS paper
+(d/c (cgen V X Y S T)
+  ((listof symbol?) (listof symbol?) (listof symbol?) Type? Type? . -> . cset?)
+  ;; useful quick loop
+  (define (cg S T) (cgen V X Y S T))
+  ;; this places no constraints on any variables in X
+  (define empty (empty-cset X Y))
+  ;; this constrains just x (which is a single var)
+  (define (singleton S x T)
+    (insert empty x S T))
+  ;; if we've been around this loop before, we're done (for rec types)
   (if (seen? S T)
       empty
       (parameterize ([match-equality-test (lambda (a b) (if (and (Rep? a) (Rep? b)) (type-equal? a b) (equal? a b)))]
+                     ;; remember S and T, and obtain everything we've seen from the context
+                     ;; we can't make this an argument since we may call back and forth with subtyping, for example
                      [current-seen (remember S T (current-seen))])
-        (match* 
-            (S T)
+        (match* (S T)
+          ;; if they're equal, no constraints are necessary (CG-Refl)
           [(a a) empty]
+          ;; CG-Top
           [(_ (Univ:)) empty]
 
+          ;; refinements are erased to their bound
           [((Refinement: S _ _) T)
            (cg S T)]
 
-          [((F: (? (lambda (e) (memq e X)) v)) S)
-           (when (match S
-                   [(F: v*)
-                    (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
-                   [_ #f])
-             (fail! S T))
-           (singleton (Un) v (var-demote S V))]
+          ;; variables that are in X and should be constrained
+          ;; all other variables are compatible only with themselves
+          [((F: (? (λ (e) (memq e X)) v)) T)
+           (match T
+             ;; only possible when v* is an index
+             [(F: v*) (when (and (bound-index? v*) (not (bound-tvar? v*)))
+                        (fail! S T))]
+             [_ (void)])
+           ;; constrain v to be below T (but don't mention V)
+           (singleton (Un) v (var-demote T V))]
           [(S (F: (? (lambda (e) (memq e X)) v)))
-           (when (match S
-                   [(F: v*)
-                    (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
-                   [_ #f])
-             (fail! S T))
+           (match S
+             [(F: v*) (when (and (bound-index? v*) (not (bound-tvar? v*)))
+                        (fail! S T))]
+             [_ (void)])
+           ;; constrain v to be above S (but don't mention V)
            (singleton (var-promote S V) v Univ)]
-
-          ;; two unions with the same number of elements, so we just try to unify them pairwise
-          #;[((Union: l1) (Union: l2))
-             (=> unmatch)
-             (unless (= (length l1) (length l2))
-               (unmatch))
-             (cgen-union V X l1 l2)]
           
-          #;[((Poly: v1 b1) (Poly: v2 b2))
-             (unless (= (length v1) (length v2))
-               (fail! S T))
-             (let ([b2* (subst-all (map list v2 v1) b2)])
-               (cg b1 b2*))]
+          ;; constrain b1 to be below T, but don't mention the new vars
+          [((Poly: v1 b1) T) (cgen (append v1 V) X Y b1 T)]
           
-          #;[((PolyDots: (list v1 ... r1) b1) (PolyDots: (list v2 ... r2) b2))
-             (unless (= (length v1) (length v2))
-               (fail! S T))
-             (let ([b2* (substitute-dotted v1 v1 v2 (subst-all (map list v2 v1) b2))])
-               (cg b1 b2*))]
+          ;; constrain *each* element of es to be below T, and then combine the constraints
+          [((Union: es) T) (cset-meet* (cons empty (for/list ([e es]) (cg e T))))]
           
-          [((Poly: v1 b1) T)
-           (cgen (append v1 V) X b1 T)]
+          ;; find *an* element of es which can be made to be a supertype of S
+          ;; FIXME: we're using multiple csets here, but I don't think it makes a difference 
+          ;; not using multiple csets will break for: ???
+          [(S (Union: es)) 
+           (cset-combine
+            (filter values
+                    (for/list ([e es]) 
+                      (with-handlers ([exn:infer? (λ _ #f)]) (cg S e)))))]
           
-          #;[((PolyDots: (list v1 ... r1) b1) T)
-             (let ([b1* (var-demote b1 (cons r1 v1))])
-               (cg b1* T))]
+          ;; two structs with the same name and parent
+          ;; just check pairwise on the fields
+          [((Struct: nm p flds proc _ _ _ _) (Struct: nm p flds* proc* _ _ _ _))
+           (let ([proc-c
+                  (cond [(and proc proc*)
+                         (cg proc proc*)]
+                        [proc* (fail! S T)]
+                        [else empty])])
+             (cset-meet proc-c (cgen/flds V X Y flds flds*)))]
           
-          #;
-          [((Poly-unsafe: n b) (Poly-unsafe: n* b*))
-           (unless (= n n*)
-             (fail! S T))
-           (cg b b*)]
-          
-          
-          [((Union: es) S) (cset-meet* (cons empty (for/list ([e es]) (cg e S))))]
-          ;; we might want to use multiple csets here, but I don't think it makes a difference
-          [(S (Union: es)) (or
-                            (for/or 
-                             ([e es]) 
-                             (with-handlers
-                                 ([exn:infer? (lambda _ #f)])
-                               (cg S e)))
-                            (fail! S T))]
-          
-          [((Struct: nm p flds proc _ _ _ _ _) (Struct: nm p flds* proc* _ _ _ _ _))
-           (let-values ([(flds flds*)
-                         (cond [(and proc proc*)
-                                (values (cons proc flds) (cons proc* flds*))]
-                               [(or proc proc*)
-                                (fail! S T)]
-                               [else (values flds flds*)])])
-             (cgen/list V X flds flds*))]
+          ;; two struct names, need to resolve b/c one could be a parent
           [((Name: n) (Name: n*))
            (if (free-identifier=? n n*)
                null
-               (fail! S T))]
+               (cg (resolve-once S) (resolve-once T)))]
+          ;; pairs are pointwise
           [((Pair: a b) (Pair: a* b*))
            (cset-meet (cg a a*) (cg b b*))]
+          ;; sequences are covariant
+          [((Sequence: ts) (Sequence: ts*))
+           (cgen/list V X Y ts ts*)]
+          [((Listof: t) (Sequence: (list t*)))
+           (cg t t*)]
+          [((List: ts) (Sequence: (list t*)))
+           (cset-meet* (for/list ([t (in-list ts)])
+                         (cg t t*)))]
+          [((HeterogenousVector: ts) (HeterogenousVector: ts*))
+           (cset-meet (cgen/list V X Y ts ts*) (cgen/list V X Y ts* ts))]
+          [((HeterogenousVector: ts) (Sequence: (list t*)))
+           (cset-meet* (for/list ([t (in-list ts)])
+                         (cg t t*)))]
+          [((Vector: t) (Sequence: (list t*)))
+           (cg t t*)]
+          [((Base: 'String _) (Sequence: (list t*)))
+           (cg -Char t*)]
+          [((Base: 'Bytes _) (Sequence: (list t*)))
+           (cg -Nat t*)]
+          [((Base: 'Input-Port _) (Sequence: (list t*)))
+           (cg -Nat t*)]
+          [((Vector: t) (Sequence: (list t*)))
+           (cg t t*)]
+          [((Hashtable: k v) (Sequence: (list k* v*)))
+           (cgen/list V X Y (list k v) (list k* v*))]
+          ;; ListDots can be below a Listof
+          ;; must be above mu unfolding
+          [((ListDots: s-dty dbound) (Listof: t-elem))
+           (when (memq dbound Y) (fail! S T))
+           (cgen V X Y (substitute Univ dbound s-dty) t-elem)]
+          ;; two ListDots with the same bound, just check the element type
+          [((ListDots: s-dty dbound) (ListDots: t-dty dbound))
+           (when (memq dbound Y) (fail! S T))
+           (cgen V X Y s-dty t-dty)]
+          [((ListDots: s-dty (? (λ (db) (memq db Y)) s-dbound)) (ListDots: t-dty t-dbound))
+           ;; What should we do if both are in Y?
+           (when (memq t-dbound Y) (fail! S T))
+           (move-dotted-rest-to-dmap (cgen V (cons s-dbound X) Y s-dty t-dty) s-dbound)]
+          [((ListDots: s-dty s-dbound) (ListDots: t-dty (? (λ (db) (memq db Y)) t-dbound)))
+           ;; s-dbound can't be in Y, due to previous rule
+           (move-dotted-rest-to-dmap (cgen V (cons t-dbound X) Y s-dty t-dty) t-dbound)]
+          
+          ;; this constrains `dbound' to be |ts| - |ss|
+          [((ListDots: s-dty dbound) (List: ts))
+           (unless (memq dbound Y) (fail! S T))
+           
+           (let* ([vars     (for/list ([n (in-range (length ts))])
+                              (gensym dbound))]
+                  ;; new-tys are dummy plain type variables, standing in for the elements of dbound that need to be generated
+                  [new-tys  (for/list ([var vars])
+                              (substitute (make-F var) dbound s-dty))]
+                  ;; generate constraints on the prefixes, and on the dummy types
+                  [new-cset (cgen/list V (append vars X) Y new-tys ts)])
+             ;; now take all the dummy types, and use them to constrain dbound appropriately
+             (move-vars-to-dmap new-cset dbound vars))]
+          
           ;; if we have two mu's, we rename them to have the same variable
           ;; and then compare the bodies
+          ;; This relies on (B 0) only unifying with itself, and thus only hitting the first case of this `match'
           [((Mu-unsafe: s) (Mu-unsafe: t)) 
            (cg s t)]
+          
           ;; other mu's just get unfolded
           [(s (? Mu? t)) (cg s (unfold t))]
           [((? Mu? s) t) (cg (unfold s) t)]
-          ;; type application          
-          [((App: (Name: n) args _)
-            (App: (Name: n*) args* _))
-           (unless (free-identifier=? n n*)
-             (fail! S T))
-             (cg (resolve-once S) (resolve-once T))]
+                    
+          ;; resolve applications
           [((App: _ _ _) _) (cg (resolve-once S) T)]
           [(_ (App: _ _ _)) (cg S (resolve-once T))]
+          
+          ;; values are covariant
           [((Values: ss) (Values: ts))
            (unless (= (length ss) (length ts))
              (fail! ss ts))
-           (cgen/list V X ss ts)]
-          [((Values: ss) (ValuesDots: ts t-dty dbound))
-           (unless (>= (length ss) (length ts))
-             (fail! ss ts))
-           (unless (memq dbound X)
-             (fail! S T))
-           (let* ([num-vars (- (length ss) (length ts))]
-                  [vars     (for/list ([n (in-range num-vars)])
-                              (gensym dbound))]
-                  [new-tys  (for/list ([var vars])
-                              (substitute (make-F var) dbound t-dty))]
-                  [new-cset (cgen/list V (append vars X) ss (append ts new-tys))])
-             (move-vars-to-dmap new-cset dbound vars))]
+           (cgen/list V X Y ss ts)]
+          
+          ;; this constrains `dbound' to be |ts| - |ss|
           [((ValuesDots: ss s-dty dbound) (Values: ts))
-           (unless (>= (length ts) (length ss))
-             (fail! ss ts))
-           (unless (memq dbound X)
-             (fail! S T))
-           (let* ([num-vars (- (length ts) (length ss))]
-                  [vars     (for/list ([n (in-range num-vars)])
+           (unless (>= (length ts) (length ss)) (fail! ss ts))
+           (unless (memq dbound Y) (fail! S T))
+           
+           (let* ([vars     (for/list ([n (in-range (- (length ts) (length ss)))])
                               (gensym dbound))]
+                  ;; new-tys are dummy plain type variables, standing in for the elements of dbound that need to be generated
                   [new-tys  (for/list ([var vars])
                               (substitute (make-F var) dbound s-dty))]
-                  [new-cset (cgen/list V (append vars X) (append ss new-tys) ts)])
+                  ;; generate constraints on the prefixes, and on the dummy types
+                  [new-cset (cgen/list V (append vars X) Y (append ss new-tys) ts)])
+             ;; now take all the dummy types, and use them to constrain dbound appropriately
              (move-vars-to-dmap new-cset dbound vars))]
+          
+          ;; identical bounds - just unify pairwise
           [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound))
-           (when (memq dbound X) (fail! ss ts))          
-           (cgen/list V X (cons s-dty ss) (cons t-dty ts))]
+           (when (memq dbound Y) (fail! ss ts))          
+           (cgen/list V X Y (cons s-dty ss) (cons t-dty ts))]
+          [((ValuesDots: ss s-dty (? (λ (db) (memq db Y)) s-dbound)) (ValuesDots: ts t-dty t-dbound))
+           ;; What should we do if both are in Y?
+           (when (memq t-dbound Y) (fail! S T))
+           (cset-meet
+            (cgen/list V X Y ss ts)
+            (move-dotted-rest-to-dmap (cgen V (cons s-dbound X) Y s-dty t-dty) s-dbound))]
+          [((ValuesDots: ss s-dty s-dbound) (ValuesDots: ts t-dty (? (λ (db) (memq db Y)) t-dbound)))
+           ;; s-dbound can't be in Y, due to previous rule
+           (cset-meet
+            (cgen/list V X Y ss ts)
+            (move-dotted-rest-to-dmap (cgen V (cons t-dbound X) Y s-dty t-dty) t-dbound))]
+          ;; vectors are invariant - generate constraints *both* ways
           [((Vector: e) (Vector: e*))
            (cset-meet (cg e e*) (cg e* e))]
+          ;; boxes are invariant - generate constraints *both* ways
           [((Box: e) (Box: e*))
            (cset-meet (cg e e*) (cg e* e))]
+          [((MPair: s t) (MPair: s* t*))
+           (cset-meet* (list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))]
+          [((Channel: e) (Channel: e*))
+           (cset-meet (cg e e*) (cg e* e))]
+          ;; we assume all HTs are mutable at the moment
           [((Hashtable: s1 s2) (Hashtable: t1 t2))
            ;; for mutable hash tables, both are invariant
            (cset-meet* (list (cg t1 s1) (cg s1 t1) (cg t2 s2) (cg s2 t2)))]
+          ;; syntax is covariant
           [((Syntax: s1) (Syntax: s2))
            (cg s1 s2)]
           ;; parameters are just like one-arg functions
           [((Param: in1 out1) (Param: in2 out2))
            (cset-meet (cg in2 in1) (cg out1 out2))]
+          ;; every function is trivially below top-arr
           [((Function: _)
             (Function: (list (top-arr:))))
            empty]
-          [((Function: (list t-arr ...))
-            (Function: (list s-arr ...)))
-           (=> unmatch)
-           (cset-combine
-            (filter 
-             values ;; only generate the successful csets
-             (for*/list 
-              ([t-arr t-arr] [s-arr s-arr])
-              (with-handlers ([exn:infer? (lambda (_) #f)])
-                (cgen/arr V X t-arr s-arr)))))]
-          ;; this is overly conservative
+          [((Function: (list s-arr ...))
+            (Function: (list t-arr ...)))
+           (cset-meet*
+            (for/list ([t-arr t-arr])
+              ;; for each element of t-arr, we need to get at least one element of s-arr that works
+              (let ([results (filter values
+                                     (for/list ([s-arr s-arr])
+                                       (with-handlers ([exn:infer? (lambda (_) #f)])
+                                         (cgen/arr V X Y s-arr t-arr))))])
+                ;; ensure that something produces a constraint set
+                (when (null? results) (fail! S T))
+                (cset-combine results))))]
+          ;; check each element
           [((Result: s f-s o-s)
             (Result: t f-t o-t))
            (cset-meet* (list (cg s t) 
-                             (cgen/filter-set V X f-s f-t)
-                             (cgen/object V X o-s o-t)))]
+                             (cgen/filter-set V X Y f-s f-t)
+                             (cgen/object V X Y o-s o-t)))]
           [(_ _)
-           (cond [(subtype S T) empty]
-                 ;; or, nothing worked, and we fail
-                 [else (fail! S T)])]))))
+           (cond 
+             ;; subtypes are easy - should this go earlier?
+             [(subtype S T) empty]
+             ;; or, nothing worked, and we fail
+             [else (fail! S T)])]))))
 
-(define (check-vars must-vars subst)
-  (and (for/and ([v must-vars])
-                (assq v subst))
-       subst))
-
-(define (subst-gen C R must-vars)
-  (define (constraint->type v #:variable [variable #f])
+;; C : cset? - set of constraints found by the inference engine
+;; Y : (listof symbol?) - index variables that must have entries
+;; R : Type? - result type into which we will be substituting
+(d/c (subst-gen C Y R)
+  (cset? (listof symbol?) Type? . -> . (or/c #f substitution/c))
+  (define var-hash (free-vars* R))
+  (define idx-hash (free-idxs* R))
+  ;; v : Symbol - variable for which to check variance
+  ;; h : (Hash Symbol Variance) - hash to check variance in (either var or idx hash)
+  ;; variable: Symbol - variable to use instead, if v was a temp var for idx extension
+  (define (constraint->type v h #:variable [variable #f])
     (match v
-      [(struct c (S X T))
-       (let ([var (hash-ref (free-vars* R) (or variable X) Constant)])
+      [(c S X T)
+       (let ([var (hash-ref h (or variable X) Constant)])
          ;(printf "variance was: ~a~nR was ~a~nX was ~a~nS T ~a ~a~n" var R (or variable X) S T)
          (evcase var 
                  [Constant S]
                  [Covariant S]
                  [Contravariant T]
-                 [Invariant S]
-                 [Dotted T]))]))
+                 [Invariant 
+                  (let ([gS (generalize S)])
+                    ;(printf "Inv var: ~a ~a ~a ~a\n" v S gS T)
+                    (if (subtype gS T)
+                        gS
+                        S))]))]))
+  ;; Since we don't add entries to the empty cset for index variables (since there is no
+  ;; widest constraint, due to dcon-exacts), we must add substitutions here if no constraint
+  ;; was found.  If we're at this point and had no other constraints, then adding the
+  ;; equivalent of the constraint (dcon null (c Bot X Top)) is okay.
+  (define (extend-idxs S)
+    (define fi-R (fi R))
+    ;; If the index variable v is not used in the type, then
+    ;; we allow it to be replaced with the empty list of types;
+    ;; otherwise we error, as we do not yet know what an appropriate
+    ;; lower bound is.
+    (define (demote/check-free v)
+      (if (memq v fi-R)
+          (int-err "attempted to demote dotted variable")
+          (i-subst null)))
+    ;; absent-entries is #f if there's an error in the substitution, otherwise
+    ;; it's a list of variables that don't appear in the substitution
+    (define absent-entries
+      (for/fold ([no-entry null]) ([v (in-list Y)])
+        (let ([entry (hash-ref S v #f)])
+          ;; Make sure we got a subst entry for an index var
+          ;; (i.e. a list of types for the fixed portion
+          ;;  and a type for the starred portion)
+          (cond
+            [(not no-entry) no-entry]
+            [(not entry) (cons v no-entry)]
+            [(or (i-subst? entry) (i-subst/starred? entry) (i-subst/dotted? entry)) no-entry]
+            [else #f]))))
+    (and absent-entries
+         (hash-union
+          (for/hash ([missing (in-list absent-entries)])
+            (let ([var (hash-ref idx-hash missing Constant)])
+              (values missing
+                      (evcase var
+                              [Constant (demote/check-free missing)]
+                              [Covariant (demote/check-free missing)]
+                              [Contravariant (i-subst/starred null Univ)]
+                              [Invariant (demote/check-free missing)]))))
+          S)))
   (match (car (cset-maps C))
-    [(cons cmap (struct dmap (dm)))
-     (check-vars
-      must-vars
-      (append 
-       (for/list ([(k dc) (in-hash dm)])
-         (match dc
-           [(struct dcon (fixed rest))
-            (list k
-                  (for/list ([f fixed])
-                    (constraint->type f #:variable k))
-                  (and rest (constraint->type rest)))]
-           [(struct dcon-exact (fixed rest))
-            (list k
-                  (for/list ([f fixed])
-                    (constraint->type f #:variable k))
-                  (constraint->type rest))]))
-       (for/list ([(k v) (in-hash cmap)])
-         (list k (constraint->type v)))))]))
+    [(cons cmap (dmap dm))
+     (let ([subst (hash-union 
+                   (for/hash ([(k dc) (in-hash dm)])
+                     (match dc
+                       [(dcon fixed #f)
+                        (values k
+                                (i-subst
+                                 (for/list ([f fixed])
+                                   (constraint->type f idx-hash #:variable k))))]
+                       [(dcon fixed rest)
+                        (values k
+                                (i-subst/starred (for/list ([f fixed])
+                                                   (constraint->type f idx-hash #:variable k))
+                                                 (constraint->type rest idx-hash)))]
+                       [(dcon-exact fixed rest)
+                        (values k
+                                (i-subst/starred
+                                 (for/list ([f fixed])
+                                   (constraint->type f idx-hash #:variable k))
+                                 (constraint->type rest idx-hash)))]
+                       [(dcon-dotted fixed dc dbound)
+                        (values k
+                                (i-subst/dotted
+                                 (for/list ([f fixed])
+                                   (constraint->type f idx-hash #:variable k))
+                                 (constraint->type dc idx-hash #:variable k)
+                                 dbound))]))
+                   (for/hash ([(k v) (in-hash cmap)])
+                     (values k (t-subst (constraint->type v var-hash)))))])
+       ;; verify that we got all the important variables
+       (and (for/and ([v (fv R)])
+              (let ([entry (hash-ref subst v #f)])
+                ;; Make sure we got a subst entry for a type var
+                ;; (i.e. just a type to substitute)
+                (and entry (t-subst? entry))))
+            (extend-idxs subst)))]))
 
-(define (cgen/list V X S T)
+;; V : a set of variables not to mention in the constraints
+;; X : the set of type variables to be constrained
+;; Y : the set of index variables to be constrained
+;; S : a list of types to be the subtypes of T
+;; T : a list of types
+;; produces a cset which determines a substitution that makes the Ss subtypes of the Ts
+(d/c (cgen/list V X Y S T)
+  ((listof symbol?) (listof symbol?) (listof symbol?) (listof Type?) (listof Type?) . -> . cset?)
   (unless (= (length S) (length T))
     (fail! S T))
-  (cset-meet* (for/list ([s S] [t T]) (cgen V X s t))))
+  (cset-meet* (for/list ([s S] [t T]) (cgen V X Y s t))))
 
 ;; X : variables to infer
+;; Y : indices to infer
 ;; S : actual argument types
 ;; T : formal argument types
 ;; R : result type
-;; must-vars : variables that must be in the substitution
 ;; expected : boolean
 ;; returns a substitution
 ;; if R is #f, we don't care about the substituion
 ;; just return a boolean result
-(define (infer X S T R must-vars [expected #f])
+(define (infer X Y S T R [expected #f])
   (with-handlers ([exn:infer? (lambda _ #f)])  
-    (let ([cs (cgen/list null X S T)])
-      (if (not expected)
-          (subst-gen cs R must-vars)
-          (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars)))))
+    (let* ([cs (cgen/list null X Y S T)]
+           [cs* (if expected 
+                    (cset-meet cs (cgen null X Y R expected))
+                    cs)])
+          (if R (subst-gen cs* Y R) #t))))
 
 ;; like infer, but T-var is the vararg type:
-(define (infer/vararg X S T T-var R must-vars [expected #f])
+(define (infer/vararg X Y S T T-var R [expected #f])
   (define new-T (if T-var (extend S T T-var) T))
   (and ((length S) . >= . (length T))
-       (infer X S new-T R must-vars expected)))
+       (infer X Y S new-T R expected)))
 
 ;; like infer, but dotted-var is the bound on the ...
 ;; and T-dotted is the repeated type
@@ -493,22 +650,16 @@
   (with-handlers ([exn:infer? (lambda _ #f)])
     (let* ([short-S (take S (length T))]
            [rest-S (drop S (length T))]
-           [cs-short (cgen/list null (cons dotted-var X) short-S T)]
+           [cs-short (cgen/list null X (list dotted-var) short-S T)]
            [new-vars (for/list ([i (in-range (length rest-S))]) (gensym dotted-var))]
            [new-Ts (for/list ([v new-vars])
                      (substitute (make-F v) dotted-var 
                                  (substitute-dots (map make-F new-vars) #f dotted-var T-dotted)))]
-           [cs-dotted (cgen/list null (append new-vars X) rest-S new-Ts)]
+           [cs-dotted (cgen/list null (append new-vars X) (list dotted-var) rest-S new-Ts)]
            [cs-dotted* (move-vars-to-dmap cs-dotted dotted-var new-vars)]
            [cs (cset-meet cs-short cs-dotted*)])
       (if (not expected)
-          (subst-gen cs R must-vars)
-          (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars)))))
-
-(define (infer/simple S T R)
-  (infer (fv/list T) S T R))
-
-(define (i s t r)
-  (infer/simple (list s) (list t) r))
+          (subst-gen cs (list dotted-var) R)
+          (subst-gen (cset-meet cs (cgen null X (list dotted-var) R expected)) (list dotted-var) R)))))
 
 ;(trace cgen)
diff --git a/collects/typed-scheme/infer/promote-demote.rkt b/collects/typed-scheme/infer/promote-demote.rkt
index 5d2daef8..334eecc7 100644
--- a/collects/typed-scheme/infer/promote-demote.rkt
+++ b/collects/typed-scheme/infer/promote-demote.rkt
@@ -25,6 +25,7 @@
              [#:F name (if (memq name V) Univ T)]
              [#:Vector t (make-Vector (inv t))]
              [#:Box t (make-Box (inv t))]
+             [#:Channel t (make-Channel (inv t))]
              [#:Hashtable k v
                           (if (V-in? V v)
                               Univ
@@ -58,6 +59,7 @@
              [#:F name (if (memq name V) (Un) T)]
              [#:Vector t (make-Vector (inv t))]
              [#:Box t (make-Box (inv t))]
+             [#:Channel t (make-Channel (inv t))]
              [#:Hashtable k v
                           (if (V-in? V v)
                               (Un)
diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-scheme/infer/restrict.rkt
index 6e45ac59..9664ee4b 100644
--- a/collects/typed-scheme/infer/restrict.rkt
+++ b/collects/typed-scheme/infer/restrict.rkt
@@ -2,7 +2,7 @@
 
 (require "../utils/utils.rkt")
 (require (rep type-rep)
-	 (types utils union subtype remove-intersect resolve)
+	 (types utils union subtype remove-intersect resolve substitute)
          "signatures.rkt"
          scheme/match mzlib/trace)
 
@@ -23,7 +23,7 @@
     [(subtype t1 t2) t1] ;; already a subtype          
     [(match t2
        [(Poly: vars t)
-        (let ([subst (infer vars (list t1) (list t) t1 vars)])
+        (let ([subst (infer vars null (list t1) (list t) t1)])
           (and subst (restrict* t1 (subst-all subst t1))))]
        [_ #f])]           
     [(Union? t1) (union-map (lambda (e) (restrict* e t2)) t1)]
diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-scheme/infer/signatures.rkt
index 4dcf72ab..962bea83 100644
--- a/collects/typed-scheme/infer/signatures.rkt
+++ b/collects/typed-scheme/infer/signatures.rkt
@@ -1,6 +1,7 @@
-#lang scheme/base
-(require scheme/unit scheme/contract "constraint-structs.rkt" "../utils/utils.rkt")
-(require (rep type-rep) (utils unit-utils))
+#lang racket/base
+(require racket/unit racket/contract racket/require
+         "constraint-structs.rkt" 
+         (path-up "utils/utils.rkt" "utils/unit-utils.rkt" "rep/type-rep.rkt"))
 (provide (all-defined-out))
 
 (define-signature dmap^
@@ -16,11 +17,11 @@
    ;; inference failure - masked before it gets to the user program
    (define-syntaxes (fail!)
      (syntax-rules ()
-       [(_ s t) (raise fail-sym)]))
+       [(_ s t) (raise (list fail-sym s t))]))
    [cnt cset-meet (cset? cset? . -> . cset?)]
    [cnt cset-meet* ((listof cset?) . -> . cset?)]
    no-constraint
-   [cnt empty-cset ((listof symbol?) . -> . cset?)]
+   [cnt empty-cset ((listof symbol?) (listof symbol?) . -> . cset?)]
    [cnt insert (cset? symbol? Type? Type? . -> . cset?)]
    [cnt cset-combine ((listof cset?) . -> . cset?)]
    [cnt c-meet ((c? c?) (symbol?) . ->* . c?)]))
@@ -29,13 +30,32 @@
   ([cnt restrict (Type? Type? . -> . Type?)]))
 
 (define-signature infer^
-  ([cnt infer (((listof symbol?) (listof Type?) (listof Type?) Type? (listof symbol?)) ((or/c #f Type?)) . ->* . any)]
-   [cnt infer/vararg (((listof symbol?) 
+  ([cnt infer ((;; variables from the forall
+                (listof symbol?) 
+                ;; indexes from the forall
+                (listof symbol?) 
+                ;; actual argument types from call site
+                (listof Type?)
+                ;; domain
+                (listof Type?)
+                ;; range
+                (or/c #f Type?))
+               ;; optional expected type
+               ((or/c #f Type?)) 
+               . ->* . any)]
+   [cnt infer/vararg ((;; variables from the forall
+                       (listof symbol?) 
+                       ;; indexes from the forall
+                       (listof symbol?) 
+                       ;; actual argument types from call site
                        (listof Type?)
+                       ;; domain
                        (listof Type?)
+                       ;; rest
                        (or/c #f Type?)
-                       Type?
-                       (listof symbol?))
+                       ;; range
+                       (or/c #f Type?))
+                      ;; [optional] expected type
                       ((or/c #f Type?)) . ->* . any)]
    [cnt infer/dots (((listof symbol?) 
                      symbol?
diff --git a/collects/typed-scheme/main.rkt b/collects/typed-scheme/main.rkt
index 0e907ace..c135bc51 100644
--- a/collects/typed-scheme/main.rkt
+++ b/collects/typed-scheme/main.rkt
@@ -4,7 +4,7 @@
 
 (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
                  (except "private/prims.rkt")
-                 (except "private/base-types-new.rkt")
+                 (except "private/base-types.rkt")
                  (except "private/base-types-extra.rkt"))
 	   (basics #%module-begin		   		   		   
 		   #%top-interaction
diff --git a/collects/typed-scheme/no-check/lang/reader.rkt b/collects/typed-scheme/no-check/lang/reader.rkt
index c8265194..9448bbaf 100644
--- a/collects/typed-scheme/no-check/lang/reader.rkt
+++ b/collects/typed-scheme/no-check/lang/reader.rkt
@@ -5,4 +5,4 @@ typed-scheme/no-check
 #:read r:read
 #:read-syntax r:read-syntax
 
-(require (prefix-in r: "../../typed-reader.ss"))
+(require (prefix-in r: typed-scheme/typed-reader))
diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt
new file mode 100644
index 00000000..8959261e
--- /dev/null
+++ b/collects/typed-scheme/optimizer/fixnum.rkt
@@ -0,0 +1,77 @@
+#lang scheme
+
+(require syntax/parse
+         "../utils/utils.rkt"
+         (for-template scheme/base scheme/fixnum scheme/unsafe/ops)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide fixnum-expr fixnum-opt-expr)
+
+
+(define (mk-fixnum-tbl generic)
+  (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a"))
+
+;; due to undefined behavior when results are out of the fixnum range, only some
+;; fixnum operations can be optimized
+;; the following must be closed on fixnums
+(define binary-fixnum-ops
+  (dict-set
+   (dict-set
+    (dict-set
+     (dict-set
+      (dict-set
+       (dict-set
+        (mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max))
+        #'bitwise-and #'unsafe-fxand)
+       #'fxand #'unsafe-fxand)
+      #'bitwise-ior #'unsafe-fxior)
+     #'fxior #'unsafe-fxior)
+    #'bitwise-xor #'unsafe-fxxor)
+   #'fxxor #'unsafe-fxxor))
+(define-syntax-class fixnum-unary-op
+  (pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot)
+  (pattern (~or (~literal abs)         (~literal fxabs)) #:with unsafe #'unsafe-fxabs))
+;; closed on fixnums, but 2nd argument must not be 0
+(define-syntax-class nonzero-fixnum-binary-op
+  (pattern (~or (~literal quotient)  (~literal fxquotient))  #:with unsafe #'unsafe-fxquotient)
+  (pattern (~or (~literal modulo)    (~literal fxmodulo))    #:with unsafe #'unsafe-fxmodulo)
+  (pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder))
+
+(define-syntax-class (fixnum-op tbl)
+  (pattern i:id
+           #:when (dict-ref tbl #'i #f)
+           #:with unsafe (dict-ref tbl #'i)))
+
+
+(define-syntax-class fixnum-expr
+  (pattern e:expr
+           #:when (subtypeof? #'e -Fixnum)
+           #:with opt ((optimize) #'e)))
+(define-syntax-class nonzero-fixnum-expr
+  (pattern e:expr
+           #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum))
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class fixnum-opt-expr
+  (pattern (#%plain-app op:fixnum-unary-op n:fixnum-expr)
+           #:with opt
+           (begin (log-optimization "unary fixnum" #'op)
+                  #'(op.unsafe n.opt)))
+  (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops))
+                        n1:fixnum-expr
+                        n2:fixnum-expr
+                        ns:fixnum-expr ...)
+           #:with opt
+           (begin (log-optimization "binary fixnum" #'op)
+                  (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...))))
+  (pattern (#%plain-app op:nonzero-fixnum-binary-op
+                        n1:fixnum-expr
+                        n2:nonzero-fixnum-expr)
+           #:with opt
+           (begin (log-optimization "binary nonzero fixnum" #'op)
+                  #'(op.unsafe n1.opt n2.opt)))
+  (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-expr)
+           #:with opt
+           (begin (log-optimization "fixnum to float" #'op)
+                  #'(unsafe-fx->fl n.opt))))
diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt
new file mode 100644
index 00000000..15675b37
--- /dev/null
+++ b/collects/typed-scheme/optimizer/float.rkt
@@ -0,0 +1,88 @@
+#lang scheme/base
+
+(require syntax/parse
+         syntax/id-table racket/dict
+         (for-template scheme/base scheme/flonum scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (types abbrev type-table utils subtype)
+         (optimizer utils fixnum))
+
+(provide float-opt-expr float-op mk-float-tbl)
+
+
+(define (mk-float-tbl generic)
+  (mk-unsafe-tbl generic "fl~a" "unsafe-fl~a"))
+
+(define binary-float-ops
+  (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max)))
+(define binary-float-comps
+  (dict-set
+   (dict-set
+    (mk-float-tbl (list #'= #'<= #'< #'> #'>=))
+    ;; not a comparison, but takes 2 floats and does not return a float,
+    ;; unlike binary-float-ops
+    #'make-rectangular #'unsafe-make-flrectangular)
+   #'make-flrectangular #'unsafe-make-flrectangular))
+(define unary-float-ops
+  (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp
+                      #'sqrt #'round #'floor #'ceiling #'truncate)))
+
+(define-syntax-class (float-op tbl)
+  (pattern i:id
+           #:when (dict-ref tbl #'i #f)
+           #:with unsafe (dict-ref tbl #'i)))
+
+(define-syntax-class float-expr
+  (pattern e:expr
+           #:when (subtypeof? #'e -Flonum)
+           #:with opt ((optimize) #'e)))
+(define-syntax-class int-expr
+  (pattern e:expr
+           #:when (subtypeof? #'e -Integer)
+           #:with opt ((optimize) #'e)))
+
+;; if the result of an operation is of type float, its non float arguments
+;; can be promoted, and we can use unsafe float operations
+;; note: none of the unary operations have types where non-float arguments
+;;  can result in float (as opposed to real) results
+(define-syntax-class float-arg-expr
+  (pattern e:fixnum-expr
+           #:with opt #'(unsafe-fx->fl e.opt))
+  (pattern e:int-expr
+           #:with opt #'(->fl e.opt))
+  (pattern e:float-expr
+           #:with opt #'e.opt))
+
+(define-syntax-class float-opt-expr
+  (pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr))
+           #:when (subtypeof? #'res -Flonum)
+           #:with opt
+           (begin (log-optimization "unary float" #'op)
+                  #'(op.unsafe f.opt)))
+  (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops))
+                                  f1:float-arg-expr
+                                  f2:float-arg-expr
+                                  fs:float-arg-expr ...))
+           ;; if the result is a float, we can coerce integers to floats and optimize
+           #:when (subtypeof? #'res -Flonum)
+           #:with opt
+           (begin (log-optimization "binary float" #'op)
+                  (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
+  (pattern (~and res (#%plain-app (~var op (float-op binary-float-comps))
+                                  f1:float-expr
+                                  f2:float-expr
+                                  fs:float-expr ...))
+           #:with opt
+           (begin (log-optimization "binary float comp" #'op)
+                  (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
+  
+  ;; we can optimize exact->inexact if we know we're giving it an Integer
+  (pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-expr)
+           #:with opt
+           (begin (log-optimization "int to float" #'op)
+                  #'(->fl n.opt)))
+  ;; we can get rid of it altogether if we're giving it an inexact number
+  (pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-expr)
+           #:with opt
+           (begin (log-optimization "float to float" #'op)
+                  #'f.opt)))
diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt
new file mode 100644
index 00000000..bdaaadc3
--- /dev/null
+++ b/collects/typed-scheme/optimizer/inexact-complex.rkt
@@ -0,0 +1,142 @@
+#lang scheme/base
+
+(require syntax/parse
+         "../utils/utils.rkt"
+         (for-template scheme/base scheme/flonum scheme/unsafe/ops)
+         (types abbrev type-table utils subtype)
+         (optimizer utils float))
+
+(provide inexact-complex-opt-expr)
+
+
+;; it's faster to take apart a complex number and use unsafe operations on
+;; its parts than it is to use generic operations
+;; we keep the real and imaginary parts unboxed as long as we stay within
+;; complex operations
+(define-syntax-class unboxed-inexact-complex-opt-expr
+  (pattern (#%plain-app (~and (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -)))
+                        c1:unboxed-inexact-complex-opt-expr
+                        c2:unboxed-inexact-complex-opt-expr
+                        cs:unboxed-inexact-complex-opt-expr ...)
+           #:with real-part (unboxed-gensym)
+           #:with imag-part (unboxed-gensym)
+           #:with (bindings ...)
+           (begin (log-optimization "unboxed binary inexact complex" #'op)
+                  #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
+                                (list #`(real-part #,(for/fold ((o #'c1.real-part))
+                                                         ((e (syntax->list #'(c2.real-part cs.real-part ...))))
+                                                       #`(op.unsafe #,o #,e)))
+                                      #`(imag-part #,(for/fold ((o #'c1.imag-part))
+                                                         ((e (syntax->list #'(c2.imag-part cs.imag-part ...))))
+                                                       #`(op.unsafe #,o #,e))))))))
+  (pattern (#%plain-app (~and op (~literal *))
+                        c1:unboxed-inexact-complex-opt-expr
+                        c2:unboxed-inexact-complex-opt-expr
+                        cs:unboxed-inexact-complex-opt-expr ...)
+           #:with real-part (unboxed-gensym)
+           #:with imag-part (unboxed-gensym)
+           #:with (bindings ...)
+           (begin (log-optimization "unboxed binary inexact complex" #'op)
+                  #`(c1.bindings ... c2.bindings ... cs.bindings ... ...
+                     ;; we want to bind the intermediate results to reuse them
+                     ;; the final results are bound to real-part and imag-part
+                     #,@(let loop ([o1 #'c1.real-part]
+                                   [o2 #'c1.imag-part]
+                                   [e1 (syntax->list #'(c2.real-part cs.real-part ...))]
+                                   [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]
+                                   [rs (append (map (lambda (x) (unboxed-gensym))
+                                                    (syntax->list #'(cs.real-part ...)))
+                                               (list #'real-part))]
+                                   [is (append (map (lambda (x) (unboxed-gensym))
+                                                    (syntax->list #'(cs.imag-part ...)))
+                                               (list #'imag-part))]
+                                   [res '()])
+                          (if (null? e1)
+                              (reverse res)
+                              (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is)
+                                    ;; complex multiplication, imag part, then real part (reverse)
+                                    (list* #`(#,(car is)
+                                              (unsafe-fl+ (unsafe-fl* #,o2 #,(car e1))
+                                                          (unsafe-fl* #,o1 #,(car e2))))
+                                           #`(#,(car rs)
+                                              (unsafe-fl- (unsafe-fl* #,o1 #,(car e1))
+                                                          (unsafe-fl* #,o2 #,(car e2))))
+                                           res)))))))
+  (pattern (#%plain-app (~and op (~literal /))
+                        c1:unboxed-inexact-complex-opt-expr
+                        c2:unboxed-inexact-complex-opt-expr
+                        cs:unboxed-inexact-complex-opt-expr ...)
+           #:with real-part (unboxed-gensym)
+           #:with imag-part (unboxed-gensym)
+           #:with (denominators ...)
+           (for/list
+            ([e1 (syntax->list #'(c2.real-part cs.real-part ...))]
+             [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))])
+            #`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2))))
+           #:with (bindings ...)
+           (begin (log-optimization "unboxed binary inexact complex" #'op)
+                  #`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ...
+                     ;; we want to bind the intermediate results to reuse them
+                     ;; the final results are bound to real-part and imag-part
+                     #,@(let loop ([o1 #'c1.real-part]
+                                   [o2 #'c1.imag-part]
+                                   [e1 (syntax->list #'(c2.real-part cs.real-part ...))]
+                                   [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]
+                                   [d  (map (lambda (x) (car (syntax-e x)))
+                                            (syntax->list #'(denominators ...)))]
+                                   [rs (append (map (lambda (x) (unboxed-gensym))
+                                                    (syntax->list #'(cs.real-part ...)))
+                                               (list #'real-part))]
+                                   [is (append (map (lambda (x) (unboxed-gensym))
+                                                    (syntax->list #'(cs.imag-part ...)))
+                                               (list #'imag-part))]
+                                   [res '()])
+                          (if (null? e1)
+                              (reverse res)
+                              (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr d) (cdr rs) (cdr is)
+                                    ;; complex division, imag part, then real part (reverse)
+                                    (list* #`(#,(car is)
+                                              (unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1))
+                                                                      (unsafe-fl* #,o1 #,(car e2)))
+                                                          #,(car d)))
+                                           #`(#,(car rs)
+                                              (unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1))
+                                                                      (unsafe-fl* #,o2 #,(car e2)))
+                                                          #,(car d)))
+                                           res)))))))
+  (pattern e:expr
+           ;; can't work on inexact reals, which are a subtype of inexact
+           ;; complexes, so this has to be equality
+           #:when (isoftype? #'e -InexactComplex)
+           #:with e* (unboxed-gensym)
+           #:with real-part (unboxed-gensym)
+           #:with imag-part (unboxed-gensym)
+           #:with (bindings ...)
+           #`((e* #,((optimize) #'e))
+              (real-part (unsafe-flreal-part e*))
+              (imag-part (unsafe-flimag-part e*)))))
+
+(define-syntax-class inexact-complex-unary-op
+  (pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part)
+  (pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part))
+(define binary-inexact-complex-ops
+  (mk-float-tbl (list #'+ #'- #'* #'/)))
+
+(define-syntax-class inexact-complex-expr
+  (pattern e:expr
+           #:when (isoftype? #'e -InexactComplex)
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class inexact-complex-opt-expr
+  (pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-expr)
+           #:with opt
+           (begin (log-optimization "unary inexact complex" #'op)
+                  #'(op.unsafe n.opt)))
+  (pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops))
+                                  e:inexact-complex-expr ...))
+           #:with exp*:unboxed-inexact-complex-opt-expr #'exp
+           #:with opt
+           (begin (log-optimization "unboxed inexact complex" #'exp)
+                  (begin (reset-unboxed-gensym)
+                         #'(let* (exp*.bindings ...)
+                             (unsafe-make-flrectangular exp*.real-part exp*.imag-part))))))
diff --git a/collects/typed-scheme/optimizer/list.rkt b/collects/typed-scheme/optimizer/list.rkt
new file mode 100644
index 00000000..272a21ed
--- /dev/null
+++ b/collects/typed-scheme/optimizer/list.rkt
@@ -0,0 +1,35 @@
+#lang scheme/base
+
+(require syntax/parse
+         syntax/id-table racket/dict
+         unstable/match scheme/match
+         (for-template scheme/base scheme/unsafe/ops)
+         "../utils/utils.rkt" "../utils/tc-utils.rkt"
+         (rep type-rep)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide list-opt-expr)
+
+
+(define-syntax-class list-expr
+  (pattern e:expr
+           #:when (match (type-of #'e)
+                    [(tc-result1: (Listof: _)) #t]
+                    [(tc-result1: (List: _)) #t]
+                    [_ #f])
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class list-opt-expr
+  ;; if we're iterating (with the for macros) over something we know is a list,
+  ;; we can generate code that would be similar to if in-list had been used
+  (pattern (#%plain-app op:id _ l)
+           #:when (id-from? #'op 'make-sequence 'racket/private/for)
+           #:with l*:list-expr #'l
+           #:with opt
+           (begin (log-optimization "in-list" #'op)
+                  #'(let ((i l*.opt))
+                      (values unsafe-car unsafe-cdr i
+                              (lambda (x) (not (null? x)))
+                              (lambda (x) #t)
+                              (lambda (x y) #t))))))
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
new file mode 100644
index 00000000..7e799542
--- /dev/null
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -0,0 +1,68 @@
+#lang scheme/base
+
+(require syntax/parse 
+         syntax/id-table racket/dict
+         (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
+         "../utils/utils.rkt"
+         (types abbrev type-table utils subtype)
+         (optimizer utils fixnum float inexact-complex vector pair list struct))
+
+(provide optimize-top)
+
+
+(define-syntax-class opt-expr
+  (pattern e:opt-expr*
+           #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
+
+(define-syntax-class opt-expr*
+  #:literal-sets (kernel-literals)
+
+  ;; interesting cases, where something is optimized
+  (pattern e:fixnum-opt-expr          #:with opt #'e.opt)
+  (pattern e:float-opt-expr           #:with opt #'e.opt)
+  (pattern e:inexact-complex-opt-expr #:with opt #'e.opt)
+  (pattern e:vector-opt-expr          #:with opt #'e.opt)
+  (pattern e:pair-opt-expr            #:with opt #'e.opt)
+  (pattern e:list-opt-expr            #:with opt #'e.opt)
+  (pattern e:struct-opt-expr          #:with opt #'e.opt)
+  
+  ;; boring cases, just recur down
+  (pattern (#%plain-lambda formals e:opt-expr ...)
+           #:with opt #'(#%plain-lambda formals e.opt ...))
+  (pattern (define-values formals e:opt-expr ...)
+           #:with opt #'(define-values formals e.opt ...))
+  (pattern (case-lambda [formals e:opt-expr ...] ...)
+           #:with opt #'(case-lambda [formals e.opt ...] ...))
+  (pattern (let-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
+           #:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
+  (pattern (letrec-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
+           #:with opt #'(letrec-values ([ids e-rhs.opt] ...) e-body.opt ...))
+  (pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...)
+           #:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
+  (pattern (kw:identifier expr ...)
+           #:when (ormap (lambda (k) (free-identifier=? k #'kw))
+                         (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
+                               #'#%variable-reference #'with-continuation-mark))
+           ;; we don't want to optimize in the cases that don't match the #:when clause
+           #:with (expr*:opt-expr ...) #'(expr ...)
+           #:with opt #'(kw expr*.opt ...))
+  (pattern other:expr
+           #:with opt #'other))
+
+(define (optimize-top stx)
+  (let ((port (if (and *log-optimizations?*
+                       *log-optimizatons-to-log-file?*)
+                  (open-output-file *optimization-log-file*
+                                    #:exists 'append)
+                  (current-output-port))))
+    (begin0
+      (parameterize ([current-output-port port]
+                     [optimize (lambda (stx)
+                                 (syntax-parse stx #:literal-sets (kernel-literals)
+                                               [e:opt-expr
+                                                (syntax/loc stx e.opt)]))])
+        ((optimize) stx))
+      (if (and *log-optimizations?*
+               *log-optimizatons-to-log-file?*)
+          (close-output-port port)
+          #t))))
diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt
new file mode 100644
index 00000000..0ac9a77a
--- /dev/null
+++ b/collects/typed-scheme/optimizer/pair.rkt
@@ -0,0 +1,30 @@
+#lang scheme/base
+
+(require syntax/parse
+         syntax/id-table racket/dict
+         unstable/match scheme/match
+         (for-template scheme/base scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (rep type-rep)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide pair-opt-expr)
+
+
+(define-syntax-class pair-unary-op
+  (pattern (~literal car) #:with unsafe #'unsafe-car)
+  (pattern (~literal cdr) #:with unsafe #'unsafe-cdr))
+
+(define-syntax-class pair-expr
+  (pattern e:expr
+           #:when (match (type-of #'e) ; type of the operand
+                    [(tc-result1: (Pair: _ _)) #t]
+                    [_ #f])
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class pair-opt-expr
+  (pattern (#%plain-app op:pair-unary-op p:pair-expr)
+           #:with opt
+           (begin (log-optimization "unary pair" #'op)
+                  #'(op.unsafe p.opt))))
diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt
new file mode 100644
index 00000000..575b985e
--- /dev/null
+++ b/collects/typed-scheme/optimizer/struct.rkt
@@ -0,0 +1,26 @@
+#lang scheme/base
+
+(require syntax/parse
+         syntax/id-table racket/dict
+         unstable/match scheme/match
+         (for-template scheme/base scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (rep type-rep)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide struct-opt-expr)
+
+(define-syntax-class struct-opt-expr
+  ;; we can always optimize struct accessors and mutators
+  ;; if they typecheck, they're safe
+  (pattern (#%plain-app op:id s:expr v:expr ...)
+           #:when (or (struct-accessor? #'op) (struct-mutator? #'op))
+           #:with opt
+           (let ([idx (struct-fn-idx #'op)])
+             (if (struct-accessor? #'op)
+                 (begin (log-optimization "struct ref" #'op)
+                        #`(unsafe-struct-ref  #,((optimize) #'s) #,idx))
+                 (begin (log-optimization "struct set" #'op)
+                        #`(unsafe-struct-set! #,((optimize) #'s) #,idx
+                                              #,@(map (optimize) (syntax->list #'(v ...)))))))))
diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt
new file mode 100644
index 00000000..912b0184
--- /dev/null
+++ b/collects/typed-scheme/optimizer/utils.rkt
@@ -0,0 +1,64 @@
+#lang scheme/base
+
+(require unstable/match scheme/match
+         racket/dict syntax/id-table unstable/syntax
+         (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (types abbrev type-table utils subtype)
+         (rep type-rep))
+
+(provide log-optimization *log-optimizations?* *log-optimizatons-to-log-file?* *optimization-log-file*
+         subtypeof? isoftype?
+         mk-unsafe-tbl
+         n-ary->binary
+         unboxed-gensym reset-unboxed-gensym
+         optimize)
+
+
+(define *log-optimizations?* #f)
+(define *log-optimizatons-to-log-file?* #f)
+(define *optimization-log-file* "opt-log")
+(define (log-optimization kind stx)
+  (if *log-optimizations?*
+      (printf "~a line ~a col ~a - ~a - ~a\n"
+              (syntax-source stx) (syntax-line stx) (syntax-column stx)
+              (syntax->datum stx)
+              kind)
+      #t))
+
+;; is the syntax object s's type a subtype of t?
+(define (subtypeof? s t)
+  (match (type-of s)
+    [(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f]))
+;; similar, but with type equality
+(define (isoftype? s t)
+  (match (type-of s)
+         [(tc-result1: (== t type-equal?)) #t] [_ #f]))
+
+;; generates a table matching safe to unsafe promitives
+(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern)
+  (for/fold ([h (make-immutable-free-id-table)]) ([g generic])
+    (let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)])
+      (dict-set (dict-set h g u) f u))))
+
+;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
+(define (n-ary->binary op arg1 arg2 rest)
+  (for/fold ([o arg1])
+      ([e (syntax->list #`(#,arg2 #,@rest))])
+    #`(#,op #,o #,e)))
+
+;; to generate temporary symbols in a predictable manner
+;; these identifiers are unique within a sequence of unboxed operations
+;; necessary to have predictable symbols to add in the hand-optimized versions
+;; of the optimizer tests (which check for equality of expanded code)
+(define *unboxed-gensym-counter* 0)
+(define (unboxed-gensym)
+  (set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*))
+  (format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*))
+(define (reset-unboxed-gensym)
+  (set! *unboxed-gensym-counter* 0))
+
+;; to avoid mutually recursive syntax classes
+;; will be set to the actual optimization function at the entry point
+;; of the optimizer
+(define optimize (make-parameter #f))
diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt
new file mode 100644
index 00000000..10144147
--- /dev/null
+++ b/collects/typed-scheme/optimizer/vector.rkt
@@ -0,0 +1,63 @@
+#lang scheme/base
+
+(require syntax/parse
+         unstable/match scheme/match
+         (for-template scheme/base scheme/flonum scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (rep type-rep)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide vector-opt-expr)
+
+
+(define-syntax-class vector-op
+  ;; we need the * versions of these unsafe operations to be chaperone-safe
+  (pattern (~literal vector-ref)  #:with unsafe #'unsafe-vector*-ref)
+  (pattern (~literal vector-set!) #:with unsafe #'unsafe-vector*-set!))
+
+(define-syntax-class vector-expr
+  (pattern e:expr
+           #:when (match (type-of #'e)
+                    [(tc-result1: (HeterogenousVector: _)) #t]
+                    [_ #f])
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class vector-opt-expr
+  ;; vector-length of a known-length vector
+  (pattern (#%plain-app (~and op (~or (~literal vector-length)
+                                      (~literal unsafe-vector-length)
+                                      (~literal unsafe-vector*-length)))
+                        v:vector-expr)
+           #:with opt
+           (begin (log-optimization "known-length vector" #'op)
+                  (match (type-of #'v)
+                    [(tc-result1: (HeterogenousVector: es))
+                     #`(begin v.opt #,(length es))]))) ; v may have side effects
+  ;; we can optimize vector-length on all vectors.
+  ;; since the program typechecked, we know the arg is a vector.
+  ;; we can optimize no matter what.
+  (pattern (#%plain-app (~and op (~literal vector-length)) v:expr)
+           #:with opt
+           (begin (log-optimization "vector" #'op)
+                  #`(unsafe-vector*-length #,((optimize) #'v))))
+  ;; same for flvector-length
+  (pattern (#%plain-app (~and op (~literal flvector-length)) v:expr)
+           #:with opt
+           (begin (log-optimization "flvector" #'op)
+                  #`(unsafe-flvector-length #,((optimize) #'v))))
+  ;; we can optimize vector ref and set! on vectors of known length if we know
+  ;; the index is within bounds (for now, literal or singleton type)
+  (pattern (#%plain-app op:vector-op v:vector-expr i:expr new:expr ...)
+           #:when (let ((len (match (type-of #'v)
+                               [(tc-result1: (HeterogenousVector: es)) (length es)]
+                               [_ 0]))
+                        (ival (or (syntax-parse #'i [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
+                                  (match (type-of #'i)
+                                    [(tc-result1: (Value: (? number? i))) i]
+                                    [_ #f]))))
+                    (and (integer? ival) (exact? ival) (<= 0 ival (sub1 len))))
+           #:with opt
+           (begin (log-optimization "vector" #'op)
+                  #`(op.unsafe v.opt #,((optimize) #'i)
+                               #,@(map (optimize) (syntax->list #'(new ...)))))))
diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt
index c27598b6..20945835 100644
--- a/collects/typed-scheme/private/base-env-indexing-abs.rkt
+++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt
@@ -1,41 +1,70 @@
-#lang scheme
+#lang racket
 
 (require
  "../utils/utils.rkt"
- scheme/tcp 
- scheme/unsafe/ops
+ racket/tcp 
  (only-in rnrs/lists-6 fold-left)
  '#%paramz
  "extra-procs.rkt"
  (utils tc-utils )
  (types  union convenience)
  (only-in '#%kernel [apply kernel:apply])
- scheme/promise scheme/system
+ racket/promise racket/system
  (only-in string-constants/private/only-once maybe-print-message)
  (only-in racket/match/runtime match:error matchable? match-equality-test)
- (for-template scheme) 
- (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Nat -Nat*]))
+ (for-template racket racket/unsafe/ops)
+ (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]))
 
 (provide indexing)
 
-(define-syntax-rule (indexing -Nat)
+(define-syntax-rule (indexing index-type)
   (make-env
    
-   [build-list (-poly (a) (-Nat (-Nat* . -> . a) . -> . (-lst a)))]
-   [make-list (-poly (a) (-Nat a . -> . (-lst a)))]
+   [build-list (-poly (a) (index-type (-NonnegativeFixnum . -> . a) . -> . (-lst a)))]
+   [make-list (-poly (a) (index-type a . -> . (-lst a)))]
    
-   [string-ref (-> -String -Nat -Char)]
-   [substring (->opt -String -Nat [-Nat] -String)]
-   [make-string (cl-> [(-Nat) -String] [(-Nat -Char) -String])]
-   [string-set! (-String -Nat -Char . -> . -Void)]
+   [string-ref (-> -String index-type -Char)]
+   [substring (->opt -String index-type [index-type] -String)]
+   [make-string (cl-> [(index-type) -String] [(index-type -Char) -String])]
+   [string-set! (-String index-type -Char . -> . -Void)]
+   [string-copy! (-String index-type -String [index-type index-type] . ->opt . -Void)]
+
+   [read-string (index-type [-Input-Port] . ->opt . (Un -String (-val eof)))]
+   [read-string! (-String [-Input-Port index-type index-type] . ->opt . (Un -NonnegativeFixnum (-val eof)))]
+   [read-bytes (index-type [-Input-Port] . ->opt . (Un -Bytes (-val eof)))]
+
+   [write-byte (cl-> [(index-type) -Void]
+                     [(index-type -Output-Port) -Void])]
+   [write-string (cl-> [(-String) -NonnegativeFixnum]
+                       [(-String -Output-Port) -NonnegativeFixnum]
+                       [(-String -Output-Port index-type) -NonnegativeFixnum]
+                       [(-String -Output-Port index-type index-type) -NonnegativeFixnum])]
+   [write-bytes  (cl-> [(-Bytes) -NonnegativeFixnum]
+                       [(-Bytes -Output-Port) -NonnegativeFixnum]
+                       [(-Bytes -Output-Port index-type) -NonnegativeFixnum]
+                       [(-Bytes -Output-Port index-type index-type) -NonnegativeFixnum])]
+   [write-bytes-avail  (cl-> [(-Bytes) -NonnegativeFixnum]
+                             [(-Bytes -Output-Port) -NonnegativeFixnum]
+                             [(-Bytes -Output-Port index-type) -NonnegativeFixnum]
+                             [(-Bytes -Output-Port index-type index-type) -NonnegativeFixnum])]
+   [write-bytes-avail*  (cl-> [(-Bytes) (-opt -NonnegativeFixnum)]
+                              [(-Bytes -Output-Port) (-opt -NonnegativeFixnum)]
+                              [(-Bytes -Output-Port index-type) (-opt -NonnegativeFixnum)]
+                              [(-Bytes -Output-Port index-type index-type) (-opt -NonnegativeFixnum)])]
+   [write-bytes-avail/enable-break (cl-> [(-Bytes) -NonnegativeFixnum]
+                                         [(-Bytes -Output-Port) -NonnegativeFixnum]
+                                         [(-Bytes -Output-Port index-type) -NonnegativeFixnum]
+                                         [(-Bytes -Output-Port index-type index-type) -NonnegativeFixnum])]
+
+
    
-   [list-ref  (-poly (a) ((-lst a) -Nat . -> . a))]
-   [list-tail (-poly (a) ((-lst a) -Nat . -> . (-lst a)))]
+   [list-ref  (-poly (a) ((-lst a) index-type . -> . a))]
+   [list-tail (-poly (a) ((-lst a) index-type . -> . (-lst a)))]
    
    [regexp-match
     (let ([?outp   (-opt -Output-Port)]
-          [N       -Nat]
-          [?N      (-opt -Nat)]
+          [N       index-type]
+          [?N      (-opt index-type)]
           [optlist (lambda (t) (-opt (-lst (-opt t))))]
           [-StrRx  (Un -String -Regexp -PRegexp)]
           [-BtsRx  (Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
@@ -46,8 +75,8 @@
        (-Pattern -InpBts [N ?N ?outp] . ->opt . (optlist -Bytes))))]
    [regexp-match?
     (let ([?outp   (-opt -Output-Port)]
-          [N       -Nat]
-          [?N      (-opt -Nat)]
+          [N       index-type]
+          [?N      (-opt index-type)]
           [optlist (lambda (t) (-opt (-lst (-opt t))))]
           [-StrRx  (Un -String -Regexp -PRegexp)]
           [-BtsRx  (Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
@@ -57,8 +86,8 @@
        (-BtsRx   -String [N ?N ?outp] . ->opt . -Boolean)
        (-Pattern -InpBts [N ?N ?outp] . ->opt . -Boolean)))]
    [regexp-match*
-    (let ([N       -Nat]
-          [?N      (-opt -Nat)]
+    (let ([N       index-type]
+          [?N      (-opt index-type)]
           [-StrRx  (Un -String -Regexp -PRegexp)]
           [-BtsRx  (Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
           [-InpBts (Un -Input-Port -Bytes)])
@@ -68,59 +97,82 @@
        (-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))]
    [regexp-try-match
     (let ([?outp   (-opt -Output-Port)]
-          [?N      (-opt -Nat)]
+          [?N      (-opt index-type)]
           [optlist (lambda (t) (-opt (-lst (-opt t))))])
-      (->opt -Pattern -Input-Port [-Nat ?N ?outp] (optlist -Bytes)))]
+      (->opt -Pattern -Input-Port [index-type ?N ?outp] (optlist -Bytes)))]
    
    [regexp-match-positions
     (let ([?outp   (-opt -Output-Port)]
-          [N       -Nat]
-          [?N      (-opt -Nat)]
+          [N       index-type]
+          [?N      (-opt index-type)]
           [optlist (lambda (t) (-opt (-lst (-opt t))))]
           [-StrRx  (Un -String -Regexp -PRegexp)]
           [-BtsRx  (Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
           [-InpBts (Un -Input-Port -Bytes)])
-      (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))]
+      (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -NonnegativeFixnum -NonnegativeFixnum))))]
    [regexp-match-positions*
     (let ([?outp   (-opt -Output-Port)]
-          [?N      (-opt -Nat)]
+          [?N      (-opt index-type)]
           [optlist (lambda (t) (-opt (-lst (-opt t))))]
           [-StrRx  (Un -String -Regexp -PRegexp)]
           [-BtsRx  (Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
           [-InpBts (Un -Input-Port -Bytes)])
-      (->opt -Pattern (Un -String -InpBts) [-Nat ?N ?outp] (-lst (-pair -Nat -Nat))))]
+      (->opt -Pattern (Un -String -InpBts) [index-type ?N ?outp] (-lst (-pair -NonnegativeFixnum -NonnegativeFixnum))))]
    
    
-   [take   (-poly (a) ((-lst a) -Nat . -> . (-lst a)))]
-   [drop   (-poly (a) ((-lst a) -Nat . -> . (-lst a)))]
-   [take-right   (-poly (a) ((-lst a) -Nat . -> . (-lst a)))]
-   [drop-right   (-poly (a) ((-lst a) -Nat . -> . (-lst a)))]
+   [take   (-poly (a) ((-lst a) index-type . -> . (-lst a)))]
+   [drop   (-poly (a) ((-lst a) index-type . -> . (-lst a)))]
+   [take-right   (-poly (a) ((-lst a) index-type . -> . (-lst a)))]
+   [drop-right   (-poly (a) ((-lst a) index-type . -> . (-lst a)))]
    [split-at
-    (-poly (a) ((list (-lst a)) -Nat . ->* . (-values (list (-lst a) (-lst a)))))]
+    (-poly (a) ((list (-lst a)) index-type . ->* . (-values (list (-lst a) (-lst a)))))]
    [split-at-right
-    (-poly (a) ((list (-lst a)) -Nat . ->* . (-values (list (-lst a) (-lst a)))))]
+    (-poly (a) ((list (-lst a)) index-type . ->* . (-values (list (-lst a) (-lst a)))))]
    
-   [vector-ref (-poly (a) ((-vec a) -Nat . -> . a))]
-   [build-vector (-poly (a) (-Nat (-Nat . -> . a) . -> . (-vec a)))]
-   [vector-set! (-poly (a) (-> (-vec a) -Nat a -Void))]
-   [vector-copy! (-poly (a) ((-vec a) -Nat (-vec a) [-Nat -Nat] . ->opt . -Void))]
-   [make-vector (-poly (a) (cl-> [(-Nat) (-vec -Nat)]
-                                 [(-Nat a) (-vec a)]))]
+   [vector-ref (-poly (a) ((-vec a) index-type . -> . a))]
+   [unsafe-vector-ref (-poly (a) ((-vec a) index-type . -> . a))]
+   [unsafe-vector*-ref (-poly (a) ((-vec a) index-type . -> . a))]
+   [build-vector (-poly (a) (index-type (-NonnegativeFixnum . -> . a) . -> . (-vec a)))]
+   [vector-set! (-poly (a) (-> (-vec a) index-type a -Void))]
+   [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))]
+   [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))]
+   [vector-copy! (-poly (a) ((-vec a) index-type (-vec a) [index-type index-type] . ->opt . -Void))]
+   [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))]
+                                 [(index-type a) (-vec a)]))]
+
+   [bytes-ref (-> -Bytes index-type -NonnegativeFixnum)]
+   [unsafe-bytes-ref (-> -Bytes index-type -NonnegativeFixnum)]
+   [bytes-set! (-> -Bytes index-type index-type -Void)]
+   [unsafe-bytes-set! (-> -Bytes index-type index-type -Void)]
+   [subbytes (cl-> [(-Bytes index-type) -Bytes] [(-Bytes index-type index-type) -Bytes])]
+   [bytes-copy! (-Bytes index-type -Bytes [index-type index-type] . ->opt . -Void)]
+   [bytes-fill! (-> -Bytes index-type -Void)]
+   [bytes->string/utf-8 (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -String)]
+   [bytes->string/locale (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -String)]
+   [bytes->string/latin-1 (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -String)]
+   [string->bytes/utf-8 (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)]
+   [string->bytes/locale (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)]
+   [string->bytes/latin-1 (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)]
+   [string-utf-8-length (-String [index-type index-type] . ->opt . -NonnegativeFixnum)]
+   [bytes-utf-8-length (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -NonnegativeFixnum)]
+   [bytes-utf-8-ref (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -Char)]
+   [bytes-utf-8-index (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -NonnegativeFixnum)]
+
    
    [peek-char
-    (cl->* [->opt [-Input-Port -Nat] (Un -Char (-val eof))])]
+    (cl->* [->opt [-Input-Port index-type] (Un -Char (-val eof))])]
    [peek-byte
-    (cl->* [->opt [-Input-Port -Nat] (Un -Byte (-val eof))])]
+    (cl->* [->opt [-Input-Port index-type] (Un -Byte (-val eof))])]
    
    ;; string.rkt
-   [real->decimal-string (N [-Nat] . ->opt .  -String)]
+   [real->decimal-string (-Real [index-type] . ->opt .  -String)]
    
-   [random (cl-> [(-Nat) -Nat*] [() -Real])]
+   [random (cl-> [(index-type) -Nat] [() -Real])]
    
    [raise-type-error
     (cl->
      [(Sym -String Univ) (Un)]
-     [(Sym -String -Nat (-lst Univ)) (Un)])]
+     [(Sym -String index-type (-lst Univ)) (Un)])]
    
    ))
-   
\ No newline at end of file
+ 
diff --git a/collects/typed-scheme/private/base-env-indexing.rkt b/collects/typed-scheme/private/base-env-indexing.rkt
index e345ab7e..23b72c05 100644
--- a/collects/typed-scheme/private/base-env-indexing.rkt
+++ b/collects/typed-scheme/private/base-env-indexing.rkt
@@ -5,7 +5,7 @@
  (for-syntax (types abbrev) (env init-envs) (r:infer infer-dummy infer)
              "base-env-indexing-abs.rkt"))
 
-(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Nat)))
+(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Integer)))
 (begin-for-syntax (initialize-type-env e))
 
 
diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt
index 479e21bc..fe546c38 100644
--- a/collects/typed-scheme/private/base-env-numeric.rkt
+++ b/collects/typed-scheme/private/base-env-numeric.rkt
@@ -20,78 +20,294 @@
     (lambda (t [r t])
       (t t . -> . r)))
   (define-for-syntax rounder 
-    (cl->* (-> -ExactRational -Integer) (-> -Flonum -Flonum) (-> -Real -Real)))
+    (cl->* (-> -PositiveFixnum -PositiveFixnum)
+           (-> -NonnegativeFixnum -NonnegativeFixnum)
+           (-> -Fixnum -Fixnum)
+           (-> -Pos -Pos)
+           (-> -Nat -Nat)
+           (-> -ExactRational -Integer)
+           (-> -NonnegativeFlonum -NonnegativeFlonum)
+           (-> -Flonum -Flonum)
+           (-> -Real -Real)))
   
   (define-for-syntax (unop t) (-> t t))
   
   (define-for-syntax fl-comp (binop -Flonum B))
   (define-for-syntax fl-op (binop -Flonum))
   (define-for-syntax fl-unop (unop -Flonum))
-  
+  (define-for-syntax fl-rounder
+    (cl->* (-> -NonnegativeFlonum -NonnegativeFlonum)
+           (-> -Flonum -Flonum)))
   
   (define-for-syntax int-op (binop -Integer))
   (define-for-syntax nat-op (binop -Nat))
   
   (define-for-syntax fx-comp (binop -Integer B))
-  (define-for-syntax fx-op (cl->* nat-op int-op))
-  (define-for-syntax fx-intop int-op)
-  (define-for-syntax fx-unop (unop -Integer))
+  (define-for-syntax fx-op (cl->* (-Pos -Pos . -> . -PositiveFixnum)
+                                  (-Nat -Nat . -> . -NonnegativeFixnum)
+                                  (-Integer -Integer . -> . -Fixnum)))
+  (define-for-syntax fx-intop (-Integer -Integer . -> . -Fixnum))
+  (define-for-syntax fx-unop (-Integer . -> . -Fixnum))
 
   (define-for-syntax real-comp (->* (list R R) R B))
+
+  ;; types for specific operations, to avoid repetition between safe and unsafe versions
+  (define-for-syntax fx+-type
+    (cl->* (-Pos -Nat . -> . -PositiveFixnum)
+           (-Nat -Pos . -> . -PositiveFixnum)
+           (-Nat -Nat . -> . -NonnegativeFixnum)
+           (-Integer -Integer . -> . -Fixnum)))
+  (define-for-syntax fx=-type
+    (cl->*
+     (-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top))
+     (-> (-val 0) -Integer B : (-FS (-filter (-val 0) 1) -top))
+     (-> -Integer -Pos B : (-FS (-filter -PositiveFixnum 0) -top))
+     (-> -Pos -Integer B : (-FS (-filter -PositiveFixnum 1) -top))
+     (-> -Integer -Nat B : (-FS (-filter -NonnegativeFixnum 0) -top))
+     (-> -Nat -Integer B : (-FS (-filter -NonnegativeFixnum 1) -top))
+     (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top))
+     (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top))
+     fx-comp))
+  (define-for-syntax fx<-type
+    (cl->*
+     (-> -Integer (-val 0) B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0)))
+     (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top))
+     (-> -Nat -Integer B : (-FS (-filter -PositiveFixnum 1) -top))
+     fx-comp))
+  (define-for-syntax fx>-type
+    (cl->*
+     (-> -Integer (-val 0) B : (-FS (-filter -PositiveFixnum 0) -top))
+     (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top))
+     (-> -Integer -Nat B : (-FS (-filter -PositiveFixnum 0) -top))
+     fx-comp))
+  (define-for-syntax fx<=-type
+    (cl->*
+     (-> -Integer (-val 0) B : (-FS -top (-filter -PositiveFixnum 0)))
+     (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top))
+     (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top))
+     (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top))
+     fx-comp))
+  (define-for-syntax fx>=-type
+    (cl->*
+     (-> -Integer (-val 0) B : (-FS (-filter -NonnegativeFixnum 0) -top))
+     (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top))
+     (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top))
+     (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top))
+     fx-comp))
+  (define-for-syntax fxmin-type
+    (cl->*
+     (-> -NegativeFixnum -Integer -NegativeFixnum)
+     (-> -Integer -NegativeFixnum -NegativeFixnum)
+     (-> -Pos -Pos -PositiveFixnum)
+     (-> -Nat -Nat -NonnegativeFixnum)
+     (-> -Integer -Integer -Fixnum)))
+  (define-for-syntax fxmax-type
+    (cl->*
+     (-> -NegativeFixnum -NegativeFixnum -NegativeFixnum)
+     (-> -Pos -Integer -PositiveFixnum)
+     (-> -Integer -Pos -PositiveFixnum)
+     (-> -Nat -Integer -NonnegativeFixnum)
+     (-> -Integer -Nat -NonnegativeFixnum)
+     (-> -Integer -Integer -Fixnum)))
+
+  (define-for-syntax fl+*-type
+    (cl->* (-NonnegativeFlonum -NonnegativeFlonum . -> . -NonnegativeFlonum)
+           (-Flonum -Flonum . -> . -Flonum)))
+  (define-for-syntax fl=-type
+    (cl->*
+     (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top))
+     (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top))
+     fl-comp))
+  (define-for-syntax fl<-type
+    (cl->*
+     (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top))
+     fl-comp))
+  (define-for-syntax fl>-type
+    (cl->*
+     (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top))
+     fl-comp))
+  (define-for-syntax flmin-type
+    (cl->* (-> -NonnegativeFlonum -NonnegativeFlonum -NonnegativeFlonum)
+           (-> -Flonum -Flonum -Flonum)))
+  (define-for-syntax flmax-type
+    (cl->* (-> -NonnegativeFlonum -Flonum -NonnegativeFlonum)
+           (-> -Flonum -NonnegativeFlonum -NonnegativeFlonum)
+           (-> -Flonum -Flonum -Flonum)))
   )
 
 ;; numeric predicates
-[zero? (make-pred-ty (list N) B -Zero)]
+[zero? (asym-pred N B (-FS (-filter (Un -NonnegativeFlonum -Zero) 0)
+                           (-not-filter -Zero 0)))]
 [number? (make-pred-ty N)]
 [integer? (asym-pred Univ B (-FS (-filter (Un -Integer -Flonum) 0)
-				     (-not-filter -Integer 0)))]
+                                 (-not-filter -Integer 0)))]
 [exact-integer? (make-pred-ty -Integer)]
 [real? (make-pred-ty -Real)]
 [inexact-real? (make-pred-ty -Flonum)]
 [complex? (make-pred-ty N)]
 [rational? (make-pred-ty -Real)]
 [exact? (asym-pred N B (-FS -top (-not-filter -ExactRational 0)))]
-[inexact? (asym-pred N B  (-FS -top (-not-filter -Flonum 0)))]
-[fixnum? (asym-pred Univ B (-FS (-filter -Integer 0) -top))]
-[positive? (-> -Real B)]
-[negative? (-> -Real B)]
+[inexact? (asym-pred N B  (-FS -top (-not-filter (Un -Flonum -InexactComplex) 0)))]
+[fixnum? (make-pred-ty -Fixnum)]
+[positive? (cl->* (-> -Fixnum B : (-FS (-filter -PositiveFixnum 0) -top))
+                  (-> -Integer B : (-FS (-filter -ExactPositiveInteger 0) -top))
+                  (-> -Flonum B : (-FS (-filter -NonnegativeFlonum 0) -top))
+                  (-> -Real B))]
+[negative? (cl->* (-> -Fixnum B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0)))
+                  (-> -Integer B : (-FS -top (-filter -Nat 0)))
+                  (-> -Flonum B : (-FS -top (-filter -NonnegativeFlonum 0)))
+                  (-> -Real B))]
 [exact-positive-integer? (make-pred-ty -Pos)]
 [exact-nonnegative-integer? (make-pred-ty -Nat)]
 
-[odd? (-> -Integer B)]
+[odd? (-> -Integer B : (-FS -top (-filter (-val 0) 0)))]
 [even? (-> -Integer B)]
 
-[modulo (cl->* (-Integer -Integer . -> . -Integer))]
+[modulo (cl->* (-Nat -NonnegativeFixnum . -> . -NonnegativeFixnum)
+               (-Integer -Fixnum . -> . -Fixnum)
+               (-Nat -Nat . -> . -Nat)
+               (-Integer -Integer . -> . -Integer))]
 
-[=  (->* (list N N) N B)]
+[=  (cl->*
+     (-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top))
+     (-> (-val 0) -Integer B : (-FS (-filter (-val 0) 1) -top))
+     (-> -Integer -PositiveFixnum B : (-FS (-filter -PositiveFixnum 0) -top))
+     (-> -PositiveFixnum -Integer B : (-FS (-filter -PositiveFixnum 1) -top))
+     (-> -Integer -NonnegativeFixnum B : (-FS (-filter -NonnegativeFixnum 0) -top))
+     (-> -NonnegativeFixnum -Integer B : (-FS (-filter -NonnegativeFixnum 1) -top))
+     (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top))
+     (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top))
+     (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top))
+     (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top))
+     (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top))
+     (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top))
+     (->* (list N N) N B))]
 
-[>= real-comp]
-[<  real-comp]
-[<= real-comp]
-[>  real-comp]
+[>  (cl->*
+     (-> -Fixnum (-val 0) B : (-FS (-filter -PositiveFixnum 0) -top))
+     (-> -Integer (-val 0) B : (-FS (-filter -Pos 0) -top))
+     (-> -NegativeFixnum -Fixnum B : (-FS (-filter -NegativeFixnum 1) -top))
+     (-> -Fixnum -NonnegativeFixnum B : (-FS (-filter -PositiveFixnum 1) -top))
+     (-> -Fixnum -Nat B : (-FS (-filter -Fixnum 1) -top))
+     (-> -Integer -Nat B : (-FS (-filter -ExactPositiveInteger 0) -top))
+     (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top))
+     (-> -NonnegativeFlonum -Flonum B : (-FS -top (-filter -NonnegativeFlonum 1)))
+     real-comp)]
+[>= (cl->*
+     (-> -Fixnum (-val 0) B : (-FS (-filter -NonnegativeFixnum 0) (-filter -NegativeFixnum 0)))
+     (-> -Integer (-val 0) B : (-FS (-filter -ExactNonnegativeInteger 0) -top))
+     (-> -Fixnum -PositiveFixnum B : (-FS (-filter -PositiveFixnum 0) -top))
+     (-> -Fixnum -NonnegativeFixnum B : (-FS (-filter -NonnegativeFixnum 0) -top))
+     (-> -Fixnum -Pos B : (-FS (-filter -PositiveFixnum 1) -top))
+     (-> -Fixnum -Nat B : (-FS (-filter -NonnegativeFixnum 1) -top))
+     (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top))
+     (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top))
+     (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top))
+     (-> -NonnegativeFlonum -Flonum B : (-FS -top (-filter -NonnegativeFlonum 1)))
+     real-comp)]
+[<  (cl->*
+     (-> -Fixnum (-val 0) B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0)))
+     (-> -Integer (-val 0) B : (-FS -top (-filter -ExactNonnegativeInteger 0)))
+     (-> -NonnegativeFixnum -Fixnum B : (-FS (-filter -PositiveFixnum 1) -top))
+     (-> -Fixnum -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top))
+     (-> -Nat -Fixnum B : (-FS (-filter -NonnegativeFixnum 0) -top))
+     (-> -Nat -Integer B : (-FS (-filter -Pos 1) -top))
+     (-> -Integer -Nat B : (-FS -top (-filter -Nat 0)))
+     (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top))
+     (-> -Flonum -NonnegativeFlonum B : (-FS -top (-filter -NonnegativeFlonum 0)))
+     real-comp)]
+[<= (cl->*
+     (-> -Fixnum (-val 0) B : (-FS -top (-filter -PositiveFixnum 0)))
+     (-> -Integer (-val 0) B : (-FS -top (-filter -ExactPositiveInteger 0)))
+     (-> -PositiveFixnum -Fixnum B : (-FS (-filter -PositiveFixnum 1) -top))
+     (-> -NonnegativeFixnum -Fixnum B : (-FS (-filter -NonnegativeFixnum 1) -top))
+     (-> -Pos -Fixnum B : (-FS (-filter -PositiveFixnum 0) -top))
+     (-> -Nat -Fixnum B : (-FS (-filter -NonnegativeFixnum 0) -top))
+     (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top))
+     (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top))
+     (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top))
+     (-> -Flonum -NonnegativeFlonum B : (-FS -top (-filter -NonnegativeFlonum 0)))
+     real-comp)]
 
 
-[* (apply cl->* (for/list ([t all-num-types]) (->* (list) t t)))]
-[+ (apply cl->* (for/list ([t all-num-types]) (->* (list) t t)))]
+[* (apply cl->*
+          (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -NonnegativeFlonum -Flonum)]) (->* (list) t t))
+                  (list (->* (list -Pos) -NonnegativeFlonum -NonnegativeFlonum))
+                  (list (->* (list -NonnegativeFlonum) -Pos -NonnegativeFlonum))
+                  (list (->* (list -Pos) -Flonum -Flonum))
+                  (list (->* (list -Flonum) -Pos -Flonum))
+                  (list (->* (list) -Real -Real))
+                  (list (->* (list) -InexactComplex -InexactComplex))
+                  (list (->* (list) N N))))]
+[+ (apply cl->*
+          (append (list (->* (list -Pos) -Nat -Pos))
+                  (list (->* (list -Nat) -Pos -Pos))
+                  (for/list ([t (list -Nat -Integer -ExactRational -NonnegativeFlonum -Flonum)]) (->* (list) t t))
+                  (list (->* (list -Nat) -NonnegativeFlonum -NonnegativeFlonum))
+                  (list (->* (list -NonnegativeFlonum) -Nat -NonnegativeFlonum))
+                  ;; special cases for promotion to inexact, not exhaustive
+                  ;; valid for + and -, but not for * and /, since (* <float> 0) is exact 0 (i.e. not a float)
+                  (list (->* (list -Flonum) -Real -Flonum))
+                  (list (->* (list -Real -Flonum) -Real -Flonum))
+                  (list (->* (list) -Real -Real))
+                  (list (->* (list -Real) -InexactComplex -InexactComplex))
+                  (list (->* (list -InexactComplex) -Real -InexactComplex))
+                  (list (->* (list) -InexactComplex -InexactComplex))
+                  (list (->* (list) N N))))]
 
-[- (apply cl->* 
-            (for/list ([t (list -Integer -ExactRational -Flonum -Real N)])
-              (->* (list t) t t)))]
-[/ (apply cl->* 
-	  (->* (list -Integer) -Integer -ExactRational)
-	  (for/list ([t (list -ExactRational -Flonum -Real N)])
-	    (->* (list t) t t)))]
+[- (apply cl->*
+          (append (for/list ([t (list -Integer -ExactRational -Flonum)])
+                            (->* (list t) t t))
+                  (list (->* (list -Flonum) -Real -Flonum))
+                  (list (->* (list -Real -Flonum) -Real -Flonum))
+                  (list (->* (list -Real) -Real -Real))
+                  (list (->* (list -Real) -InexactComplex -InexactComplex))
+                  (list (->* (list -InexactComplex) -Real -InexactComplex))
+                  (list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
+                  (list (->* (list N) N N))))]
+[/ (apply cl->*
+          (append (list (->* (list -Integer) -Integer -ExactRational))
+                  (for/list ([t (list -ExactRational -Flonum)])
+                            (->* (list t) t t))
+                  ;; only exact 0 as first argument can cause the result of a division involving inexacts to be exact
+                  (list (->* (list -Flonum) -Real -Flonum))
+                  (list (->* (list -Real) -Real -Real))
+                  (list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
+                  (list (->* (list N) N N))))]
 
-[max (apply cl->* (for/list ([t all-num-types]) (->* (list t) t t)))]
-[min (apply cl->* (for/list ([t all-num-types]) (->* (list t) t t)))]
+[max (cl->* (->* (list -PositiveFixnum) -Fixnum -PositiveFixnum)
+            (->* (list -NonnegativeFixnum) -Fixnum -NonnegativeFixnum)
+            (->* (list -NegativeFixnum) -NegativeFixnum -NegativeFixnum)
+            (->* (list -Fixnum) -Fixnum -Fixnum)
+            (->* (list -Pos) -Integer -Pos)
+            (->* (list -Nat) -Integer -Nat)
+            (->* (list -Integer) -Integer -Integer)
+            (->* (list -ExactRational) -ExactRational -ExactRational)
+            (->* (list -NonnegativeFlonum) -Flonum -NonnegativeFlonum)
+            (->* (list -Flonum) -Flonum -Flonum)
+            (->* (list -Real) -Real -Real))]
+[min (cl->* (->* (list -PositiveFixnum) -PositiveFixnum -PositiveFixnum)
+            (->* (list -NonnegativeFixnum) -NonnegativeFixnum -NonnegativeFixnum)
+            (->* (list -NegativeFixnum) -Fixnum -NegativeFixnum)
+            (->* (list -Fixnum) -NegativeFixnum -NegativeFixnum)
+            (->* (list -Fixnum) -Fixnum -Fixnum)
+            (->* (list -Pos) -Pos -Pos)
+            (->* (list -Nat) -Nat -Nat)
+            (->* (list -Integer) -Integer -Integer)
+            (->* (list -ExactRational) -ExactRational -ExactRational)
+            (->* (list -NonnegativeFlonum) -NonnegativeFlonum -NonnegativeFlonum)
+            (->* (list -Flonum) -Flonum -Flonum)
+            (->* (list -Real) -Real -Real))]
 
 
 [add1 (cl->* (-> -Pos -Pos)
              (-> -Nat -Pos)
              (-> -Integer -Integer)
              (-> -ExactRational -ExactRational)
+             (-> -NonnegativeFlonum -NonnegativeFlonum)
              (-> -Flonum -Flonum)
              (-> -Real -Real)
+             (-> -InexactComplex -InexactComplex)
              (-> N N))]
 
 [sub1 (cl->* (-> -Pos -Nat)
@@ -99,19 +315,56 @@
              (-> -ExactRational -ExactRational)
              (-> -Flonum -Flonum)
              (-> -Real -Real)
+             (-> -InexactComplex -InexactComplex)
              (-> N N))]
 
-[quotient (cl->* (-Nat -Nat . -> . -Nat)
+[quotient (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum)
+                 (-Fixnum -Fixnum . -> . -Fixnum)
+                 (-Nat -Nat . -> . -Nat)
                  (-Integer -Integer . -> . -Integer))]
-[remainder (cl->* (-Nat -Nat . -> . -Nat)
+[remainder (cl->* (-Nat -NonnegativeFixnum . -> . -NonnegativeFixnum)
+                  (-Integer -Fixnum . -> . -Fixnum)
+                  (-Nat -Nat . -> . -Nat)
                   (-Integer -Integer . -> . -Integer))]
-[quotient/remainder (cl->* (-Nat -Nat . -> . (-values (list -Nat -Nat)))
+[quotient/remainder (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . (-values (list -NonnegativeFixnum -NonnegativeFixnum)))
+                           (-Nat -NonnegativeFixnum . -> . (-values (list -Nat -NonnegativeFixnum)))
+                           (-Fixnum -Fixnum . -> . (-values (list -Fixnum -Fixnum)))
+                           (-Integer -Fixnum . -> . (-values (list -Integer -Fixnum)))
+                           (-Nat -Nat . -> . (-values (list -Nat -Nat)))
                            (-Integer -Integer . -> . (-values (list -Integer -Integer))))]
 
+[arithmetic-shift (cl->* (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum)
+                         (-Nat -Nat . -> . -Nat)
+                         (-Integer -Integer . -> . -Integer))]
+[bitwise-and (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)
+                    (null -Fixnum . ->* . -Fixnum)
+                    (null -Nat . ->* . -Nat)
+                    (null -Integer . ->* . -Integer))]
+[bitwise-ior (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)
+                    (null -Fixnum . ->* . -Fixnum)
+                    (null -Nat . ->* . -Nat)
+                    (null -Integer . ->* . -Integer))]
+[bitwise-not (cl->* (null -Fixnum . ->* . -Fixnum)
+                    (null -Integer . ->* . -Integer))]
+[bitwise-xor (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)
+                    (null -Fixnum . ->* . -Fixnum)
+                    (null -Nat . ->* . -Nat)
+                    (null -Integer . ->* . -Integer))]
+[bitwise-bit-set? (-> -Integer -Integer B)]
+[bitwise-bit-field (-> -Integer -Integer -Integer -Integer)]
+[integer-length (-> -Integer -NonnegativeFixnum)]
+
+[abs (cl->* (-PositiveFixnum . -> . -PositiveFixnum)
+            (-Fixnum . -> . -NonnegativeFixnum)
+            (-Pos . -> . -Pos)
+            (-Integer . -> . -Nat)
+            (-Flonum . -> . -NonnegativeFlonum)
+            (-Real . -> . -Real))]
+
 ;; exactness
 [exact->inexact (cl->* 
                  (-Real . -> . -Flonum)
-                 (N . -> . N))]
+                 (N . -> . -InexactComplex))]
 [inexact->exact (cl->*
                  (-Real . -> . -ExactRational)
                  (N . -> . N))]
@@ -120,68 +373,91 @@
 [ceiling rounder]
 [truncate rounder]
 [round rounder]
-[make-rectangular (-Real -Real . -> . N)]
-[make-polar (-Real -Real . -> . N)]
-[real-part (N . -> . -Real)]
-[imag-part (N . -> . -Real)]
-[magnitude (N . -> . -Real)]
-[angle     (N . -> . -Real)]
-[numerator   (-Real . -> . -Real)]
-[denominator (-Real . -> . -Real)]
-[rationalize (-Real -Real . -> . N)]
+[make-rectangular (cl->* (-Flonum -Flonum . -> . -InexactComplex)
+                         (-Real -Real . -> . N))]
+[make-polar (cl->* (-Flonum -Flonum . -> . -InexactComplex)
+                   (-Real -Real . -> . N))]
+[real-part (cl->* (-InexactComplex . -> . -Flonum)
+                  (N . -> . -Real))]
+[imag-part (cl->* (-InexactComplex . -> . -Flonum)
+                  (N . -> . -Real))]
+[magnitude (cl->* (-InexactComplex . -> . -Flonum)
+                  (N . -> . -Real))]
+[angle     (cl->* (-InexactComplex . -> . -Flonum)
+                  (N . -> . -Real))]
+[numerator   (cl->* (-ExactRational . -> . -Integer)
+                    (-Real . -> . -Real))]
+[denominator (cl->* (-ExactRational . -> . -Integer)
+                    (-Real . -> . -Real))]
+[rationalize (cl->* (-ExactRational -ExactRational . -> . -ExactRational)
+                    (-Flonum . -> . -Flonum)
+                    (-Real -Real . -> . N))]
 [expt (cl->* (-Nat -Nat . -> . -Nat)
-             (-Integer -Integer . -> . -Integer)
+             (-Integer -Nat . -> . -Integer)
+             (-Real -Integer . -> . -Real)
+             (-InexactComplex -InexactComplex . -> . -InexactComplex)
              (N N . -> . N))]
 [sqrt (cl->*
        (-Nat . -> . -Real)
+       (-NonnegativeFlonum . -> . -NonnegativeFlonum)
+       (-InexactComplex . -> . -InexactComplex)
        (N . -> . N))]
 [log (cl->*
       (-Pos . -> . -Real)
+      (-InexactComplex . -> . -InexactComplex)
       (N . -> . N))]
-[exp  (N . -> . N)]
-[cos  (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))]
-[sin  (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))]
-[tan  (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))]
-[acos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))]
-[asin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))]
-[atan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N) (-Real -Real . -> . N))]
-[gcd  (null -Integer . ->* . -Integer)]
+[exp  (cl->* (-Flonum . -> . -Flonum)
+             (-Real . -> . -Real)
+             (-InexactComplex . -> . -InexactComplex)
+             (N . -> . N))]
+[cos  (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))]
+[sin  (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))]
+[tan  (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))]
+[acos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))]
+[asin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))]
+[atan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N) (-Real -Real . -> . N))]
+[gcd  (cl->* (null -Fixnum . ->* . -Fixnum) (null -Integer . ->* . -Integer))]
 [lcm  (null -Integer . ->* . -Integer)]
 
 ;; scheme/math
 
 [sgn (-Real . -> . -Real)]
-[pi -Flonum]
+[pi -NonnegativeFlonum]
 [sqr (cl->* (-> -Pos -Pos)
-            (-> -Nat -Nat)                          
+            (-> -Nat -Nat)
             (-> -Integer -Integer)
             (-> -ExactRational -ExactRational)
+            (-> -NonnegativeFlonum -NonnegativeFlonum)
             (-> -Flonum -Flonum)
             (-> -Real -Real)
+            (-> -InexactComplex -InexactComplex)
             (-> N N))]
-[sgn (N . -> . N)]
-[conjugate (N . -> . N)]
-[sinh (N . -> . N)]
-[cosh (N . -> . N)]
-[tanh (N . -> . N)]
+[conjugate (cl->* (-InexactComplex . -> . -InexactComplex)
+                  (N . -> . N))]
+[sinh (cl->* (-InexactComplex . -> . -InexactComplex)
+             (N . -> . N))]
+[cosh (cl->* (-InexactComplex . -> . -InexactComplex)
+             (N . -> . N))]
+[tanh (cl->* (-InexactComplex . -> . -InexactComplex)
+             (N . -> . N))]
 
 ;; unsafe numeric ops
-[unsafe-flabs fl-unop]
-[unsafe-fl+ fl-op]
+[unsafe-flabs (-> -Flonum -NonnegativeFlonum)]
+[unsafe-fl+ fl+*-type]
 [unsafe-fl- fl-op]
-[unsafe-fl* fl-op]
+[unsafe-fl* fl+*-type]
 [unsafe-fl/ fl-op]
-[unsafe-fl= fl-comp]
-[unsafe-fl<= fl-comp]
-[unsafe-fl>= fl-comp]
-[unsafe-fl> fl-comp]
-[unsafe-fl< fl-comp]
-[unsafe-flmin fl-op]
-[unsafe-flmax fl-op]
-[unsafe-flround fl-unop]
-[unsafe-flfloor fl-unop]
-[unsafe-flceiling fl-unop]
-[unsafe-fltruncate fl-unop]
+[unsafe-fl= fl=-type]
+[unsafe-fl<= fl<-type]
+[unsafe-fl>= fl>-type]
+[unsafe-fl> fl>-type]
+[unsafe-fl< fl<-type]
+[unsafe-flmin flmin-type]
+[unsafe-flmax flmax-type]
+[unsafe-flround fl-rounder]
+[unsafe-flfloor fl-rounder]
+[unsafe-flceiling fl-rounder]
+[unsafe-fltruncate fl-rounder]
 [unsafe-flsin fl-unop]
 [unsafe-flcos fl-unop]
 [unsafe-fltan fl-unop]
@@ -189,76 +465,79 @@
 [unsafe-flasin fl-unop]
 [unsafe-flacos fl-unop]
 [unsafe-fllog fl-unop]
-[unsafe-flexp fl-unop]
-[unsafe-flsqrt fl-unop]
-[unsafe-fx->fl (-Integer . -> . -Flonum)]
+[unsafe-flexp fl-rounder]
+[unsafe-flsqrt fl-rounder]
+[unsafe-fx->fl (cl->* (-Nat . -> . -NonnegativeFlonum) (-Integer . -> . -Flonum))]
+[unsafe-make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)]
+[unsafe-flreal-part (-InexactComplex . -> . -Flonum)]
+[unsafe-flimag-part (-InexactComplex . -> . -Flonum)]
 
-[unsafe-fx+ fx-op]
+[unsafe-fx+ fx+-type]
 [unsafe-fx- fx-intop]
 [unsafe-fx* fx-op]
 [unsafe-fxquotient fx-intop]
 [unsafe-fxremainder fx-intop]
 [unsafe-fxmodulo fx-intop]
-[unsafe-fxabs (-Integer . -> . -Nat)]
+[unsafe-fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))]
 
-[unsafe-fxand fx-intop]
-[unsafe-fxior fx-intop]
-[unsafe-fxxor fx-intop]
+[unsafe-fxand fx-op]
+[unsafe-fxior fx-op]
+[unsafe-fxxor fx-op]
 [unsafe-fxnot fx-unop]
 [unsafe-fxlshift fx-intop]
-[unsafe-fxrshift fx-intop]
+[unsafe-fxrshift (cl->* (-> -NonnegativeFixnum -NonnegativeFixnum -NonnegativeFixnum) fx-intop)]
 
-[unsafe-fx= fx-comp]
-[unsafe-fx< fx-comp]
-[unsafe-fx> fx-comp]
-[unsafe-fx<= fx-comp]
-[unsafe-fx>= fx-comp]
+[unsafe-fx= fx=-type]
+[unsafe-fx< fx<-type]
+[unsafe-fx> fx>-type]
+[unsafe-fx<= fx<=-type]
+[unsafe-fx>= fx>=-type]
 [unsafe-fxmin fx-op]
 [unsafe-fxmax fx-op]
 
 ;; scheme/fixnum
 
-[fx+ fx-op]
+[fx+ fx+-type]
 [fx- fx-intop]
 [fx* fx-op]
 [fxquotient fx-intop]
 [fxremainder fx-intop]
 [fxmodulo fx-intop]
-[fxabs (-Integer . -> . -Nat)]
+[fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))]
 
-[fxand fx-intop]
-[fxior fx-intop]
-[fxxor fx-intop]
+[fxand fx-op]
+[fxior fx-op]
+[fxxor fx-op]
 [fxnot fx-unop]
 [fxlshift fx-intop]
-[fxrshift fx-intop]
+[fxrshift (cl->* (-> -NonnegativeFixnum -NonnegativeFixnum -NonnegativeFixnum) fx-intop)]
 
-[fx= fx-comp]
-[fx< fx-comp]
-[fx> fx-comp]
-[fx<= fx-comp]
-[fx>= fx-comp]
+[fx= fx=-type]
+[fx< fx<-type]
+[fx> fx>-type]
+[fx<= fx<=-type]
+[fx>= fx>=-type]
 [fxmin fx-op]
 [fxmax fx-op]
 
 
 ;; safe flonum ops
-[flabs fl-unop]
-[fl+ fl-op]
+[flabs (-> -Flonum -NonnegativeFlonum)]
+[fl+ fl+*-type]
 [fl- fl-op]
-[fl* fl-op]
+[fl* fl+*-type]
 [fl/ fl-op]
-[fl= fl-comp]
-[fl<= fl-comp]
-[fl>= fl-comp]
-[fl> fl-comp]
-[fl< fl-comp]
-[flmin fl-op]
-[flmax fl-op]
-[flround fl-unop]
-[flfloor fl-unop]
-[flceiling fl-unop]
-[fltruncate fl-unop]
+[fl= fl=-type]
+[fl<= fl<-type]
+[fl>= fl>-type]
+[fl> fl>-type]
+[fl< fl<-type]
+[flmin flmin-type]
+[flmax flmax-type]
+[flround fl-rounder]
+[flfloor fl-rounder]
+[flceiling fl-rounder]
+[fltruncate fl-rounder]
 [flsin fl-unop]
 [flcos fl-unop]
 [fltan fl-unop]
@@ -269,18 +548,22 @@
 [flexp fl-unop]
 [flsqrt fl-unop]
 [->fl (-Integer . -> . -Flonum)]
+[make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)]
+[flreal-part (-InexactComplex . -> . -Flonum)]
+[flimag-part (-InexactComplex . -> . -Flonum)]
 
 ;; safe flvector ops
 
 [flvector? (make-pred-ty -FlVector)]
 [flvector (->* (list) -Flonum -FlVector)]
-[make-flvector (-> -Nat -Flonum -FlVector)]
-[flvector-length (-> -FlVector -Nat)]
-[flvector-ref (-> -FlVector -Nat -Flonum)]
-[flvector-set! (-> -FlVector -Nat -Flonum -Void)]
+[make-flvector (cl->* (-> -Integer -FlVector)
+                      (-> -Integer -Flonum -FlVector))]
+[flvector-length (-> -FlVector -NonnegativeFixnum)]
+[flvector-ref (-> -FlVector -Integer -Flonum)]
+[flvector-set! (-> -FlVector -Integer -Flonum -Void)]
 
 ;; unsafe flvector ops
 
-[unsafe-flvector-length (-> -FlVector -Nat)]
-[unsafe-flvector-ref (-> -FlVector -Nat -Flonum)]
-[unsafe-flvector-set! (-> -FlVector -Nat -Flonum -Void)]
+[unsafe-flvector-length (-> -FlVector -NonnegativeFixnum)]
+[unsafe-flvector-ref (-> -FlVector -Integer -Flonum)]
+[unsafe-flvector-set! (-> -FlVector -Integer -Flonum -Void)]
diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt
index 502bcbd9..fcd52e0f 100644
--- a/collects/typed-scheme/private/base-env.rkt
+++ b/collects/typed-scheme/private/base-env.rkt
@@ -1,22 +1,24 @@
 #lang s-exp "env-lang.rkt"
 
 (require
- scheme/tcp
- scheme
- scheme/unsafe/ops
- scheme/fixnum
+ racket/tcp
+ racket
+ racket/unsafe/ops
+ racket/fixnum
  (only-in rnrs/lists-6 fold-left)
  '#%paramz
  "extra-procs.rkt"
  (only-in '#%kernel [apply kernel:apply])
  (only-in racket/private/pre-base new-apply-proc)
- (for-syntax (only-in racket/private/pre-base new-apply-proc))
+ (for-syntax (only-in racket/private/pre-base new-apply-proc)
+             #;racket/string)
  scheme/promise scheme/system
+ racket/mpair
  (only-in string-constants/private/only-once maybe-print-message)
  (only-in mzscheme make-namespace)
  (only-in racket/match/runtime match:error matchable? match-equality-test)
  (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym])
-             (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-VectorTop)))
+             (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop)))
 
 [raise (Univ . -> . (Un))]
 [raise-syntax-error (cl->* 
@@ -188,7 +190,7 @@
                            'must-truncate 'truncate/replace)
         #f
         -Output-Port)]
-[read (->opt [-Input-Port] -Sexp)]
+[read (->opt [-Input-Port] Univ)]
 [ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
 [andmap (-polydots (a c d b) (cl->*
                               ;; 1 means predicate on second argument
@@ -207,10 +209,16 @@
 [empty? (make-pred-ty (-val null))]
 [empty (-val null)]
 
+[make-channel (-poly (a) (-> (-channel a)))]
+[channel? (make-pred-ty (make-ChannelTop))]
+[channel-get (-poly (a) ((-channel a) . -> . a))]
+[channel-try-get (-poly (a) ((-channel a) . -> . (Un a (-val #f))))]
+[channel-put (-poly (a) ((-channel a) a . -> . -Void))]
+
 [string? (make-pred-ty -String)]
 [string (->* '() -Char -String)]
-[string-length (-String . -> . -Nat)]
-[unsafe-string-length (-String . -> . -Nat)]
+[string-length (-String . -> . -NonnegativeFixnum)]
+[unsafe-string-length (-String . -> . -NonnegativeFixnum)]
 
 [symbol? (make-pred-ty Sym)]
 [keyword? (make-pred-ty -Keyword)]
@@ -266,19 +274,35 @@
 [match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))]
 [matchable? (make-pred-ty (Un -String -Bytes))]
 [display (Univ [-Output-Port] . ->opt . -Void)]
+[displayln (Univ [-Output-Port] . ->opt . -Void)]
 [write   (Univ [-Output-Port] . ->opt . -Void)]
 [print   (Univ [-Output-Port] . ->opt . -Void)]
 [void (->* '() Univ -Void)]
 [void? (make-pred-ty -Void)]
 [printf (->* (list -String) Univ -Void)]
+[eprintf (->* (list -String) Univ -Void)]
 [fprintf (->* (list -Output-Port -String) Univ -Void)]
 [format (->* (list -String) Univ -String)]
 
-[sleep (N . -> . -Void)]
+[thread (-> (-> Univ) -Thread)]
+[thread? (make-pred-ty -Thread)]
+[current-thread (-> -Thread)]
+[thread/suspend-to-kill (-> (-> Univ) -Thread)]
+[thread-suspend (-Thread . -> . -Void)]
+[kill-thread (-Thread . -> . -Void)]
+[break-thread (-Thread . -> . -Void)]
+[sleep ([N] . ->opt . -Void)]
+[thread-running? (-Thread . -> . B)]
+[thread-dead? (-Thread . -> . B)]
+[thread-wait (-Thread . -> . -Void)]
+[thread-send (-poly (a) (-Thread Univ [(-> a)] . ->opt . (Un -Void (-val #f) a)))]
+[thread-receive (-> Univ)]
+[thread-try-receive (-> Univ)]
+[thread-rewind-receive (-> (-lst Univ) -Void)]
 
 [reverse (-poly (a) (-> (-lst a) (-lst a)))]
 [append (-poly (a) (->* (list) (-lst a) (-lst a)))]
-[length (-poly (a) (-> (-lst a) -Nat))]
+[length (-poly (a) (-> (-lst a) -NonnegativeFixnum))]
 [memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
 [memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
 [memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))]
@@ -301,6 +325,22 @@
 [string<=? (->* (list -String -String) -String B)]
 [string>=? (->* (list -String -String) -String B)]
 
+[char-alphabetic? (-> -Char B)]
+[char-lower-case? (-> -Char B)]
+[char-upper-case? (-> -Char B)]
+[char-title-case? (-> -Char B)]
+[char-numeric? (-> -Char B)]
+[char-symbolic? (-> -Char B)]
+[char-punctuation? (-> -Char B)]
+[char-graphic? (-> -Char B)]
+[char-whitespace? (-> -Char B)]
+[char-blank? (-> -Char B)]
+[char-iso-control? (-> -Char B)]
+[char-general-category (-> -Char (apply Un (map -val
+  '(lu ll lt lm lo mn mc me nd nl no ps pe pi pf pd
+    pc po sc sm sk so zs zp zl cc cf cs co cn))))]
+[make-known-char-range-list (-> (-lst (-Tuple (list -ExactPositiveInteger -ExactPositiveInteger B))))]
+
 [string-ci<? (->* (list -String -String) -String B)]
 [string-ci>? (->* (list -String -String) -String B)]
 [string-ci=? (->* (list -String -String) -String B)]
@@ -315,8 +355,9 @@
 [char-downcase (-> -Char -Char)]
 [char-titlecase (-> -Char -Char)]
 [char-foldcase (-> -Char -Char)]
-[char->integer (-> -Char -Nat)]
-[integer->char (-> -Nat -Char)]
+[char->integer (-> -Char -NonnegativeFixnum)]
+[integer->char (-> -Integer -Char)]
+[char-utf-8-length (-> -Char (apply Un (map -val '(1 2 3 4 5 6))))]
 
 [string-normalize-nfd (-> -String -String)]
 [string-normalize-nfkd (-> -String -String)]
@@ -371,6 +412,11 @@
 [call-with-escape-continuation (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
 
 [struct->vector (Univ . -> . (-vec Univ))]
+[unsafe-struct-ref top-func]
+[unsafe-struct*-ref top-func]
+[unsafe-struct-set! top-func]
+[unsafe-struct*-set! top-func]
+
 ;; parameter stuff
 
 [parameterization-key Sym]
@@ -425,20 +471,6 @@
 
 [match:error ((list) Univ . ->* . (Un))]
 
-[arithmetic-shift (cl->* (-Nat -Nat . -> . -Nat)
-                         (-Integer -Integer . -> . -Integer))]
-[bitwise-and (cl->* (null -Nat . ->* . -Nat)
-                    (null -Integer . ->* . -Integer))]
-[bitwise-ior (cl->* (null -Nat . ->* . -Nat)
-                    (null -Integer . ->* . -Integer))]
-[bitwise-not (cl->* (null -Nat . ->* . -Nat)
-                    (null -Integer . ->* . -Integer))]
-[bitwise-xor (cl->* (null -Nat . ->* . -Nat)
-                    (null -Integer . ->* . -Integer))]
-
-[abs (cl->* (-Integer . -> . -Nat)
-            (-Real . -> . -Real))]
-
 [file-exists? (-Pathlike . -> . B)]
 [string->symbol (-String . -> . Sym)]
 [symbol->string (Sym . -> . -String)]
@@ -450,16 +482,16 @@
 
 [vector->list (-poly (a) (-> (-vec a) (-lst a)))]
 [list->vector (-poly (a) (-> (-lst a) (-vec a)))]
-[vector-length ((make-VectorTop) . -> . -Nat)]
+[vector-length ((make-VectorTop) . -> . -NonnegativeFixnum)]
 [vector (-poly (a) (->* (list) a (-vec a)))]
 [vector-immutable (-poly (a) (->* (list) a (-vec a)))]
 [vector->immutable-vector (-poly (a) (-> (-vec a) (-vec a)))]
 [vector-fill! (-poly (a) (-> (-vec a) a -Void))]
 [vector-argmax (-poly (a) (-> (-> a -Real) (-vec a) a))]
 [vector-argmin (-poly (a) (-> (-> a -Real) (-vec a) a))]
-[vector-memq (-poly (a) (-> a (-vec a) (-opt -Nat)))]
-[vector-memv (-poly (a) (-> a (-vec a) (-opt -Nat)))]
-[vector-member (-poly (a) (a (-vec a) . -> . (-opt -Nat)))]
+[vector-memq (-poly (a) (-> a (-vec a) (-opt -NonnegativeFixnum)))]
+[vector-memv (-poly (a) (-> a (-vec a) (-opt -NonnegativeFixnum)))]
+[vector-member (-poly (a) (a (-vec a) . -> . (-opt -NonnegativeFixnum)))]
 ;; [vector->values no good type here]
 
 
@@ -505,7 +537,8 @@
                  (cl-> [((-HT a b) a) b]
                        [((-HT a b) a (-> c)) (Un b c)]))]
 [hash-ref! (-poly (a b)
-                  (cl-> [((-HT a b) a (-> b)) b]))]
+                  (cl-> [((-HT a b) a b) b]
+                        [((-HT a b) a (-> b)) b]))]
 [hash-has-key? (-poly (a b) (-> (-HT a b) a B))]
 [hash-update! (-poly (a b)
                      (cl-> [((-HT a b) a (-> b b)) -Void]
@@ -517,7 +550,7 @@
 [hash-remove! (-poly (a b) ((-HT a b) a . -> . -Void))]
 [hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))]
 [hash-for-each (-poly (a b c) (-> (-HT a b) (-> a b c) -Void))]
-[hash-count (-poly (a b) (-> (-HT a b) -Nat))]
+[hash-count (-poly (a b) (-> (-HT a b) -NonnegativeFixnum))]
 [hash-copy (-poly (a b) (-> (-HT a b) (-HT a b)))]
 [eq-hash-code (-poly (a) (-> a -Integer))]
 [eqv-hash-code (-poly (a) (-> a -Integer))]
@@ -531,25 +564,35 @@
                            ((-HT a b) -Integer . -> . a))]
 [hash-iterate-value (-poly (a b)
                            ((-HT a b) -Integer . -> . b))]
-#;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))]
 
 [bytes (->* (list) -Integer -Bytes)]
-[bytes-ref (-> -Bytes -Integer -Integer)]
-[bytes-append (->* (list -Bytes) -Bytes -Bytes)]
-[subbytes (cl-> [(-Bytes -Integer) -Bytes] [(-Bytes -Integer -Integer) -Bytes])]
-[bytes-length (-> -Bytes -Nat)]
-[unsafe-bytes-length (-> -Bytes -Nat)]
+[bytes? (make-pred-ty -Bytes)]
+[make-bytes (cl-> [(-Integer -Integer) -Bytes]
+                  [(-Integer) -Bytes])]
+[bytes->immutable-bytes (-> -Bytes -Bytes)]
+[byte? (make-pred-ty -NonnegativeFixnum)]
+[bytes-append (->* (list) -Bytes -Bytes)]
+[bytes-length (-> -Bytes -NonnegativeFixnum)]
+[unsafe-bytes-length (-> -Bytes -NonnegativeFixnum)]
+[bytes-copy (-> -Bytes -Bytes)]
+[bytes->list (-> -Bytes (-lst -NonnegativeFixnum))]
+[list->bytes (-> (-lst -Integer) -Bytes)]
+[bytes<? (->* (list -Bytes) -Bytes B)]
+[bytes>? (->* (list -Bytes) -Bytes B)]
+[bytes=? (->* (list -Bytes) -Bytes B)]
 
-[read-bytes-line (->opt [-Input-Port Sym] -Bytes)]
+[read-bytes-line (->opt [-Input-Port Sym] (Un -Bytes (-val eof)))]
 [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)]
 [close-input-port (-> -Input-Port -Void)]
 [close-output-port (-> -Output-Port -Void)]
-[read-line  (->opt [-Input-Port Sym] -String)]
+[read-line  (->opt [-Input-Port Sym] (Un -String (-val eof)))]
 [copy-file (-> -Pathlike -Pathlike -Void)]
-[bytes->string/utf-8 (-> -Bytes -String)]
+[flush-output (->opt [-Output-Port] -Void)]
+[file-stream-buffer-mode (cl-> [(-Port) (Un (-val 'none) (-val 'line) (-val 'block) (-val #f))]
+                               [(-Port (Un (-val 'none) (-val 'line) (-val 'block))) -Void])]
+[file-position (-> -Port -Nat)]
 
 [force (-poly (a) (-> (-Promise a) a))]
-[bytes<? (->* (list -Bytes) -Bytes B)]
 [regexp-replace*
  (cl->* (-Pattern -String -String . -> . -String)
 	(-Pattern (Un -Bytes -String) (Un -Bytes -String) . -> . -Bytes))]
@@ -563,11 +606,11 @@
 [open-output-bytes
  (cl->* [[Univ] . ->opt . -Output-Port])]
 [get-output-bytes (-Output-Port [Univ N N] . ->opt . -Bytes)]
-#;[exn:fail? (-> Univ B)]
-#;[exn:fail:read? (-> Univ B)]
+[char-ready? (->opt [-Input-Port] B)]
+[byte-ready? (->opt [-Input-Port] B)]
 
 [open-output-string (-> -Output-Port)]
-;; FIXME - wrong
+;; FIXME - this is too general
 [get-output-string (-> -Output-Port -String)]
 
 [make-directory (-> -Path -Void)]
@@ -575,11 +618,11 @@
 [delete-file (-> -Pathlike -Void)]
 [make-namespace (->opt [(Un (-val 'empty) (-val 'initial))] -Namespace)]
 [make-base-namespace (-> -Namespace)]
-[eval (-> -Sexp Univ)]
+[eval (->opt Univ [-Namespace] Univ)]
 
 [exit (-> (Un))]
 
-[module->namespace (-> -Sexp -Namespace)]
+[module->namespace (-> (-mu x (-lst (Un -Symbol -String -Nat x (-val #f)))) -Namespace)]
 [current-namespace (-Param -Namespace -Namespace)]
 
 [getenv (-> -String (Un -String (-val #f)))]
@@ -630,13 +673,27 @@
 
 [list->string ((-lst -Char) . -> . -String)]
 [string->list (-String . -> . (-lst -Char))]
-[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))]
+[build-string (-Nat (-Integer . -> . -Char) . -> . -String)]
+
+[sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B)
+                          #:cache-keys? B #f
+                          . ->key . (-lst a))
+                         ((-lst a) (b b . -> . B)
+                          #:key (a . -> . b) #t
+                          #:cache-keys? B #f
+                          . ->key . (-lst a))))]
 [find-system-path (Sym . -> . -Path)]
 
 [object-name (Univ . -> . Univ)]
 
 [path? (make-pred-ty -Path)]
 
+;; scheme/function
+[const (-poly (a) (-> a (->* '() Univ a)))]
+(primitive? (-> Univ B))
+(primitive-closure? (-> Univ B))
+
+
 ;; scheme/cmdline
 
 [parse-command-line
@@ -656,7 +713,7 @@
                     (-lst a))
                    ((-lst b) b) 
                    . ->... . 
-                   -Nat))]
+                   -NonnegativeFixnum))]
 [filter-map (-polydots (c a b)
                        ((list
                          ((list a) (b b) . ->... . (-opt c))
@@ -678,6 +735,8 @@
                      ((-lst b) b) . ->... .(-lst c)))]
 [append*
  (-poly (a) ((-lst (-lst a)) . -> . (-lst a)))]
+[argmin (-poly (a) ((a . -> . -Real) (-lst a) . -> . a))]
+[argmax (-poly (a) ((a . -> . -Real) (-lst a) . -> . a))]
 
 ;; scheme/tcp
 [tcp-listener? (make-pred-ty -TCP-Listener)]
@@ -687,11 +746,11 @@
 [tcp-accept-ready? (-TCP-Listener . -> . B )]
 [tcp-addresses (cl->*
 		(-Port [(-val #f)] . ->opt . (-values (list -String -String)))
-		(-Port (-val #t) . -> . (-values (list -String -Nat -String -Nat))))]
+		(-Port (-val #t) . -> . (-values (list -String -NonnegativeFixnum -String -NonnegativeFixnum))))]
 [tcp-close (-TCP-Listener . -> . -Void )]
 [tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
 [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
-[tcp-listen (N . -> . -TCP-Listener)]
+[tcp-listen (-Integer [-Integer Univ (-opt -String)] . ->opt . -TCP-Listener)]
 
 ;; scheme/bool
 [boolean=? (B B . -> . B)]
@@ -707,9 +766,17 @@
 
 ;; scheme/port
 [port->lines (cl->* ([-Input-Port] . ->opt . (-lst -String)))]
+[port->bytes-lines (cl->* ([-Input-Port] . ->opt . (-lst -Bytes)))]
+[port->list (-poly (a) (->opt [(-> -Input-Port a) -Input-Port] (-lst a)))]
+[port->bytes (->opt [-Input-Port] -Bytes)]
+[port->string (->opt [-Input-Port] -String)]
 [with-output-to-string
   (-> (-> Univ) -String)]
 [open-output-nowhere (-> -Output-Port)]
+[copy-port (->* (list -Input-Port -Output-Port) -Output-Port -Void)]
+
+[input-port? (make-pred-ty -Input-Port)]
+[output-port? (make-pred-ty -Output-Port)]
 
 ;; scheme/path
 
@@ -743,16 +810,17 @@
 
 ;; unsafe
 
-[unsafe-vector-ref (-poly (a) ((-vec a) -Nat . -> . a))]
-[unsafe-vector*-ref (-poly (a) ((-vec a) -Nat . -> . a))]
-[unsafe-vector-length (-poly (a) ((-vec a) . -> . -Nat))]
-[unsafe-vector*-length (-poly (a) ((-vec a) . -> . -Nat))]
+[unsafe-vector-length ((make-VectorTop) . -> . -NonnegativeFixnum)]
+[unsafe-vector*-length ((make-VectorTop) . -> . -NonnegativeFixnum)]
 [unsafe-car (-poly (a b) 
-              (cl->*
-               (->acc (list (-pair a b)) a (list -car))))]
+                   (cl->*
+                    (->acc (list (-pair a b)) a (list -car))
+                    (->* (list (-lst a)) a)))]
 [unsafe-cdr (-poly (a b) 
-              (cl->*
-               (->acc (list (-pair a b)) b (list -cdr))))]
+                   (cl->*
+                    (->acc (list (-pair a b)) b (list -cdr))
+                    (->* (list (-lst a)) (-lst a))))]
+
 
 ;; scheme/vector
 [vector-count (-polydots (a b)
@@ -761,7 +829,7 @@
                            (-vec a))
                           ((-vec b) b)
                           . ->... . 
-                          -Nat))]
+                          -NonnegativeFixnum))]
 [vector-filter (-poly (a b) (cl->*
                              ((make-pred-ty (list a) Univ b)
                               (-vec a)
@@ -791,6 +859,12 @@
  (-poly (a) ((list (-vec a)) -Integer . ->* . (-values (list (-vec a) (-vec a)))))]
 
 
+;; racket/string
+[string-join (-> (-lst -String) -String -String)]
+[string-append*
+ (cl->* (-> (-lst -String) -String)
+        (-> -String (-lst -String) -String))]
+
 ;; scheme/system
 [system (-String . -> . -Boolean)]
 [system* ((list -Pathlike) -String . ->* . -Boolean)]
@@ -798,32 +872,11 @@
 [system*/exit-code ((list -Pathlike) -String . ->* . -Integer)]
 
 ;; Byte and String Output (Section 12.3 of the Reference)
+;; some are now in base-env-indexing-abs.rkt
 [write-char (cl-> [(-Char) -Void]
                   [(-Char -Output-Port) -Void])]
-[write-byte (cl-> [(-Nat) -Void]
-                  [(-Nat -Output-Port) -Void])]
 [newline (cl-> [() -Void]
                [(-Output-Port) -Void])]
-[write-string (cl-> [(-String) -Nat]
-                    [(-String -Output-Port) -Nat]
-                    [(-String -Output-Port -Nat) -Nat]
-                    [(-String -Output-Port -Nat -Nat) -Nat])]
-[write-bytes  (cl-> [(-Bytes) -Nat]
-                    [(-Bytes -Output-Port) -Nat]
-                    [(-Bytes -Output-Port -Nat) -Nat]
-                    [(-Bytes -Output-Port -Nat -Nat) -Nat])]
-[write-bytes-avail  (cl-> [(-Bytes) -Nat]
-                          [(-Bytes -Output-Port) -Nat]
-                          [(-Bytes -Output-Port -Nat) -Nat]
-                          [(-Bytes -Output-Port -Nat -Nat) -Nat])]
-[write-bytes-avail*  (cl-> [(-Bytes) (-opt -Nat)]
-                           [(-Bytes -Output-Port) (-opt -Nat)]
-                           [(-Bytes -Output-Port -Nat) (-opt -Nat)]
-                           [(-Bytes -Output-Port -Nat -Nat) (-opt -Nat)])]
-[write-bytes-avail/enable-break (cl-> [(-Bytes) -Nat]
-                                      [(-Bytes -Output-Port) -Nat]
-                                      [(-Bytes -Output-Port -Nat) -Nat]
-                                      [(-Bytes -Output-Port -Nat -Nat) -Nat])]
 [write-special (cl-> [(Univ) -Boolean]
                      [(Univ -Output-Port) -Boolean])]
 ;; Need event type before we can include these
@@ -832,3 +885,27 @@
 ;;write-special-evt
 [port-writes-atomic? (-Output-Port . -> . -Boolean)]
 [port-writes-special? (-Output-Port . -> . -Boolean)]
+
+;; probably the most useful cases
+[curry (-poly (a b c) 
+	      (cl->* ((a b . -> . c) a . -> . (b . -> . c))
+		     ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))]
+;; mutable pairs
+[mcons (-poly (a b) (-> a b (-mpair a b)))]
+[mcar (-poly (a b)
+             (cl->* (-> (-mpair a b) a)
+                    (-> (-mlst a) a)))]
+[mcdr (-poly (a b)
+             (cl->* (-> (-mpair a b) b)
+                    (-> (-mlst a) (-mlst a))))]
+[set-mcar! (-poly (a b)
+                  (cl->* (-> (-mpair a b) a -Void)
+                         (-> (-mlst a) a -Void)))]
+[set-mcdr! (-poly (a b)
+                  (cl->* (-> (-mpair a b) b -Void)
+                         (-> (-mlst a) (-mlst a) -Void)))]
+[mpair? (make-pred-ty (make-MPairTop))]
+[mlist (-poly (a) (->* (list) a (-mlst a)))]
+[mlength (-poly (a) (-> (-mlst a) -NonnegativeFixnum))]
+[mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))]
+[mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))]
diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt
index 6575c55f..a643b158 100644
--- a/collects/typed-scheme/private/base-special-env.rkt
+++ b/collects/typed-scheme/private/base-special-env.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 
 ;; these are libraries providing functions we add types to that are not in scheme/base
 (require
@@ -31,7 +31,7 @@
           (define-hierarchy child (spec ...) grand ...)
           ...)
        (begin
-         (d-s parent ([name : type] ...) ())
+         (d-s parent ([name : type] ...))
          (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...)
          ...)]))
 
@@ -66,9 +66,14 @@
      [year-day : -Number]
      [dst? : -Boolean]
      [time-zone-offset : -Number]))
+  
+  (define-hierarchy arity-at-least
+    ([value : -Nat]))
 
   (define-hierarchy exn
     ([message : -String] [continuation-marks : -Cont-Mark-Set])
+    
+    (define-hierarchy exn:break ([continuation : top-func]))
 
     (define-hierarchy exn:fail ()
 
@@ -160,6 +165,8 @@
                              (-> Univ Univ)
                              (-> a Univ)
                              (-> Univ a Univ))))])
+            (-> Univ (-seq a) (seq-vals))
+            #;
             (cl->* (-> Univ (-lst a) (seq-vals))
                    (-> Univ (-vec a) (seq-vals))
                    (-> Univ -String (seq-vals -Char))
diff --git a/collects/typed-scheme/private/base-types-extra.rkt b/collects/typed-scheme/private/base-types-extra.rkt
index de39e172..5e8eef63 100644
--- a/collects/typed-scheme/private/base-types-extra.rkt
+++ b/collects/typed-scheme/private/base-types-extra.rkt
@@ -13,11 +13,12 @@
 ;; special type names that are not bound to particular types
 (define-other-types
   -> U Rec All Opaque Vector
-  Parameterof List Class Values Instance Refinement
+  Parameterof List List* Class Values Instance Refinement
   pred)
 
 (provide (rename-out [All ∀]
                      [U Un]
+		     [-> →]
                      [List Tuple]
                      [Rec mu]
                      [Parameterof Parameter]))
diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types.rkt
similarity index 80%
rename from collects/typed-scheme/private/base-types-new.rkt
rename to collects/typed-scheme/private/base-types.rkt
index 98d22dec..5b51c829 100644
--- a/collects/typed-scheme/private/base-types-new.rkt
+++ b/collects/typed-scheme/private/base-types.rkt
@@ -1,14 +1,20 @@
 #lang s-exp "type-env-lang.rkt"
 
 [Complex -Number]
+[Inexact-Complex -InexactComplex]
 [Number -Number]
 [Integer -Integer]
 [Real -Real]
 [Exact-Rational -ExactRational]
 [Float -Flonum]
+[Nonnegative-Float -NonnegativeFlonum]
 [Exact-Positive-Integer -ExactPositiveInteger]
 [Exact-Nonnegative-Integer -ExactNonnegativeInteger]
+[Positive-Fixnum -PositiveFixnum]
+[Nonnegative-Fixnum -NonnegativeFixnum]
+[Fixnum -Fixnum]
 [Natural -ExactNonnegativeInteger]
+[Zero (-val 0)]
 
 [Void -Void]
 [Boolean -Boolean]
@@ -20,6 +26,8 @@
 [Path-String -Pathlike]
 [Regexp -Regexp]
 [PRegexp -PRegexp]
+[Byte-Regexp -Byte-Regexp]
+[Byte-PRegexp -Byte-PRegexp]
 [Char -Char]
 [Namespace -Namespace]
 [Input-Port -Input-Port]
@@ -35,6 +43,7 @@
 [Identifier Ident]
 [Procedure top-func]
 [Keyword -Keyword]
+[Thread -Thread]
 [Listof -Listof]
 [Vectorof (-poly (a) (make-Vector a))]
 [FlVector -FlVector]
@@ -43,6 +52,7 @@
 [Promise (-poly (a) (-Promise a))]
 [Pair (-poly (a b) (-pair a b))]
 [Boxof (-poly (a) (make-Box a))]
+[Channelof (-poly (a) (make-Channel a))]
 [Continuation-Mark-Set -Cont-Mark-Set]
 [False (-val #f)]
 [True (-val #t)]
@@ -50,4 +60,6 @@
 [Nothing (Un)]
 [Pairof (-poly (a b) (-pair a b))]
 [MPairof (-poly (a b) (-mpair a b))]
+[MListof (-poly (a) (-mlst a))]
+[Sequenceof (-poly (a) (-seq a))]
 
diff --git a/collects/typed-scheme/private/extra-procs.rkt b/collects/typed-scheme/private/extra-procs.rkt
index 6cd86438..b4a74b03 100644
--- a/collects/typed-scheme/private/extra-procs.rkt
+++ b/collects/typed-scheme/private/extra-procs.rkt
@@ -1,8 +1,10 @@
 #lang scheme/base
 (provide assert)
 
-(define (assert v [pred values])
-  (unless (pred v)
-    (error "Assertion failed"))
-  v)
-
+(define-syntax assert
+  (syntax-rules ()
+    ((assert v)
+     (or v (error "Assertion failed")))
+    ((assert v pred)
+     (let ((val v))
+       (if (pred val) val (error "Assertion failed"))))))
diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt
index 83c7f36b..3d9bea9b 100644
--- a/collects/typed-scheme/private/for-clauses.rkt
+++ b/collects/typed-scheme/private/for-clauses.rkt
@@ -2,18 +2,23 @@
 
 (require syntax/parse
          "annotate-classes.rkt"
-         (for-template racket/base))
+         (for-template racket/base
+                       "base-types.rkt"))
 
 (provide (all-defined-out))
 
 (define-splicing-syntax-class for-clause
     ;; single-valued seq-expr
-    (pattern (var:annotated-name seq-expr:expr)
-             #:with (expand ...) (list #'(var.ann-name seq-expr)))
+    (pattern (~and c (var:annotated-name seq-expr:expr))
+             #:with (expand ...) (list (syntax/loc
+                                           #'c
+                                         (var.ann-name seq-expr))))
     ;; multi-valued seq-expr
     ;; currently disabled because it triggers an internal error in the typechecker
-    #;(pattern (((v:annotated-name) ...) seq-expr:expr)
-             #:with (expand ...) (list #'((v.ann-name ...) seq-expr)))
+    #;(pattern (~and c (((v:annotated-name) ...) seq-expr:expr))
+             #:with (expand ...) (list (syntax/loc
+                                           #'c
+                                         ((v.ann-name ...) seq-expr))))
     ;; when clause
     (pattern (~seq #:when guard:expr)
              #:with (expand ...) (list #'#:when #'guard)))
@@ -21,12 +26,18 @@
 ;; intersperses "#:when #t" clauses to emulate the for* variants' semantics
 (define-splicing-syntax-class for*-clause
   ;; single-valued seq-expr
-    (pattern (var:annotated-name seq-expr:expr)
-             #:with (expand ...) (list #'(var.ann-name seq-expr) #'#:when #'#t))
+    (pattern (~and c (var:annotated-name seq-expr:expr))
+             #:with (expand ...) (list (syntax/loc
+                                           #'c
+                                         (var.ann-name seq-expr))
+                                       #'#:when #'#t))
     ;; multi-valued seq-expr
     ;; currently disabled because it triggers an internal error in the typechecker
-    #;(pattern (((v:annotated-name) ...) seq-expr:expr)
-             #:with (expand ...) (list #'((v.ann-name ...) seq-expr) #'#:when #'#t))
+    #;(pattern (~and c (((v:annotated-name) ...) seq-expr:expr))
+             #:with (expand ...) (list (quasisyntax/loc
+                                           #'c
+                                         ((v.ann-name ...) seq-expr))
+                                       #'#:when #'#t))
     ;; when clause
     (pattern (~seq #:when guard:expr)
              #:with (expand ...) (list #'#:when #'guard)))
diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt
deleted file mode 100644
index 8e7358ea..00000000
--- a/collects/typed-scheme/private/optimize.rkt
+++ /dev/null
@@ -1,115 +0,0 @@
-#lang scheme/base
-
-(require syntax/parse (for-template scheme/base scheme/flonum scheme/unsafe/ops)
-         "../utils/utils.rkt" unstable/match scheme/match unstable/syntax
-         (rep type-rep)
-         (types abbrev type-table utils))
-(provide optimize)
-
-(define-syntax-class float-opt-expr
-  (pattern e:opt-expr
-           #:when (match (type-of #'e)
-                    [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f])
-           #:with opt #'e.opt))
-
-(define-syntax-class float-binary-op
-  #:literals (+ - * / = <= < > >= min max
-              fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax)
-  (pattern (~and i:id (~or + - * / = <= < > >= min max))
-           #:with unsafe (format-id #'here "unsafe-fl~a" #'i))
-  (pattern (~and i:id (~or fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax))
-           #:with unsafe (format-id #'here "unsafe-~a" #'i)))
-
-(define-syntax-class float-unary-op
-  #:literals (abs sin cos tan asin acos atan log exp sqrt round floor ceiling truncate
-              flabs flsin flcos fltan flasin flacos flatan fllog flexp flsqrt flround flfloor flceiling fltruncate)
-  (pattern (~and i:id (~or abs sin cos tan asin acos atan log exp sqrt round floor ceiling truncate))
-           #:with unsafe (format-id #'here "unsafe-fl~a" #'i))
-  (pattern (~and i:id (~or flabs flsin flcos fltan flasin flacos flatan fllog flexp flsqrt flround flfloor flceiling fltruncate))
-           #:with unsafe (format-id #'here "unsafe-~a" #'i)))
-
-(define-syntax-class pair-opt-expr
-  (pattern e:opt-expr
-           #:when (match (type-of #'e) ; type of the operand
-                    [(tc-result1: (Pair: _ _)) #t]
-                    [_ #f])
-           #:with opt #'e.opt))
-
-(define-syntax-class pair-unary-op
-  #:literals (car cdr)
-  (pattern (~and i:id (~or car cdr))
-           #:with unsafe (format-id #'here "unsafe-~a" #'i)))
-
-(define-syntax-class opt-expr
-  (pattern e:opt-expr*
-           #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
-
-(define *log-optimizations?* #f)
-(define *log-optimizatons-to-log-file?* #f)
-(define *optimization-log-file* "opt-log")
-(define (log-optimization kind stx)
-  (if *log-optimizations?*
-      (printf "~a line ~a col ~a - ~a\n"
-              (syntax-source stx) (syntax-line stx) (syntax-column stx)
-              kind)
-      #t))
-
-(define-syntax-class opt-expr*
-  #:literal-sets (kernel-literals)
-  #:local-conventions ([#px"^e" opt-expr]
-                       [#px"^f\\d*s?$" float-opt-expr]
-                       [#px"^p\\d*s?$" pair-opt-expr])
-
-  ;; interesting cases, where something is optimized
-  (pattern (#%plain-app op:float-unary-op f)
-           #:with opt
-           (begin (log-optimization "unary float" #'op)
-                  #'(op.unsafe f.opt)))
-  ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
-  (pattern (#%plain-app op:float-binary-op f1 f2 fs ...)
-           #:with opt 
-           (begin (log-optimization "binary float" #'op)
-                  (for/fold ([o #'f1.opt])
-                      ([e (syntax->list #'(f2.opt fs.opt ...))])
-                    #`(op.unsafe #,o #,e))))
-  (pattern (#%plain-app op:pair-unary-op p)
-           #:with opt
-           (begin (log-optimization "unary pair" #'op)
-                  #'(op.unsafe p.opt)))
-
-  ;; boring cases, just recur down
-  (pattern (#%plain-lambda formals e ...)
-           #:with opt #'(#%plain-lambda formals e.opt ...))
-  (pattern (define-values formals e ...)
-           #:with opt #'(define-values formals e.opt ...))
-  (pattern (case-lambda [formals e ...] ...)
-           #:with opt #'(case-lambda [formals e.opt ...] ...))
-  (pattern (let-values ([ids e-rhs] ...) e-body ...)
-           #:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
-  (pattern (letrec-values ([ids e-rhs] ...) e-body ...)
-           #:with opt #'(letrec-values ([ids e-rhs.opt] ...) e-body.opt ...))
-  (pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs] ...) e-body ...)
-           #:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
-  (pattern (kw:identifier expr ...)
-           #:when (ormap (lambda (k) (free-identifier=? k #'kw))
-                         (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
-                               #'#%variable-reference #'with-continuation-mark))
-           #:with opt #'(kw expr.opt ...))
-  (pattern other:expr
-           #:with opt #'other))
-
-(define (optimize stx)
-  (let ((port (if (and *log-optimizations?*
-                       *log-optimizatons-to-log-file?*)
-                  (open-output-file *optimization-log-file*
-                                    #:exists 'append)
-                  (current-output-port))))
-    (begin0
-      (parameterize ([current-output-port port])
-        (syntax-parse stx #:literal-sets (kernel-literals)
-                      [e:opt-expr
-                       (syntax/loc stx e.opt)]))
-      (if (and *log-optimizations?*
-               *log-optimizatons-to-log-file?*)
-          (close-output-port port)
-          #t))))
diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt
index 3477ec06..23285bcd 100644
--- a/collects/typed-scheme/private/parse-type.rkt
+++ b/collects/typed-scheme/private/parse-type.rkt
@@ -6,7 +6,7 @@
          (utils tc-utils stxclass-util)
          syntax/stx (prefix-in c: scheme/contract)
          syntax/parse
-         (env type-environments type-name-env type-alias-env lexical-env)         
+         (env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env)         
          scheme/match unstable/debug
          (for-template scheme/base "colon.ss")
          ;; needed at this phase for tests
@@ -51,23 +51,34 @@
            #:attr bound (datum->syntax #'i (string->symbol (substring (attribute s) 3)) #'i #'i))
   (pattern (~seq _:ddd bound:id)))
 
+(define (parse-all-body s)
+  (syntax-parse s
+    [(ty)
+     (parse-type #'ty)]
+    [(x ...)
+     #:fail-unless (= 1 (length 
+			 (for/list ([i (syntax->list #'(x ...))]
+				    #:when (and (identifier? i)
+						(free-identifier=? i #'t:->)))
+				   i))) 
+     #f
+     (parse-type s)]))
+
 (define (parse-all-type stx parse-type)
   ;(printf "parse-all-type: ~a ~n" (syntax->datum stx))
   (syntax-parse stx #:literals (t:All)
-    [((~and kw t:All) (vars:id ... v:id dd:ddd) t)
+    [((~and kw t:All) (vars:id ... v:id dd:ddd) . t)
      (let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
-            [tvars (map make-F vars)]
-            [v (syntax-e #'v)]
-            [tv (make-Dotted (make-F v))])
+            [v (syntax-e #'v)])
        (add-type-name-reference #'kw)
-       (parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))])
-         (make-PolyDots (append vars (list v)) (parse-type #'t))))]
-    [((~and kw t:All) (vars:id ...) t) 
-     (let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
-            [tvars (map make-F vars)])
+       (extend-indexes v
+         (extend-tvars vars
+           (make-PolyDots (append vars (list v)) (parse-all-body #'t)))))]
+    [((~and kw t:All) (vars:id ...) . t) 
+     (let* ([vars (map syntax-e (syntax->list #'(vars ...)))])
        (add-type-name-reference #'kw)
-       (parameterize ([current-tvars (extend-env vars tvars (current-tvars))])
-         (make-Poly vars (parse-type #'t))))]
+       (extend-tvars vars
+         (make-Poly vars (parse-all-body #'t))))]
     [(t:All (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")]
     [(t:All . rest) (tc-error "All: bad syntax")]))
 
@@ -98,7 +109,7 @@
   (parameterize ([current-orig-stx stx])    
     (syntax-parse
         stx
-      #:literals (t:Class t:Refinement t:Instance t:List cons t:pred t:-> : case-lambda
+      #:literals (t:Class t:Refinement t:Instance t:List t:List* cons t:pred t:-> : case-lambda
                           t:Rec t:U t:All t:Opaque t:Parameter t:Vector quote)
       [t
        #:declare t (3d Type?)
@@ -135,7 +146,10 @@
              (make-Instance v)))]
       [((~and kw t:List) ts ...)
        (add-type-name-reference #'kw)
-       (-Tuple (map parse-type (syntax->list #'(ts ...))))]
+       (parse-list-type stx)]
+      [((~and kw t:List*) ts ... t)
+       (add-type-name-reference #'kw)
+       (-Tuple* (map parse-type (syntax->list #'(ts ...))) (parse-type #'t))]
       [((~and kw t:Vector) ts ...)
        (add-type-name-reference #'kw)
        (make-HeterogenousVector (map parse-type (syntax->list #'(ts ...))))]
@@ -163,10 +177,7 @@
        (let* ([var (syntax-e #'x)]
               [tvar (make-F var)])
          (add-type-name-reference #'kw)
-         (parameterize ([current-tvars (extend-env 
-                                        (list var) 
-                                        (list tvar)
-                                        (current-tvars))])
+         (extend-tvars (list var)
            (let ([t (parse-type #'t)])
              (if (memq var (fv t))
                  (make-Mu var t)
@@ -193,6 +204,12 @@
        (add-type-name-reference #'kw)
        (-Param (parse-type #'t1) (parse-type #'t2))]
       ;; function types
+      ;; handle this error first:
+      [((~or dom (~between (~and kw t:->) 2 +inf.0)) ...)
+       (for ([k (syntax->list #'(kw ...))]) (add-type-name-reference k))
+       (tc-error/stx (syntax->list #'(kw ...))
+                     "The -> type constructor may be used only once in a form")
+       Err]
       [(dom (~and kw t:->) rng : ~! latent:latent-filter)
        (add-type-name-reference #'kw)
        ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
@@ -207,42 +224,27 @@
                #:kws (attribute kws.Keyword))))]
       [(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng)
        (add-type-name-reference #'kw)
-       (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
-         (if (not (Dotted? var))
-             (tc-error/stx #'bound 
-                           "Used a type variable (~a) not bound with ... as a bound on a ..."
-                           (syntax-e #'bound))
-             (make-Function
-              (list
-               (make-arr-dots (map parse-type (syntax->list #'(dom ...)))
-                              (parse-values-type #'rng)
-                              (parameterize 
-                                  ([current-tvars 
-                                    (extend-env 
-                                     (list (syntax-e #'bound)) 
-                                     (list (make-DottedBoth (make-F (syntax-e #'bound))))
-                                     (current-tvars))])
-                                (parse-type #'rest))
-                              (syntax-e #'bound))))))]
+       (let* ([bnd (syntax-e #'bound)])
+         (unless (bound-index? bnd)
+           (tc-error/stx #'bound 
+                         "Used a type variable (~a) not bound with ... as a bound on a ..."
+                         bnd))
+         (make-Function
+          (list
+           (make-arr-dots (map parse-type (syntax->list #'(dom ...)))
+                          (parse-values-type #'rng)
+                          (extend-tvars (list bnd)
+                            (parse-type #'rest))
+                          bnd))))]
       [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng)
        (add-type-name-reference #'kw)
-       (let ([bounds (filter (compose Dotted? cdr)
-                             (env-keys+vals (current-tvars)))])
-         (when (null? bounds)
-           (tc-error/stx stx "No type variable bound with ... in scope for ... type"))
-         (unless (null? (cdr bounds))
-           (tc-error/stx stx "Cannot infer bound for ... type"))
-         (match-let ([(cons var (struct Dotted (t))) (car bounds)])
-           (make-Function
-            (list
-             (make-arr-dots (map parse-type (syntax->list #'(dom ...)))
-                            (parse-values-type #'rng)
-                            (parameterize ([current-tvars 
-                                            (extend-env (list var)
-                                                        (list (make-DottedBoth t))
-                                                        (current-tvars))])
-                              (parse-type #'rest))
-                            var)))))]
+       (let ([var (infer-index stx)])
+         (make-Function
+          (list
+           (make-arr-dots (map parse-type (syntax->list #'(dom ...)))
+                          (parse-values-type #'rng)
+                          (extend-tvars (list var) (parse-type #'rest))
+                          var))))]
       #| ;; has to be below the previous one
      [(dom:expr ... (~and kw t:->) rng) 
       (add-type-name-reference #'kw)
@@ -251,23 +253,24 @@
       ;; use expr to rule out keywords
       [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng)
        (add-type-name-reference #'kw)
-       (make-Function
-        (list (make-arr
-               (map parse-type (syntax->list #'(dom ...)))
-               (parse-values-type #'rng)
-               #:kws (attribute kws.Keyword))))]
+      (let ([doms (for/list ([d (syntax->list #'(dom ...))])
+                    (parse-type d))])
+         (make-Function
+          (list (make-arr
+                 doms
+                 (parse-values-type #'rng)
+                 #:kws (attribute kws.Keyword)))))]
       
       [id:identifier
        (cond 
          ;; if it's a type variable, we just produce the corresponding reference (which is in the HT)
-         [(lookup (current-tvars) (syntax-e #'id) (lambda (_) #f))
-          =>
-          (lambda (e) (cond [(DottedBoth? e) (Dotted-t e)]
-                            [(Dotted? e)
-                             (tc-error 
-                              "Type variable ~a must be used with ..."
-                              (syntax-e #'id))]
-                            [else e]))]
+         [(bound-tvar? (syntax-e #'id))
+          (make-F (syntax-e #'id))]
+         ;; if it was in current-indexes, produce a better error msg
+         [(bound-index? (syntax-e #'id))
+          (tc-error
+           "Type variable ~a must be used with ..."
+           (syntax-e #'id))]
          ;; if it's a type alias, we expand it (the expanded type is stored in the HT)
          [(lookup-type-alias #'id parse-type (lambda () #f))
           =>
@@ -334,34 +337,54 @@
        (-val (syntax-e #'t))]
       [_ (tc-error "not a valid type: ~a" (syntax->datum stx))])))
 
+(define (parse-list-type stx)
+  (parameterize ([current-orig-stx stx])        
+    (syntax-parse stx #:literals (t:List)
+      [((~and kw t:List) tys ... dty :ddd/bound)
+       (add-type-name-reference #'kw)
+       (let ([var (syntax-e #'bound)])
+         (unless (bound-index? var)
+           (if (bound-tvar? var)
+               (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." var)
+               (tc-error/stx #'bound "Type variable ~a is unbound" var)))
+         (-Tuple* (map parse-type (syntax->list #'(tys ...)))
+                  (make-ListDots
+                   (extend-tvars (list var)
+                     (parse-type #'dty))
+                   var)))]
+      [((~and kw t:List) tys ... dty _:ddd)
+       (add-type-name-reference #'kw)
+       (let ([var (infer-index stx)])
+         (-Tuple* (map parse-type (syntax->list #'(tys ...)))
+                    (make-ListDots
+                     (extend-tvars (list var)
+                       (parse-type #'dty))
+                     var)))]
+      [((~and kw t:List) tys ...) 
+       (add-type-name-reference #'kw)
+       (-Tuple (map parse-type (syntax->list #'(tys ...))))])))
+
 (define (parse-values-type stx)
   (parameterize ([current-orig-stx stx])        
     (syntax-parse stx #:literals (values t:All)
       [((~and kw values) tys ... dty :ddd/bound)
        (add-type-name-reference #'kw)
-       (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
-         (if (not (Dotted? var))
-             (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound))             
-             (make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
-                              (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) 
-                                                                        (list (make-DottedBoth (make-F (syntax-e #'bound))))
-                                                                        (current-tvars))])
-                                (parse-type #'dty))
-                              (syntax-e #'bound))))]
+       (let ([var (syntax-e #'bound)])
+         (unless (bound-index? var)
+           (if (bound-tvar? var)
+               (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." var)
+               (tc-error/stx #'bound "Type variable ~a is unbound" var)))         
+         (make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
+                          (extend-tvars (list var)
+                            (parse-type #'dty))
+                          var))]
       [((~and kw values) tys ... dty _:ddd)
        (add-type-name-reference #'kw)
-       (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))])
-         (when (null? bounds)
-           (tc-error/stx stx "No type variable bound with ... in scope for ... type"))
-         (unless (null? (cdr bounds))
-           (tc-error/stx stx "Cannot infer bound for ... type"))
-         (match-let ([(cons var (struct Dotted (t))) (car bounds)])
-           (make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
-                            (parameterize ([current-tvars (extend-env (list var) 
-                                                                      (list (make-DottedBoth t))
-                                                                      (current-tvars))])
+       (let ([var (infer-index stx)])
+         (make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
+                          (extend-tvars (list var)
                               (parse-type #'dty))
-                            var)))]
+                            var))]
       [((~and kw values) tys ...) 
        (add-type-name-reference #'kw)
        (-values (map parse-type (syntax->list #'(tys ...))))]
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index dd08d722..cef82b22 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -26,6 +26,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
                      [define-typed-struct/exec define-struct/exec:]))
 
 (require "../utils/utils.rkt"
+         racket/base
 	 (for-syntax 
           syntax/parse
 	  syntax/private/util
@@ -48,7 +49,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
          (except-in mzlib/contract ->)
          (only-in mzlib/contract [-> c->])
          mzlib/struct
-         "base-types-new.rkt"
+         "base-types.rkt"
          "base-types-extra.rkt")
 
 (define-for-syntax (ignore stx) (syntax-property stx 'typechecker:ignore #t))
@@ -296,31 +297,64 @@ This file defines two sorts of primitives. All of them are provided into any mod
                  (define-typed-struct-internal (vars ...)
                    #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))
 
-(define-syntax (define-typed-struct stx)
-  (define-syntax-class fld-spec
-    #:literals (:)
-    #:description "[field-name : type]"
-    (pattern [fld:id : ty]))
-  (define-syntax-class struct-name
-    #:description "struct name (with optional super-struct name)"
-    #:attributes (name super)
-    (pattern (name:id super:id))
-    (pattern name:id
-	     #:with super #f))
-  (syntax-parse stx
-    [(_ nm:struct-name (fs:fld-spec ...) . opts)
-     (let ([mutable (if (memq '#:mutable (syntax->datum #'opts))
-                        '(#:mutable)
-                        '())])
-       (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
-                                           'typechecker:ignore #t)]
-                     [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))]))
+(define-syntaxes (define-typed-struct struct:)
+  (let ()
+    (define-syntax-class fld-spec
+      #:literals (:)
+      #:description "[field-name : type]"
+      (pattern [fld:id : ty]))
+    (define-syntax-class struct-name
+      #:description "struct name (with optional super-struct name)"
+      #:attributes (name super)
+      (pattern (name:id super:id))
+      (pattern name:id
+               #:with super #f))    
+    (define-splicing-syntax-class struct-name/new
+      #:description "struct name (with optional super-struct name)"
+      (pattern (~seq name:id super:id)
+               #:attr old-spec #'(name super)
+               #:with new-spec #'(name super))
+      (pattern name:id
+               #:with super #f
+               #:attr old-spec #'name
+               #:with new-spec #'(name)))
+    (define (mutable? opts) 
+      (if (memq '#:mutable (syntax->datum opts)) '(#:mutable) '()))
+    (values     
+     (lambda (stx)
+       (syntax-parse stx
+         [(_ nm:struct-name (fs:fld-spec ...) . opts)
+          (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* () 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))]))
+     (lambda (stx)
+       (syntax-parse stx
+         [(_ nm:struct-name/new (fs:fld-spec ...) . opts)
+          (let ([mutable (mutable? #'opts)]
+                [cname (datum->syntax #f (syntax-e #'nm.name))])
+            (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* () 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))])
+            (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))])
+              #'(begin d-s dtsi)))])))))
 
 (define-syntax (require-typed-struct stx)
   (syntax-parse stx #:literals (:)
@@ -347,8 +381,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ (nm parent) ([fld : ty] ...) lib)
      (and (identifier? #'nm) (identifier? #'parent))
      (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
-                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
-                    #;[(parent-tys ...) (Struct-flds (parse-type #'parent))])
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
                    #`(begin
                        (require (only-in lib struct-info))
                        (define-syntax nm (make-struct-info 
@@ -392,10 +425,13 @@ This file defines two sorts of primitives. All of them are provided into any mod
        (let loop ((clauses #'clauses))
          (define-syntax-class for-clause
            ;; single-valued seq-expr
+           ;; unlike the definitions in for-clauses.rkt, this does not include
+           ;; #:when clauses, which are handled separately here
            (pattern (var:annotated-name seq-expr:expr)
                     #:with expand #'(var.ann-name seq-expr))
            ;; multi-valued seq-expr
-           (pattern ((v:annotated-name ...) seq-expr:expr)
+           ;; currently disabled because it triggers an internal error in the typechecker
+           #;(pattern ((v:annotated-name ...) seq-expr:expr)
                     #:with expand #'((v.ann-name ...) seq-expr)))
          (syntax-parse clauses
            [(head:for-clause next:for-clause ... #:when rest ...)
@@ -476,10 +512,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
       (quasisyntax/loc stx
         (for/lists (var.ann-name ...)
           (clause.expand ... ...)
-          #,@(syntax-property
-              #'(c ...)
-              'type-ascription
-              #'ty)))
+          c ...))
       'type-ascription
       #'ty)]))
 (define-syntax (for/fold: stx)
@@ -492,10 +525,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
       (quasisyntax/loc stx
         (for/fold ((var.ann-name init) ...)
           (clause.expand ... ...)
-          #,@(syntax-property
-              #'(c ...)
-              'type-ascription
-              #'ty)))
+          c ...))
       'type-ascription
       #'ty)]))
 
diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-scheme/private/type-annotation.rkt
index 7109f5dd..75c4db9a 100644
--- a/collects/typed-scheme/private/type-annotation.rkt
+++ b/collects/typed-scheme/private/type-annotation.rkt
@@ -3,7 +3,7 @@
 (require "../utils/utils.rkt" 
 	 (rep type-rep)
 	 (utils tc-utils)
-	 (env type-env)
+	 (env global-env)
          (except-in (types subtype union convenience resolve utils) -> ->*)
          (private parse-type)
          (only-in scheme/contract listof ->)
@@ -112,49 +112,41 @@
   (map (lambda (e) (get-type e #:default default)) stxs))
 
 ;; list[identifier] stx (stx -> tc-results?) (stx tc-results? -> tc-results?) -> tc-results?
+;; stxs : the identifiers, possibly with type annotations on them
+;; expr : the RHS expression
+;; tc-expr : a function like `tc-expr' from tc-expr-unit
+;; tc-expr/check : a function like `tc-expr/check' from tc-expr-unit
 (d/c (get-type/infer stxs expr tc-expr tc-expr/check)
   ((listof identifier?) syntax? (syntax? . -> . tc-results?) (syntax? tc-results? . -> . tc-results?) . -> . tc-results?)
   (match stxs
-    ['() 
-     (tc-expr/check expr (ret null))]
-    [(list stx)
-     (cond [(type-annotation stx #:infer #t)
-            => (lambda (ann)
-                 (tc-expr/check expr (ret ann)))]
-           [else (tc-expr expr)])]
     [(list stx ...)
      (let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))])
        (if (for/and ([a anns]) a)
-           (begin (tc-expr/check expr (ret anns)))
+           (tc-expr/check expr (ret anns))
            (let ([ty (tc-expr expr)])
              (match ty
-               [(tc-results: tys) 
+               [(tc-results: tys fs os) 
                 (if (not (= (length stxs) (length tys)))
                     (begin
                       (tc-error/delayed 
                                       "Expression should produce ~a values, but produces ~a values of types ~a"
                                       (length stxs) (length tys) (stringify tys))
                       (ret (map (lambda _ (Un)) stxs)))
-                    (ret 
-                     (for/list ([stx stxs] [ty tys] [a anns])
-                       (cond [a => (lambda (ann) (check-type stx ty ann) ann)]
-                             [else ty]))))]
-               [ty (tc-error/delayed 
-                    "Expression should produce ~a values, but produces one values of type ~a"
-                    (length stxs) ty)
-                   (ret (map (lambda _ (Un)) stxs))]))))]))
-
+                    (combine-results 
+                     (for/list ([stx stxs] [ty tys] [a anns] [f fs] [o os])
+                       (cond [a (check-type stx ty a) (ret a f o)]
+			     ;; mutated variables get generalized, so that we don't infer too small a type
+			     [(is-var-mutated? stx) (ret (generalize ty) f o)]
+                             [else (ret ty f o)]))))]))))]))
 
 ;; check that e-type is compatible with ty in context of stx
 ;; otherwise, error
 ;; syntax type type -> void
-
 (define (check-type stx e-type ty)
-  (let ([stx* (current-orig-stx)])
-    (parameterize ([current-orig-stx stx])
-      (unless (subtype e-type ty)
-        ;(printf "orig-stx: ~a" (syntax->datum stx*))
-        (tc-error "Body had type:~n~a~nVariable had type:~n~a~n" e-type ty)))))
+  (parameterize ([current-orig-stx stx])
+    (unless (subtype e-type ty)
+      ;(printf "orig-stx: ~a" (syntax->datum stx*))
+      (tc-error "Body had type:~n~a~nVariable had type:~n~a~n" e-type ty))))
 
 (define (dotted? stx)
   (cond [(syntax-property stx type-dotted-symbol) => syntax-e]
diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt
index a8f395b5..4d8d6bf8 100644
--- a/collects/typed-scheme/private/type-contract.rkt
+++ b/collects/typed-scheme/private/type-contract.rkt
@@ -30,7 +30,7 @@
   (syntax-parse stx #:literals (define-values)
     [(define-values (n) _)
      (let ([typ (if maker?
-                    ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
+                    ((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
                     typ)])
        (with-syntax ([cnt (type->contract 
                            typ 
@@ -64,7 +64,7 @@
           [(Function: arrs)
            (when flat? (exit (fail)))
            (let ()           
-             (define (f a)
+             (define ((f [case-> #f]) a)
                (define-values (dom* opt-dom* rngs* rst)
                  (match a
                    ;; functions with no filters or objects
@@ -91,16 +91,21 @@
                             [(list r) r]
                             [_ #`(values #,@rngs*)])]
                     [rst* rst])
-                 (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
-                     #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*)
-                     #'(dom* ... . -> . rng*))))
+		 ;; Garr, I hate case->!
+		 (if (and (pair? (syntax-e #'(opt-dom* ...))) case->)
+		     (exit (fail))
+		     (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
+			 (if case->
+			     #'(dom* ... #:rest (listof rst*) . -> . rng*)
+			     #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*))
+			 #'(dom* ... . -> . rng*)))))
              (unless (no-duplicates (for/list ([t arrs])
                                       (match t
                                         [(arr: dom _ _ _ _) (length dom)]
                                         ;; is there something more sensible here?
                                         [(top-arr:) (int-err "got top-arr")])))
                (exit (fail)))
-             (match (map f arrs)
+             (match (map (f (not (= 1 (length arrs)))) arrs)
                [(list e) e]
                [l #`(case-> #,@l)]))]
           [_ (int-err "not a function" f)]))
@@ -160,7 +165,7 @@
            #;#'class?           
            #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
         [(Value: '()) #'null?]
-        [(Struct: nm par flds proc poly? pred? cert acc-ids maker-id)
+        [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id)
          (cond 
            [(assf (λ (t) (type-equal? t ty)) structs-seen)
             =>
diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt
index 8af94fdf..601bdb38 100644
--- a/collects/typed-scheme/private/with-types.rkt
+++ b/collects/typed-scheme/private/with-types.rkt
@@ -1,63 +1,58 @@
-#lang scheme/base
+#lang racket/base
 
-(require (for-syntax scheme/base syntax/parse mzlib/etc scheme/match)
-         scheme/require 
-         "base-env.rkt" 
-	 "base-special-env.rkt"
-	 "base-env-numeric.rkt"
-	 "base-env-indexing.rkt"
-	 "extra-procs.rkt"
-         "prims.rkt"
-         racket/contract/regions racket/contract/base
+(require racket/require racket/contract/regions racket/contract/base
+         "base-env.rkt" "base-special-env.rkt" "base-env-numeric.rkt"
+	 "base-env-indexing.rkt" "extra-procs.rkt" "prims.rkt"         
          (for-syntax 
-          "base-types-extra.rkt"
-          unstable/debug
-          (path-up "env/type-name-env.rkt"
-                   "env/type-alias-env.rkt"
-                   "infer/infer-dummy.rkt"
-                   "private/parse-type.rkt"
-                   "private/type-contract.rkt"
-                   "typecheck/typechecker.rkt"
-                   "env/type-environments.rkt" 
-                   "env/type-env.rkt"
-                   "infer/infer.rkt"
-                   "utils/tc-utils.rkt"
-                   "types/utils.rkt")
-          (except-in (path-up "utils/utils.rkt" "types/convenience.rkt" "types/abbrev.rkt") infer ->)))
+          scheme/base syntax/parse racket/block racket/match
+          unstable/sequence unstable/debug "base-types-extra.rkt"
+         (except-in (path-up "env/type-name-env.rkt"
+                             "env/type-alias-env.rkt"
+                             "infer/infer-dummy.rkt"
+                             "private/parse-type.rkt"
+                             "private/type-contract.rkt"
+                             "typecheck/typechecker.rkt"
+                             "env/type-env-structs.rkt" 
+                             "env/global-env.rkt"
+                             "env/tvar-env.rkt"
+                             "infer/infer.rkt"
+                             "utils/tc-utils.rkt"
+                             "types/utils.rkt"
+                             "types/convenience.rkt"
+                             "types/abbrev.rkt")
+                    ->)
+         (except-in (path-up "utils/utils.rkt") infer)))
 
 (provide with-type)
 
 (define-for-syntax (with-type-helper stx body fvids fvtys exids extys resty expr? ctx)
-  (begin-with-definitions
+  (block
     (define old-context (unbox typed-context?))
+    (define ((no-contract t [stx stx]))
+      (tc-error/stx stx "Type ~a could not be converted to a contract." t))
     (set-box! typed-context? #t)
     (define fv-types (for/list ([t (in-list (syntax->list fvtys))])
                        (parse-type t)))
     (define fv-cnts (for/list ([t (in-list fv-types)]
                                [stx (in-list (syntax->list fvtys))])
-                      (type->contract t #:typed-side #f 
-                                      (lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t)))))
+                      (type->contract t #:typed-side #f (no-contract t))))
     (define ex-types (for/list ([t (syntax->list extys)])
                        (parse-type t)))
     (define ex-cnts (for/list ([t (in-list ex-types)]
                                [stx (in-list (syntax->list extys))])
-                      (type->contract t #:typed-side #t
-                                      (lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t)))))
+                      (type->contract t #:typed-side #t (no-contract t))))
     (define region-tc-result 
       (and expr? (parse-tc-results resty)))
     (define region-cnts 
       (if region-tc-result
           (match region-tc-result 
             [(tc-result1: t)
-             (list (type->contract 
-                    t 
-                    #:typed-side #t
-                    (lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t))))]
+             (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))]
             [(tc-results: ts)
              (for/list ([t (in-list ts)])
                (type->contract
                 t #:typed-side #t
-                (lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t))))])
+                (no-contract t #'region-ty-stx)))])
           null))
     (for ([i (in-list (syntax->list fvids))]
           [ty (in-list fv-types)])
@@ -76,8 +71,6 @@
                    [infer-param infer]
                    ;; do we report multiple errors
                    [delay-errors? #t]
-                   ;; this parameter is for parsing types
-                   [current-tvars initial-tvar-env]
                    ;; this parameter is just for printing types
                    ;; this is a parameter to avoid dependency issues
                    [current-type-names
@@ -91,10 +84,8 @@
                    [type-name-references null]
                    ;; for error reporting
                    [orig-module-stx stx]
-                   [expanded-module-stx expanded-body])
-      (if expr?
-          (tc-expr/check expanded-body region-tc-result)
-          (tc-expr/check expanded-body (ret ex-types))))
+                   [expanded-module-stx expanded-body])     
+          (tc-expr/check expanded-body (if expr? region-tc-result (ret ex-types))))
     (report-all-errors)
     (set-box! typed-context? old-context)
     ;; then clear the new entries from the env ht
diff --git a/collects/typed-scheme/rep/filter-rep.rkt b/collects/typed-scheme/rep/filter-rep.rkt
index 0040f414..1fbd6952 100644
--- a/collects/typed-scheme/rep/filter-rep.rkt
+++ b/collects/typed-scheme/rep/filter-rep.rkt
@@ -3,11 +3,9 @@
 (require scheme/match scheme/contract)
 (require "rep-utils.rkt" "free-variance.rkt")
 
-(define Filter/c
-  (flat-named-contract
-   'Filter
-   (λ (e)
-     (and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e))))))
+(define (Filter/c-predicate? e)
+  (and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e))))
+(define Filter/c (flat-named-contract 'Filter Filter/c-predicate?))
 
 (define FilterSet/c
   (flat-named-contract
@@ -48,17 +46,16 @@
              (combine-frees (map free-idxs* fs))])
 
 (df FilterSet (thn els)
-    [#:contract (->d ([t (cond [(Bot? t)
-                                Bot?]
-                               [(Bot? e)
-                                Top?]
-                               [else Filter/c])]
-                      [e (cond [(Bot? e)
-                                Bot?]
-                               [(Bot? t)
-                                Top?]
-                               [else Filter/c])])
+    [#:contract (->d ([t any/c]
+                      [e any/c])
                      (#:syntax [stx #f])
+                     #:pre-cond
+                     (and (cond [(Bot? t) #t]
+                                [(Bot? e) (Top? t)]
+                                [else (Filter/c-predicate? t)])
+                          (cond [(Bot? e) #t]
+                                [(Bot? t) (Top? e)]
+                                [else (Filter/c-predicate? e)]))
                      [result FilterSet?])]
     [#:fold-rhs (*FilterSet (filter-rec-id thn) (filter-rec-id els))])
 
diff --git a/collects/typed-scheme/rep/free-variance.rkt b/collects/typed-scheme/rep/free-variance.rkt
index 41fc238c..db8f0e63 100644
--- a/collects/typed-scheme/rep/free-variance.rkt
+++ b/collects/typed-scheme/rep/free-variance.rkt
@@ -5,33 +5,30 @@
          mzlib/etc scheme/contract)
 
 (provide Covariant Contravariant Invariant Constant Dotted
-         combine-frees flip-variances without-below unless-in-table empty-hash-table
-         fix-bound make-invariant variance?)
+         combine-frees flip-variances without-below unless-in-table
+         fix-bound make-invariant make-constant variance?)
 
 ;; this file contains support for calculating the free variables/indexes of types
 ;; actual computation is done in rep-utils.rkt  and type-rep.rkt
 (define-values (Covariant Contravariant Invariant Constant Dotted)
   (let ()
-    (define-struct Variance () #:inspector #f)
-    (define-struct (Covariant Variance) () #:inspector #f)
-    (define-struct (Contravariant Variance) () #:inspector #f)
-    (define-struct (Invariant Variance) () #:inspector #f)
-    (define-struct (Constant Variance) () #:inspector #f)
+    (define-struct Variance () #:transparent)
+    (define-struct (Covariant Variance) () #:transparent)
+    (define-struct (Contravariant Variance) () #:transparent)
+    (define-struct (Invariant Variance) () #:transparent)
+    (define-struct (Constant Variance) () #:transparent)
     ;; not really a variance, but is disjoint with the others
-    (define-struct (Dotted Variance) () #:inspector #f)
+    (define-struct (Dotted Variance) () #:transparent)
     (values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
 
 
 (define (variance? e)
   (memq e (list Covariant Contravariant Invariant Constant Dotted)))
 
-(define empty-hash-table (make-immutable-hasheq null))
-
 ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
 ;; (listof frees) -> frees
 (define (combine-frees freess)    
-  (define ht (make-hasheq))
-  (define (combine-var v w)
+  (define ((combine-var v) w)
     (cond
       [(eq? v w) v]
       [(eq? v Dotted) w]
@@ -39,50 +36,39 @@
       [(eq? v Constant) w]
       [(eq? w Constant) v]
       [else Invariant]))
-  (for* ([old-ht (in-list freess)]
-         [(sym var) (in-hash old-ht)])
-        (let* ([sym-var (hash-ref ht sym (lambda () #f))])
-          (if sym-var
-              (hash-set! ht sym (combine-var var sym-var))
-              (hash-set! ht sym var))))
-  ht)
+  (for*/fold ([ht #hasheq()])
+    ([old-ht (in-list freess)]
+     [(sym var) (in-hash old-ht)])
+    (hash-update ht sym (combine-var var) var)))
 
 ;; given a set of free variables, change bound to ...
 ;; (if bound wasn't free, this will add it as Dotted
 ;;  appropriately so that things that expect to see
 ;;  it as "free" will -- fixes the case where the
 ;;  dotted pre-type base doesn't use the bound).
-(define (fix-bound vs bound)
-  (define vs* (hash-map* (lambda (k v) v) vs))
-  (hash-set! vs* bound Dotted)
-  vs*)
+(define (fix-bound vs bound)  
+  (hash-set vs bound Dotted))
 
 ;; frees -> frees
 (define (flip-variances vs)
-  (hash-map* 
-   (lambda (k v) 
-     (evcase v
-       [Covariant Contravariant]
-       [Contravariant Covariant]
-       [v v]))
-   vs))
+  (for/hasheq ([(k v) (in-hash vs)])
+    (values k (evcase v
+                [Covariant Contravariant]
+                [Contravariant Covariant]
+                [v v]))))
 
 (define (make-invariant vs)
-  (hash-map* 
-   (lambda (k v) Invariant)
-   vs))
+  (for/hasheq ([(k v) (in-hash vs)])
+    (values k Invariant)))
 
-(define (hash-map* f ht)
-  (define new-ht (make-hasheq))
-  (for ([(k v) (in-hash ht)])
-     (hash-set! new-ht k (f k v)))
-  new-ht)
+(define (make-constant vs)
+  (for/hasheq ([(k v) (in-hash vs)])
+    (values k Constant)))
 
 (define (without-below n frees)
-  (define new-ht (make-hasheq))
-  (for ([(k v) (in-hash frees)])
-       (when (>= k n) (hash-set! new-ht k v)))
-  new-ht)
+  (for/hasheq ([(k v) (in-hash frees)]
+               #:when (>= k n))
+    (values k v)))
 
 (define-syntax (unless-in-table stx) 
   (syntax-case stx ()
diff --git a/collects/typed-scheme/rep/object-rep.rkt b/collects/typed-scheme/rep/object-rep.rkt
index e36c3a5a..3608a0e9 100644
--- a/collects/typed-scheme/rep/object-rep.rkt
+++ b/collects/typed-scheme/rep/object-rep.rkt
@@ -6,6 +6,7 @@
 (dpe CarPE () [#:fold-rhs #:base])
 (dpe CdrPE () [#:fold-rhs #:base])
 (dpe SyntaxPE () [#:fold-rhs #:base])
+;; t is always a Name (can't put that into the contract b/c of circularity)
 (dpe StructPE ([t Type?] [idx natural-number/c])     
     [#:frees (free-vars* t) (free-idxs* t)]
     [#:fold-rhs (*StructPE (type-rec-id t) idx)])
diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt
index ade55c9f..a52d800e 100644
--- a/collects/typed-scheme/rep/rep-utils.rkt
+++ b/collects/typed-scheme/rep/rep-utils.rkt
@@ -6,7 +6,7 @@
          syntax/boundmap
          "free-variance.rkt"
          "interning.rkt"
-	 unstable/syntax unstable/match
+	 unstable/syntax unstable/match unstable/struct
          mzlib/etc
          scheme/contract         
          (for-syntax 
@@ -47,7 +47,7 @@
   
   (define (combiner f flds)
     (syntax-parse flds
-      [() #'empty-hash-table]
+      [() #'#hasheq()]
       [(e) #`(#,f e)]
       [(e ...) #`(combine-frees (list (#,f e) ...))]))
   (define-splicing-syntax-class frees-pat
@@ -55,8 +55,8 @@
     #:attributes (f1 f2)
     (pattern (~seq f1:expr f2:expr))
     (pattern #f
-             #:with f1 #'empty-hash-table
-             #:with f2 #'empty-hash-table)
+             #:with f1 #'#hasheq()
+             #:with f2 #'#hasheq())
     (pattern e:expr
              #:with f1 #'(e Rep-free-vars)
              #:with f2 #'(e Rep-free-idxs)))
@@ -130,7 +130,7 @@
                      #,(quasisyntax/loc #'nm
                          (defintern (nm.*maker . flds.fs) flds.maker intern?
                            #:extra-args
-                           frees.f1 frees.f2 #:syntax [orig-stx #f] 
+                           frees.f1 frees.f2 #:syntax [orig-stx #f]
                            #,@(if key? (list #'key-expr) null)))))
             provides))])))
 
@@ -247,22 +247,16 @@
                                [Rep-free-idxs free-idxs*]))
 
 (p/c (struct Rep ([seq exact-nonnegative-integer?] 
-                  [free-vars (hash/c symbol? variance?)] 
-                  [free-idxs (hash/c exact-nonnegative-integer? variance?)]
+                  [free-vars (hash/c symbol? variance?)]                   
+                  [free-idxs (hash/c symbol? variance?)]
                   [stx (or/c #f syntax?)]))
      [replace-syntax (Rep? syntax? . -> . Rep?)])
 
-
-(define (list-update l k v)
-  (if (zero? k)
-      (cons v (cdr l))
-      (cons (car l) (list-update (cdr l) (sub1 k) v))))
-
 (define (replace-field val new-val idx)
   (define-values (type skipped) (struct-info val))
   (define maker (struct-type-make-constructor type))
-  (define flds (cdr (vector->list (struct->vector val))))
-  (apply maker (list-update flds idx new-val)))
+  (define flds (struct->list val))
+  (apply maker (list-set flds idx new-val)))
 
 (define (replace-syntax rep stx)
   (replace-field rep stx 3))
diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt
index 4a076230..f942dc8b 100644
--- a/collects/typed-scheme/rep/type-rep.rkt
+++ b/collects/typed-scheme/rep/type-rep.rkt
@@ -3,7 +3,7 @@
 
 (require (utils tc-utils) 
 	 "rep-utils.rkt" "object-rep.rkt" "filter-rep.rkt" "free-variance.rkt"
-         mzlib/trace scheme/match
+         mzlib/trace scheme/match mzlib/etc
          scheme/contract unstable/debug
          (for-syntax scheme/base syntax/parse))
 
@@ -14,12 +14,12 @@
      (and (Type? e)
           (not (Scope? e))
           (not (arr? e))
+          (not (fld? e))
           (not (Values? e))
           (not (ValuesDots? e))
           (not (Result? e)))))
 
-(define Type/c
-  (flat-named-contract 'Type Type/c?))
+(define Type/c (flat-named-contract 'Type Type/c?))
 
 ;; Name = Symbol
 
@@ -41,13 +41,14 @@
 ;; this is ONLY used when a type error ocurrs
 (dt Error () [#:frees #f] [#:fold-rhs #:base])
 
+;; de Bruijn indexes - should never appear outside of this file
+;; bound type variables
 ;; i is an nat
-(dt B ([i natural-number/c])
-    [#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))]
-    [#:fold-rhs #:base])
+(dt B ([i natural-number/c]) [#:frees #f] [#:fold-rhs #:base])
 
+;; free type variables
 ;; n is a Name
-(dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base])
+(dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) #hasheq()] [#:fold-rhs #:base])
 
 ;; id is an Identifier
 (dt Name ([id identifier?]) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base])
@@ -57,37 +58,81 @@
 ;; stx is the syntax of the pair of parens
 (dt App ([rator Type/c] [rands (listof Type/c)] [stx (or/c #f syntax?)])
     [#:intern (list rator rands)]
-    [#:frees (combine-frees (map free-vars* (cons rator rands)))
-             (combine-frees (map free-idxs* (cons rator rands)))]
+    [#:frees (λ (f) (combine-frees (map f (cons rator rands))))]
     [#:fold-rhs (*App (type-rec-id rator)
                       (map type-rec-id rands)
                       stx)])
 
+(define (get-variances t num-rands)
+  (match t
+    [(Name: v) (error 'fail)]
+    [(Poly: n scope)
+     (let ([t (free-idxs* scope)])
+       (for/list ([i (in-range n)])
+         (hash-ref t i)))]
+    [(PolyDots: n scope)
+     (let ([t (free-idxs* scope)]
+           [base-count (sub1 n)]
+           [extras (max 0 (- n num-rands))])
+       (append 
+        ;; variances of the fixed arguments
+        (for/list ([i (in-range base-count)])
+          (hash-ref t i))
+        ;; variance of the dotted arguments
+        (for/list ([i (in-range extras)])
+          (hash-ref t n))))]))
+
+(define (apply-variance v tbl)
+  (evcase v
+    [(Constant) (make-constant tbl)]
+    [(Covariant) tbl]
+    [(Invariant) (make-invariant tbl)]
+    [(Contravariant) (flip-variances tbl)]))
+
 ;; left and right are Types
 (dt Pair ([left Type/c] [right Type/c]) [#:key 'pair])
 
+;; dotted list -- after expansion, becomes normal Pair-based list type
+(dt ListDots ([dty Type/c] [dbound (or/c symbol? natural-number/c)])
+    [#:frees (if (symbol? dbound)
+                 (hash-remove (free-vars* dty) dbound)
+                 (free-vars* dty))
+             (if (symbol? dbound)
+                 (combine-frees (list (make-immutable-hasheq (list (cons dbound Covariant))) (free-idxs* dty)))
+                 (free-idxs* dty))]
+    [#:fold-rhs (*ListDots (type-rec-id dty) dbound)])
+
 ;; *mutable* pairs - distinct from regular pairs
 ;; left and right are Types
-(dt MPair ([left Type/c] [right Type/c]) [#:key 'mpair])
+(dt MPair ([left Type/c] [right Type/c])     
+    [#:frees (λ (f) (make-invariant (combine-frees (list (f left) (f right)))))]
+    [#:key 'mpair])
 
 
 ;; elem is a Type
 (dt Vector ([elem Type/c]) 
-    [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
+    [#:frees (λ (f) (make-invariant (f elem)))]
     [#:key 'vector])
 
 ;; elems are all Types
 (dt HeterogenousVector ([elems (listof Type/c)])
-    [#:frees (make-invariant (combine-frees (map free-vars* elems))) (make-invariant (combine-frees (map free-idxs* elems)))]
+    [#:frees (λ (f) (make-invariant (combine-frees (map f elems))))]
     [#:key 'vector]
     [#:fold-rhs (*HeterogenousVector (map type-rec-id elems))])
 
 ;; elem is a Type
-(dt Box ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
+(dt Box ([elem Type/c]) 
+    [#:frees (λ (f) (make-invariant (f elem)))]
     [#:key 'box])  
 
+;; elem is a Type
+(dt Channel ([elem Type/c])
+    [#:frees (λ (f) (make-invariant (f elem)))]
+    [#:key 'channel])
+
 ;; name is a Symbol (not a Name)
-(dt Base ([name symbol?] [contract syntax?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name]
+(dt Base ([name symbol?] [contract syntax?]) 
+    [#:frees #f] [#:fold-rhs #:base] [#:intern name]
     [#:key (case name
 	     [(Number Integer) 'number]
 	     [(Boolean) 'boolean]
@@ -97,9 +142,9 @@
 	     [else #f])])
 
 ;; body is a Scope
-(dt Mu ([body (scope-depth 1)]) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]
+(dt Mu ([body (scope-depth 1)]) #:no-provide [#:frees (λ (f) (f body))]
     [#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))]
-    [#:key (Type-key body)])    
+    [#:key (Type-key body)])
 
 ;; n is how many variables are bound here
 ;; body is a Scope
@@ -108,7 +153,7 @@
                       [body (scope-depth n)])
                      (#:syntax [stx (or/c #f syntax?)])
                      [result Poly?])]
-    [#:frees (free-vars* body) (without-below n (free-idxs* body))]
+    [#:frees (λ (f) (f body))]
     [#:fold-rhs (let ([body* (remove-scopes n body)])
                   (*Poly n (add-scopes n (type-rec-id body*))))]
     [#:key (Type-key body)])
@@ -122,7 +167,7 @@
                      (#:syntax [stx (or/c #f syntax?)])
                      [result PolyDots?])]
     [#:key (Type-key body)]
-    [#:frees (free-vars* body) (without-below n (free-idxs* body))]
+    [#:frees (λ (f) (f body))]
     [#:fold-rhs (let ([body* (remove-scopes n body)])
                   (*PolyDots n (add-scopes n (type-rec-id body*))))])
 
@@ -148,7 +193,12 @@
     [#:fold-rhs (*Values (map type-rec-id rs))])
 
 (dt ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)])
-    [#:frees (λ (f) (combine-frees (map f (cons dty rs))))]
+    [#:frees (if (symbol? dbound)
+                 (hash-remove (combine-frees (map free-vars* (cons dty rs))) dbound)
+                 (combine-frees (map free-vars* (cons dty rs))))
+             (if (symbol? dbound)
+                 (combine-frees (cons (make-immutable-hasheq (list (cons dbound Covariant))) (map free-idxs* (cons dty rs))))
+                 (combine-frees (map free-idxs* (cons dty rs))))]
     [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)])
 
 ;; arr is NOT a Type
@@ -165,10 +215,10 @@
                                    dom))
                       (match drest
                         [(cons t (? symbol? bnd))
-                         (list (fix-bound (flip-variances (free-vars* t)) bnd))]                          
-                        [(cons t (? number? bnd)) 
+                         (list (hash-remove (flip-variances (free-vars* t)) bnd))]
+                        [(cons t _)
                          (list (flip-variances (free-vars* t)))]
-                        [#f null])
+                        [_ null])
                       (list (free-vars* rng))))
              (combine-frees 
               (append (map (compose flip-variances free-idxs*) 
@@ -177,10 +227,11 @@
                                    dom))
                       (match drest
                         [(cons t (? symbol? bnd))
+                         (list (make-immutable-hasheq (list (cons bnd Contravariant)))
+                               (flip-variances (free-idxs* t)))]
+                        [(cons t _)
                          (list (flip-variances (free-idxs* t)))]
-                        [(cons t (? number? bnd)) 
-                         (list (fix-bound (flip-variances (free-idxs* t)) bnd))]
-                        [#f null])
+                        [_ null])
                       (list (free-idxs* rng))))]
     [#:fold-rhs (*arr (map type-rec-id dom)
                       (type-rec-id rng)
@@ -196,48 +247,43 @@
 ;; arities : Listof[arr]
 (dt Function ([arities (listof arr/c)])
     [#:key 'procedure]
-    [#:frees (combine-frees (map free-vars* arities))
-             (combine-frees (map free-idxs* arities))]
+    [#:frees (λ (f) (combine-frees (map f arities)))]
     [#:fold-rhs (*Function (map type-rec-id arities))])
 
 
+(dt fld ([t Type/c] [acc identifier?] [mutable? boolean?])
+    [#:frees (λ (f) (if mutable? (make-invariant (f t)) (f t)))]
+    [#:fold-rhs (*fld (type-rec-id t) acc mutable?)]
+    [#:intern (list t (hash-id acc) mutable?)])
+
 ;; name : symbol
 ;; parent : Struct
-;; flds : Listof[Cons[Type,Bool]] type and mutability
+;; flds : Listof[fld]
 ;; proc : Function Type
 ;; poly? : is this a polymorphic type?
 ;; pred-id : identifier for the predicate of the struct
 ;; cert : syntax certifier for pred-id
-(dt Struct ([name symbol?] 
-            [parent (or/c #f Struct? Name?)] 
-            [flds (listof Type/c)]
-            #;
-            [flds (listof (cons/c Type/c boolean?))]
+;; acc-ids : names of the accessors
+;; maker-id : name of the constructor
+(dt Struct ([name symbol?]
+            [parent (or/c #f Struct? Name?)]
+            [flds (listof fld?)]
             [proc (or/c #f Function?)]
-            [poly? boolean?] 
+            [poly? (or/c #f (listof symbol?))]
             [pred-id identifier?]
             [cert procedure?]
-            [acc-ids (listof identifier?)]
             [maker-id identifier?])
     [#:intern (list name parent flds proc)]
-    [#:frees (combine-frees (map free-vars* (append (if proc (list proc) null)
-                                                    (if parent (list parent) null) 
-                                                    
-                                                    flds #;(map car flds))))
-             (combine-frees (map free-idxs* (append (if proc (list proc) null)
-                                                    (if parent (list parent) null)
-                                                    flds #;(map car flds))))]
+    [#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null)
+                                                           (if parent (list parent) null)                                                     
+                                                           flds))))]
     [#:fold-rhs (*Struct name 
                          (and parent (type-rec-id parent))
                          (map type-rec-id flds)
-                         #;
-                         (for/list ([(t m?) (in-pairs (in-list flds))])
-                           (cons (type-rec-id t) m?))
                          (and proc (type-rec-id proc))
                          poly?
                          pred-id
                          cert
-                         acc-ids
                          maker-id)]
     [#:key #f])
 
@@ -247,6 +293,7 @@
 
 ;; the supertype of all of these values
 (dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
+(dt ChannelTop () [#:fold-rhs #:base] [#:key 'channel])
 (dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])
 (dt HashtableTop () [#:fold-rhs #:base] [#:key 'hash])
 (dt MPairTop () [#:fold-rhs #:base] [#:key 'mpair])
@@ -270,8 +317,7 @@
                                                 (and sorted? (type<? last e))
                                                 e))])
                                  sorted?))))]) 
-    [#:frees (combine-frees (map free-vars* elems))
-             (combine-frees (map free-idxs* elems))]
+    [#:frees (λ (f) (combine-frees (map f elems)))]
     [#:fold-rhs ((get-union-maker) (map type-rec-id elems))]
     [#:key (let loop ([res null] [ts elems])
              (if (null? ts) res
@@ -297,8 +343,7 @@
     [#:key (Type-key parent)]
     [#:intern (list parent (hash-id pred))]
     [#:fold-rhs (*Refinement (type-rec-id parent) pred cert)]
-    [#:frees (free-vars* parent)
-             (free-idxs* parent)])
+    [#:frees (λ (f) (f parent))])
     
 
 ;; t : Type
@@ -310,14 +355,10 @@
 (dt Class ([pos-flds (listof Type/c)]
            [name-flds (listof (list/c symbol? Type/c boolean?))]
            [methods (listof (list/c symbol? Function?))])
-    [#:frees (combine-frees
-              (map free-vars* (append pos-flds 
-                                      (map cadr name-flds)
-                                      (map cadr methods))))
-             (combine-frees
-              (map free-idxs* (append pos-flds 
-                                      (map cadr name-flds)
-                                      (map cadr methods))))]
+    [#:frees (λ (f) (combine-frees
+                     (map f (append pos-flds 
+                                    (map cadr name-flds)
+                                    (map cadr methods)))))]
     [#:key 'class]
     [#:fold-rhs (match (list pos-flds name-flds methods)
                   [(list
@@ -335,6 +376,13 @@
 ;; cls : Class
 (dt Instance ([cls Type/c]) [#:key 'instance])
 
+;; sequences
+;; includes lists, vectors, etc
+;; tys : sequence produces this set of values at each step
+(dt Sequence ([tys (listof Type/c)])
+    [#:frees (λ (f) (combine-frees (map f tys)))]
+    [#:key #f] [#:fold-rhs (*Sequence (map type-rec-id tys))])
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; Ugly hack - should use units
@@ -430,6 +478,9 @@
               (*ValuesDots (map sb rs)
                            (sb dty)
                            (if (eq? dbound name) (+ count outer) dbound))]
+       [#:ListDots dty dbound
+                   (*ListDots (sb dty)
+                              (if (eq? dbound name) (+ count outer) dbound))]
        [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
        [#:PolyDots n body* 
                    (let ([body (remove-scopes n body*)])
@@ -478,6 +529,9 @@
                      (*ValuesDots (map sb rs)
                                   (sb dty)
                                   (if (eqv? dbound (+ count outer)) (F-n image) dbound))]
+       [#:ListDots dty dbound
+                   (*ListDots (sb dty)
+                              (if (eqv? dbound (+ count outer)) (F-n image) dbound))]
        [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
        [#:PolyDots n body* 
                    (let ([body (remove-scopes n body*)])
diff --git a/collects/typed-scheme/scribblings/begin.scrbl b/collects/typed-scheme/scribblings/begin.scrbl
index 697c1056..137b8e29 100644
--- a/collects/typed-scheme/scribblings/begin.scrbl
+++ b/collects/typed-scheme/scribblings/begin.scrbl
@@ -74,7 +74,7 @@ typed/racket
 (define-struct: leaf ([val : Number]))
 (define-struct: node ([left : Tree] [right : Tree]))
 
-(: tree-height (Tree -> Number))
+(: tree-height (Tree -> Integer))
 (define (tree-height t)
   (cond [(leaf? t) 1]
         [else (max (+ 1 (tree-height (node-left t)))
diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl
index e3ef9417..4e063ef2 100644
--- a/collects/typed-scheme/scribblings/ts-reference.scrbl
+++ b/collects/typed-scheme/scribblings/ts-reference.scrbl
@@ -8,6 +8,11 @@
 
 @(define the-eval (make-base-eval))
 @(the-eval '(require (except-in typed/racket #%top-interaction #%module-begin)))
+@(define the-top-eval (make-base-eval))
+@(the-top-eval '(require (except-in typed/racket #%module-begin)))
+
+@(define-syntax-rule (ex . args)
+   (examples #:eval the-top-eval . args))
 
 @title[#:tag "top"]{The Typed Racket Reference} 
 
@@ -18,15 +23,43 @@
 
 @section[#:tag "type-ref"]{Type Reference}
 
-@subsubsub*section{Base Types}
+@defidform[Any]{Any Racket value. All other types are subtypes of @racket[Any].}
+
+@defidform[Nothing]{The empty type.  No values inhabit this type, and
+any expression of this type will not evaluate to a value.}
+
+@subsection{Base Types}
+
+@subsubsection{Numeric Types}
 @deftogether[(
 @defidform[Number]
 @defidform[Complex]
+@defidform[Inexact-Complex]
 @defidform[Real]
+@defidform[Float]
+@defidform[Nonnegative-Float]
+@defidform[Exact-Rational]
 @defidform[Integer]
 @defidform[Natural]
-@defidform[Exact-Positive-Integer]
 @defidform[Exact-Nonnegative-Integer]
+@defidform[Exact-Positive-Integer]
+@defidform[Zero]
+)]{These types represent the hierarchy of @rtech{numbers} of Racket.
+@racket[Integer] includes only @rtech{integers} that are @rtech{exact
+numbers}, corresponding to the predicate @racket[exact-integer?]. 
+
+@ex[
+7
+8.3
+(/ 8 3)
+0
+-12
+3+4i]
+}
+
+@subsubsection{Other Base Types}
+
+@deftogether[(
 @defidform[Boolean]
 @defidform[True]
 @defidform[False]
@@ -39,42 +72,124 @@
 @defidform[Path]
 @defidform[Regexp]
 @defidform[PRegexp]
-@defidform[Syntax]
-@defidform[Identifier]
 @defidform[Bytes]
 @defidform[Namespace]
 @defidform[EOF]
 @defidform[Continuation-Mark-Set]
-@defidform[Char])]{
-These types represent primitive Racket data.  Note that @racket[Integer] represents exact integers.}
+@defidform[Char]
+@defidform[Thread])]{
+These types represent primitive Racket data.
 
-@defidform[Any]{Any Racket value. All other types are subtypes of @racket[Any].}
+@ex[
+#t
+#f
+"hello"
+(current-input-port)
+(current-output-port)
+(string->path "/")
+#rx"a*b*"
+#px"a*b*"
+'#"bytes"
+(current-namespace)
+#\b
+(thread (lambda () (add1 7)))
+]
+}
 
-@defidform[Nothing]{The empty type.  No values inhabit this type, and
-any expression of this type will not evaluate to a value.}
+@subsection{Singleton Types}
+
+Some kinds of data are given singleton types by default.  In
+particular, @rtech{symbols} and @rtech{keywords} have types which
+consist only of the particular symbol or keyword.  These types are
+subtypes of @racket[Symbol] and @racket[Keyword], respectively.
+
+@ex[
+'#:foo
+'bar
+]
+
+@subsection{Containers}
 
 
 The following base types are parameteric in their type arguments.
 
-@defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]}
-@defform[(Boxof t)]{A @rtech{box} of @racket[t]}
-@defform[(Syntaxof t)]{A @rtech{syntax object} containing a @racket[t]}
-@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]}
-@defform[(Option t)]{Either @racket[t] of @racket[#f]}
-@defform*[[(Parameter t)
-           (Parameter s t)]]{A @rtech{parameter} of @racket[t].  If two type arguments are supplied, 
-                               the first is the type the parameter accepts, and the second is the type returned.}
-@defform[(Pair s t)]{is the pair containing @racket[s] as the @racket[car]
+@defform[(Pair s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car]
   and @racket[t] as the @racket[cdr]}
-@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type
-   @racket[k] and value type @racket[v].}
 
-@subsubsub*section{Type Constructors}
+@ex[
+(cons 1 2)
+(cons 1 "one")
+]
+
+
+@defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]}
+@defform[(List t ...)]{is the type of the list with one element, in order, 
+  for each type provided to the @racket[List] type constructor.}
+@defform/none[(#,(racket List) t ... trest #,(racket ...) bound)]{is the type of a list with
+one element for each of the @racket[t]s, plus a sequence of elements
+corresponding to @racket[trest], where @racket[bound]
+  must be an identifier denoting a type variable bound with @racket[...].}
+
+@ex[
+(list 'a 'b 'c)
+(map symbol->string (list 'a 'b 'c))
+]
+
+@defform[(Boxof t)]{A @rtech{box} of @racket[t]}
+
+@ex[(box "hello world")]
+
+@deftogether[(
+ @defform[(Syntaxof t)] 
+ @defidform[Syntax]
+ @defidform[Identifier])]{A @rtech{syntax object} containing a
+ @racket[t]. @racket[Syntax] is the type of any object constructable
+ via @racket[datum->syntax].  @racket[Identifier] is @racket[(Syntaxof
+ Symbol)].
+
+@ex[#'here]
+
+}
+
+@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]}
+@defform[(Vector t ...)]{is the type of the list with one element, in order, 
+  for each type provided to the @racket[Vector] type constructor.}
+
+@ex[(vector 1 2 3)
+#(a b c)]
+
+@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type
+   @racket[k] and value type @racket[v].
+
+@ex[#hash((a . 1) (b . 2))]
+}
+
+@defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent.
+@ex[
+(ann (make-channel) (Channelof Symbol))
+]
+}
+
+@defform*[[(Parameterof t)
+           (Parameterof s t)]]{A @rtech{parameter} of @racket[t].  If two type arguments are supplied, 
+                                 the first is the type the parameter accepts, and the second is the type returned.
+@ex[current-input-port
+    current-directory]
+}
+                              
+@defform[(Promise t)]{A @rtech{promise} of @racket[t].
+ @ex[(delay 3)]}
+
+@defidform[Sexp]{A recursive union containing types traversed by
+@racket[datum->syntax]. Note that this is @emph{not} the type produced
+by @racket[read].} 
+
+@subsection{Other Type Constructors}
 
 @defform*[#:id -> #:literals (* ...)
 	       [(dom ... -> rng)
 	        (dom ... rest * -> rng)
-		(dom ... rest ... bound -> rng)
+		(dom ... rest #,(racket ...) bound -> rng)
                 (dom -> rng : pred)]]{is the type of functions from the (possibly-empty)
   sequence @racket[dom ...] to the @racket[rng] type.  The second form
   specifies a uniform rest argument of type @racket[rest], and the
@@ -83,22 +198,27 @@ The following base types are parameteric in their type arguments.
   second occurrence of @racket[...] is literal, and @racket[bound]
   must be an identifier denoting a type variable. In the fourth form, 
   there must be only one @racket[dom] and @racket[pred] is the type 
-  checked by the predicate.}
-@defform[(U t ...)]{is the union of the types @racket[t ...]}
+  checked by the predicate.
+  
+  @ex[(λ: ([x : Number]) x)
+      (λ: ([x : Number] . [y : String *]) (length y))
+      ormap
+      string?]}
+@defform[(U t ...)]{is the union of the types @racket[t ...].
+ @ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]}
 @defform[(case-lambda fun-ty ...)]{is a function that behaves like all of
   the @racket[fun-ty]s.  The @racket[fun-ty]s must all be function
   types constructed with @racket[->].}
 @defform/none[(t t1 t2 ...)]{is the instantiation of the parametric type
   @racket[t] at types @racket[t1 t2 ...]}
 @defform[(All (v ...) t)]{is a parameterization of type @racket[t], with
-  type variables @racket[v ...]}
-@defform[(List t ...)]{is the type of the list with one element, in order, 
-  for each type provided to the @racket[List] type constructor.}
-@defform[(Vector t ...)]{is the type of the list with one element, in order, 
-  for each type provided to the @racket[Vector] type constructor.}
+  type variables @racket[v ...].  If @racket[t] is a function type
+      constructed with @racket[->], the outer pair of parentheses
+      around the function type may be omitted.}
 @defform[(values t ...)]{is the type of a sequence of multiple values, with
 types @racket[t ...].  This can only appear as the return type of a
-function.}
+function.
+@ex[(values 1 2 3)]}
 @defform/none[v]{where @racket[v] is a number, boolean or string, is the singleton type containing only that value}
 @defform/none[(quote val)]{where @racket[val] is a Racket value, is the singleton type containing only that value}
 @defform/none[i]{where @racket[i] is an identifier can be a reference to a type
@@ -106,6 +226,11 @@ name or a type variable}
 @defform[(Rec n t)]{is a recursive type where @racket[n] is bound to the
 recursive type in the body @racket[t]}
 
+
+@subsection{Other Types}
+
+@defform[(Option t)]{Either @racket[t] of @racket[#f]}
+
 Other types cannot be written by the programmer, but are used
 internally and may appear in error messages.
 
@@ -115,6 +240,7 @@ types with the same printed representation.}
 @defform/none[<n>]{is the printed representation of a reference to the
 type variable @racket[n]}
 
+
 @section[#:tag "special-forms"]{Special Form Reference}
 
 Typed Racket provides a variety of special forms above and beyond
@@ -153,7 +279,8 @@ Type-annotated versions of
 
 @defform/subs[(lambda: formals . body)
 ([formals ([v : t] ...) 
-	  ([v : t] ... . [v : t])])]{
+	  ([v : t] ... . [v : t *])
+	  ([v : t] ... . [v : t ...])])]{
 A function of the formal arguments @racket[v], where each formal
 argument has the associated type.  If a rest argument is present, then
 it has type @racket[(Listof t)].}
@@ -246,14 +373,26 @@ types.  In most cases, use of @racket[:] is preferred to use of @racket[define:]
 
 @subsection{Structure Definitions}
 @defform/subs[
-(define-struct: maybe-type-vars name-spec ([f : t] ...))
+(struct: maybe-type-vars name-spec ([f : t] ...) options ...)
 ([maybe-type-vars code:blank (v ...)]
- [name-spec name (name parent)])]{
+ [name-spec name (code:line name parent)]
+ [options #:transparent #:mutable])]{
  Defines a @rtech{structure} with the name @racket[name], where the
- fields @racket[f] have types @racket[t].  When @racket[parent], the
+ fields @racket[f] have types @racket[t], similar to the behavior of @racket[struct].
+  When @racket[parent] is present, the
 structure is a substructure of @racket[parent].  When
 @racket[maybe-type-vars] is present, the structure is polymorphic in the type
- variables @racket[v].}
+ variables @racket[v].
+
+Options provided have the same meaning as for the @racket[struct] form.}
+
+
+@defform/subs[
+(define-struct: maybe-type-vars name-spec ([f : t] ...) options ...)
+([maybe-type-vars code:blank (v ...)]
+ [name-spec name (name parent)]
+ [options #:transparent #:mutable])]{Legacy version of @racket[struct:], 
+corresponding to @racket[define-struct].}
                                  
 @defform/subs[
 (define-struct/exec: name-spec ([f : t] ...) [e : proc-t])
@@ -379,18 +518,43 @@ Other libraries can be used with Typed Racket via
 (check-version)
 ]
 
+@section{Utilities}
+
+Typed Racket provides some additional utility functions to facilitate typed programming.
+
+@defproc*[
+([(assert [v (U #f A)]) A]
+ [(assert [v A] [p? (A -> Any : B)]) B])]{
+Verifies that the argument satisfies the constraint.  If no predicate
+is provided, simply checks that the value is not
+@racket[#f].  
+}
+
+@examples[#:eval the-top-eval
+(define: x : (U #f Number) (string->number "7"))
+x
+(assert x)
+(define: y : (U String Number) 0)
+y
+(assert y number?)
+(assert y boolean?)]
+
+
 @section{Typed Racket Syntax Without Type Checking}
 
-@defmodulelang[typed-scheme/no-check]
+@defmodulelang*[(typed/racket/no-check
+                 typed/racket/base/no-check)]
 
 On occasions where the Typed Racket syntax is useful, but actual
-typechecking is not desired, the @racketmodname[typed-scheme/no-check]
-language is useful.  It provides the same bindings and syntax as Typed
-Racket, but does no type checking.
+typechecking is not desired, the @racketmodname[typed/racket/no-check]
+and @racketmodname[typed/racket/base/no-check] languages are useful.
+They provide the same bindings and syntax as
+@racketmodname[typed/racket] and @racketmodname[typed/racket/base],
+but do no type checking.
 
 Examples:
 
-@racketmod[typed-scheme/no-check
+@racketmod[typed/racket/no-check
 (: x Number)
 (define x "not-a-number")]
 
diff --git a/collects/typed-scheme/scribblings/types.scrbl b/collects/typed-scheme/scribblings/types.scrbl
index 467bd742..1d020b11 100644
--- a/collects/typed-scheme/scribblings/types.scrbl
+++ b/collects/typed-scheme/scribblings/types.scrbl
@@ -94,7 +94,7 @@ to describe an infinite family of data.  For example, this is the type
 of binary trees of numbers.  
 
 @racketblock[
-(Rec BT (U Number (Pair BT BT)))]
+(define-type BinaryTree (Rec BT (U Number (Pair BT BT))))]
 
 The @racket[Rec] type constructor specifies that the type @racket[BT]
 refers to the whole binary tree type within the body of the
@@ -148,7 +148,7 @@ Typed Racket offers abstraction over types as well as values.
 
 @subsection{Polymorphic Data Structures}
 
-Virtually every Racket program uses lists and sexpressions.  Fortunately, Typed
+Virtually every Racket program uses lists and other collections.  Fortunately, Typed
 Racket can handle these as well.  A simple list processing program can be
 written like this:
 
diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt
new file mode 100644
index 00000000..e3288fe8
--- /dev/null
+++ b/collects/typed-scheme/tc-setup.rkt
@@ -0,0 +1,60 @@
+#lang racket/base
+
+(require (rename-in "utils/utils.rkt" [infer r:infer])
+         (except-in syntax/parse id)
+         unstable/mutated-vars
+         scheme/base
+         (private type-contract)
+         (types utils convenience)
+         (typecheck typechecker provide-handling tc-toplevel)
+         (env tvar-env type-name-env type-alias-env)
+         (r:infer infer)
+         (utils tc-utils)
+         (rep type-rep)
+         (except-in (utils utils) infer)
+         (only-in (r:infer infer-dummy) infer-param)
+         racket/match
+         (for-syntax racket/base)
+         (for-template racket/base))
+
+(provide tc-setup invis-kw)
+
+(define-syntax-class invis-kw
+  #:literals (define-values define-syntaxes #%require #%provide begin)
+  (pattern (~or define-values define-syntaxes #%require #%provide begin)))
+
+(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body)
+  (let ()
+    (set-box! typed-context? #t)
+    (start-timing (syntax-property stx 'enclosing-module-name))
+    (with-handlers
+        ([(lambda (e) (and #f (exn:fail? e) (not (exn:fail:syntax? e))))
+          (lambda (e) (tc-error "Internal Typed Racket Error : ~a" e))])
+      (parameterize (;; enable fancy printing?
+                     [custom-printer #t]
+                     ;; a cheat to avoid units
+                     [infer-param infer]
+                     ;; do we report multiple errors
+                     [delay-errors? #t]
+                     ;; do we print the fully-expanded syntax?
+                     [print-syntax? #f]
+                     ;; this parameter is just for printing types
+                     ;; this is a parameter to avoid dependency issues
+                     [current-type-names
+                      (lambda ()
+                        (append 
+                         (type-name-env-map (lambda (id ty)
+                                              (cons (syntax-e id) ty)))
+                         (type-alias-env-map (lambda (id ty)
+                                               (cons (syntax-e id) ty)))))]
+                     ;; reinitialize seen type variables
+                     [type-name-references null])
+        (do-time "Initialized Envs")
+        (let ([fully-expanded-stx (local-expand stx expand-ctxt null)])
+          (do-time "Local Expand Done")
+          (parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)]
+                         [orig-module-stx (or (orig-module-stx) orig-stx)]
+                         [expanded-module-stx fully-expanded-stx])
+            (let ([result (checker fully-expanded-stx)])
+              (do-time "Typechecking Done")
+              . body)))))))
diff --git a/collects/typed-scheme/typecheck/check-below.rkt b/collects/typed-scheme/typecheck/check-below.rkt
new file mode 100644
index 00000000..9f06b138
--- /dev/null
+++ b/collects/typed-scheme/typecheck/check-below.rkt
@@ -0,0 +1,102 @@
+#lang racket/base
+
+(require (rename-in "../utils/utils.rkt" [private private-in])
+         racket/match (prefix-in - racket/contract)
+         (types utils convenience union subtype remove-intersect type-table filter-ops)
+         (private-in parse-type type-annotation)
+         (rep type-rep)
+         (only-in (infer infer) restrict)
+         (except-in (utils tc-utils stxclass-util))
+         (env lexical-env type-env-structs tvar-env index-env)
+         (except-in syntax/parse id)
+         (only-in srfi/1 split-at))
+
+(p/c
+ [check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])])
+
+(define (print-object o)
+  (match o
+    [(Empty:) "no object"]
+    [_ (format "object ~a" o)]))
+
+;; check-below : (/\ (Results Type -> Result)
+;;                   (Results Results -> Result)
+;;                   (Type Results -> Type)
+;;                   (Type Type -> Type))
+(define (check-below tr1 expected)     
+  (define (filter-better? f1 f2)
+    (match* (f1 f2)
+      [(f f) #t]
+      [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-))
+       (and (implied-atomic? f2+ f1+)
+            (implied-atomic? f2- f1-))]
+      [(_ _) #f]))
+  (define (object-better? o1 o2)
+    (match* (o1 o2)
+      [(o o) #t]
+      [(o (or (NoObject:) (Empty:))) #t]
+      [(_ _) #f]))  
+  (match* (tr1 expected)
+    ;; these two have to be first so that errors can be allowed in cases where multiple values are expected
+    [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) (tc-results: ts2 (NoFilter:) (NoObject:)))
+     (ret ts2)]
+    [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _)
+     expected]
+    
+    [((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:)))
+     (unless (= (length ts) (length ts2))
+       (tc-error/expr "Expected ~a values, but got ~a" (length ts2) (length ts)))
+     (unless (for/and ([t ts] [s ts2]) (subtype t s))
+       (tc-error/expr "Expected ~a, but got ~a" (stringify ts2) (stringify ts)))
+     (if (= (length ts) (length ts2))
+         (ret ts2 fs os)
+         (ret ts2))]
+    [((tc-result1: t1 f1 o1) (tc-result1: t2 (FilterSet: (Top:) (Top:)) (Empty:)))
+     (cond 
+       [(not (subtype t1 t2))
+        (tc-error/expr "Expected ~a, but got ~a" t2 t1)])
+     expected]
+    [((tc-result1: t1 f1 o1) (tc-result1: t2 f2 o2))
+     (cond 
+       [(not (subtype t1 t2))
+        (tc-error/expr "Expected ~a, but got ~a" t2 t1)]
+       [(and (not (filter-better? f1 f2))
+             (object-better? o1 o2))
+        (tc-error/expr "Expected result with filter ~a, got filter ~a" f2 f1)]
+       [(and (filter-better? f1 f2)
+             (not (object-better? o1 o2)))
+        (tc-error/expr "Expected result with object ~a, got object ~a" o2 o1)]
+       [(and (not (filter-better? f1 f2))
+             (not (object-better? o1 o2)))
+        (tc-error/expr "Expected result with filter ~a and ~a, got filter ~a and ~a" f2 (print-object o2) f1 (print-object o1))])
+     expected]
+    [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound))
+     (unless (andmap subtype t1 t2)
+       (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
+     expected]
+    [((tc-results: t1 fs os) (tc-results: t2 fs os))
+     (unless (= (length t1) (length t2))
+       (tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1)))
+     (unless (for/and ([t t1] [s t2]) (subtype t s))
+       (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
+     expected]
+    [((tc-result1: t1 f o) (? Type? t2))
+     (unless (subtype t1 t2)
+       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
+     (ret t2 f o)]
+    [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:)))
+     (unless (subtype t1 t2)
+       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
+     t1]
+    [((? Type? t1) (tc-result1: t2 f o))
+     (if (subtype t1 t2)
+         (tc-error/expr "Expected result with filter ~a and ~a, got ~a" f (print-object o) t1)
+         (tc-error/expr "Expected ~a, but got ~a" t2 t1))
+     t1]
+    [((? Type? t1) (? Type? t2))
+     (unless (subtype t1 t2)
+       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
+     expected]
+    [((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*))
+     (int-err "dotted types in check-below nyi: ~a ~a" dty dty*)]
+    [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)]))
diff --git a/collects/typed-scheme/typecheck/def-export.rkt b/collects/typed-scheme/typecheck/def-export.rkt
new file mode 100644
index 00000000..acf624d6
--- /dev/null
+++ b/collects/typed-scheme/typecheck/def-export.rkt
@@ -0,0 +1,27 @@
+#lang racket/base
+
+(require racket/require
+         (for-syntax syntax/parse racket/base 
+                     (path-up "utils/tc-utils.rkt" "private/typed-renaming.rkt" "env/type-name-env.rkt")))
+(provide def-export)
+
+
+(define-for-syntax (renamer id #:alt [alt #f])
+  (if alt
+      (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
+      (make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
+
+(define-syntax (def-export stx)
+  (syntax-parse stx
+    [(def-export export-id:identifier id:identifier cnt-id:identifier)
+     #'(define-syntax export-id
+         (if (unbox typed-context?)
+             (renamer #'id #:alt #'cnt-id)
+             (renamer #'cnt-id)))]
+    [(def-export export-id:identifier id:identifier cnt-id:identifier #:alias)
+     #'(define-syntax export-id
+         (if (unbox typed-context?)
+             (begin                           
+               (add-alias #'export-id #'id)
+               (renamer #'id #:alt #'cnt-id))
+             (renamer #'cnt-id)))]))
\ No newline at end of file
diff --git a/collects/typed-scheme/typecheck/find-annotation.rkt b/collects/typed-scheme/typecheck/find-annotation.rkt
index ceb9b79a..48b5612f 100644
--- a/collects/typed-scheme/typecheck/find-annotation.rkt
+++ b/collects/typed-scheme/typecheck/find-annotation.rkt
@@ -45,13 +45,19 @@
 
 ;; expr id -> type or #f
 ;; if there is a binding in stx of the form:
-;; (let ([x (reverse name)]) e)
+;; (let ([x (reverse name)]) e) or
+;; (let ([x name]) e)
 ;; where x has a type annotation, return that annotation, otherwise #f
 (define (find-annotation stx name)
   (define (find s) (find-annotation s name))
   (define (match? b)
     (syntax-parse b
       #:literals (#%plain-app reverse)
+      [c:lv-clause
+       #:with n:id #'c.e
+       #:with (v) #'(c.v ...)
+       #:fail-unless (free-identifier=? name #'n) #f
+       (or (type-annotation #'v) (lookup-type/lexical #'v #:fail (lambda _ #f)))]
       [c:lv-clause
        #:with (#%plain-app reverse n:id) #'c.e
        #:with (v) #'(c.v ...) 
diff --git a/collects/typed-scheme/typecheck/provide-handling.rkt b/collects/typed-scheme/typecheck/provide-handling.rkt
index 504cfb1c..48734be0 100644
--- a/collects/typed-scheme/typecheck/provide-handling.rkt
+++ b/collects/typed-scheme/typecheck/provide-handling.rkt
@@ -9,16 +9,14 @@
          (private typed-renaming)
          (rep type-rep)
 	 (utils tc-utils)
+         (for-syntax syntax/parse racket/base)
          racket/contract/private/provide unstable/list
-         unstable/debug
+         unstable/debug syntax/id-table racket/dict
          unstable/syntax scheme/struct-info scheme/match
-         "def-binding.rkt" syntax/parse)
+         "def-binding.rkt" syntax/parse
+         (for-template scheme/base "def-export.rkt" scheme/contract))
 
-(require (for-template scheme/base
-                       scheme/contract))
-
-(provide remove-provides provide? generate-prov
-         get-alternate)
+(provide remove-provides provide? generate-prov get-alternate)
 
 (define (provide? form)    
   (syntax-parse form 
@@ -29,21 +27,13 @@
 (define (remove-provides forms)
   (filter (lambda (e) (not (provide? e))) (syntax->list forms)))
 
-(define (renamer id #:alt [alt #f])
-  (if alt
-      (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
-      (make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
-
-;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
-(define mapping (make-free-identifier-mapping))
-
 (define (mem? i vd)
   (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
         [else #f]))
 
-;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax
-;; val-defs: define-values in this module
-;; stx-defs: define-syntaxes in this module
+;; generate-contract-defs : dict[id -> def-binding] dict[id -> id] id -> syntax
+;; defs: defines in this module
+;; provs: provides in this module
 ;; pos-blame-id: a #%variable-reference for the module
 
 ;; internal-id : the id being provided 
@@ -52,105 +42,79 @@
 
 ;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id
 ;; otherwise, we will map internal-id to the fresh id in `mapping'
-(define ((generate-prov stx-defs val-defs pos-blame-id) form)
+(define (generate-prov defs provs pos-blame-id)
+  ;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
+  (define mapping (make-free-id-table))
+
   ;; mk : id [id] -> (values syntax id)
   (define (mk internal-id [new-id (generate-temporary internal-id)])
+    (define (mk-untyped-syntax b defn-id internal-id)
+      (match b
+        [(def-struct-stx-binding _ (? struct-info? si))
+         (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
+           (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
+                                                                       (mk e)
+                                                                       (values #'(begin) e)))
+                                                     (list* type-desc constr pred super accs))])
+             (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids])
+                                                                          (if (identifier? i)
+                                                                              #`(syntax #,i)
+                                                                              i))])
+               #`(begin
+                   #,@defns
+                   (define-syntax #,defn-id
+                     (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
+        [_
+         #`(define-syntax #,defn-id
+             (lambda (stx)
+               (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))]))
     (cond
       ;; if it's already done, do nothing
-      [(free-identifier-mapping-get mapping internal-id
-                                    ;; if it wasn't there, put it in, and skip this case
-                                    (lambda ()
-                                      (free-identifier-mapping-put! mapping internal-id new-id)
-                                      #f))
-       => (lambda (mapped-id)
-            (values #'(begin) mapped-id))]
-      [(mem? internal-id val-defs)
+      [(dict-ref mapping internal-id
+                 ;; if it wasn't there, put it in, and skip this case
+                 (λ () (dict-set! mapping internal-id new-id) #f))
+       => (λ (mapped-id) (values #'(begin) mapped-id))]
+      [(dict-ref defs internal-id #f)
        =>
-       (lambda (b)
-         (values
-          (with-syntax ([id internal-id])
-            (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
-                   =>
-                   (lambda (cnt)                                    
-                     (with-syntax ([(cnt-id) (generate-temporaries #'(id))]
-                                   [export-id new-id]
-                                   [module-source pos-blame-id]
-                                   [the-contract (generate-temporary 'generated-contract)])
-                       #`(begin 
-                           (define the-contract #,cnt)
-                           (define-syntax cnt-id
-                             (make-provide/contract-transformer
-                              (quote-syntax the-contract)
-                              (quote-syntax id)
-                              (quote-syntax out-id)
-                              (quote-syntax module-source)))
-                           (define-syntax export-id
-                             (if (unbox typed-context?)
-                                 (renamer #'id #:alt #'cnt-id)
-                                 (renamer #'cnt-id))))))]
-                  [else 
-                   (with-syntax ([(error-id) (generate-temporaries #'(id))]
-                                 [export-id new-id])
-                     #`(begin        
-                         (define-syntax error-id
-                           (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
-                         (define-syntax export-id
-                           (if (unbox typed-context?)
-                               (renamer #'id #:alt #'error-id)
-                               (renamer #'error-id)))))]))
-          new-id))]
-      [(mem? internal-id stx-defs) 
-       =>
-       (lambda (b)
-         (define (mk-untyped-syntax defn-id internal-id)
-           (match b
-             [(struct def-struct-stx-binding (_ (? struct-info? si)))
-               (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
-                 (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
-                                                                             (mk e)
-                                                                             (values #'(begin) e)))
-                                                           (list* type-desc constr pred super accs))])
-                   (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids])
-                                                                                (if (identifier? i)
-                                                                                    #`(syntax #,i)
-                                                                                    i))])
-                   #`(begin
-                       #,@defns
-                       (define-syntax #,defn-id
-                         (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
-             [_
-               #`(define-syntax #,defn-id
-                   (lambda (stx)
-                     (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))]))
-         (with-syntax* ([id internal-id]
-                        [export-id new-id]
-                        [(untyped-id) (generate-temporaries #'(id))])
-           (values
-            #`(begin  
-                #,(mk-untyped-syntax #'untyped-id internal-id)
-                (define-syntax export-id
-                  (if (unbox typed-context?)
-                      (begin                           
-                        (add-alias #'export-id #'id)
-                        (renamer #'id #:alt #'untyped-id))
-                      (renamer #'untyped-id))))
-            new-id)))]
+       (match-lambda
+         [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f) #:out #t)) (? values cnt)))
+          (values
+           (with-syntax* ([id internal-id]
+                          [cnt-id (generate-temporary #'id)]
+                          [export-id new-id]
+                          [module-source pos-blame-id]
+                          [the-contract (generate-temporary 'generated-contract)])
+             #`(begin 
+                 (define the-contract #,cnt)
+                 (define-syntax cnt-id
+                   (make-provide/contract-transformer
+                    (quote-syntax the-contract)
+                    (quote-syntax id)
+                    (quote-syntax out-id)
+                    (quote-syntax module-source)))
+                 (def-export export-id id cnt-id)))
+           new-id)]
+         [(def-binding id ty)
+          (values
+           (with-syntax* ([id internal-id]
+                          [error-id (generate-temporary #'id)]
+                          [export-id new-id])
+               #'(begin        
+                   (define-syntax (error-id stx)
+                     (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))
+                   (def-export export-id id error-id)))
+           new-id)]
+         [(and b (def-stx-binding _))
+          (with-syntax* ([id internal-id]
+                         [export-id new-id]
+                         [untyped-id (generate-temporary #'id)]
+                         [def (mk-untyped-syntax b #'untyped-id internal-id)])
+            (values
+             #`(begin def (def-export export-id id untyped-id #:alias))
+             new-id))])]
       ;; otherwise, not defined in this module, not our problem
       [else (values #'(begin) internal-id)]))
-  ;; do-one : id [id] -> syntax
-  (define (do-one internal-id [external-id internal-id])
+  ;; do-one : id id -> syntax
+  (for/list ([(internal-id external-id) (in-dict provs)])
     (define-values (defs id) (mk internal-id))
-    #`(begin #,defs (provide (rename-out [#,id #,external-id]))))
-  (syntax-parse form #:literals (#%provide)
-      [(#%provide form ...)
-       (for/list ([f (syntax->list #'(form ...))])
-         (parameterize ([current-orig-stx f])
-           (syntax-parse f
-             [i:id 
-              (do-one #'i)]
-             [((~datum rename) in out)
-              (do-one #'in #'out)]
-             [((~datum protect) . _)
-              (tc-error "provide: protect not supported by Typed Scheme")]
-             [_ (int-err "unknown provide form")])))]
-      [_ (int-err "non-provide form! ~a" (syntax->datum form))]))
+    #`(begin #,defs (provide (rename-out [#,id #,external-id])))))
diff --git a/collects/typed-scheme/typecheck/signatures.rkt b/collects/typed-scheme/typecheck/signatures.rkt
index 14103c35..0e12899a 100644
--- a/collects/typed-scheme/typecheck/signatures.rkt
+++ b/collects/typed-scheme/typecheck/signatures.rkt
@@ -11,7 +11,6 @@
    [cnt tc-literal (->* (syntax?) ((or/c #f Type/c)) Type/c)]
    [cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)]
    [cnt tc-expr/check/t (syntax? tc-results? . -> . Type/c)]
-   [cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])]
    [cnt tc-exprs ((listof syntax?) . -> . tc-results?)]
    [cnt tc-exprs/check ((listof syntax?) tc-results? . -> . tc-results?)]
    [cnt tc-expr/t (syntax? . -> . Type/c)]
@@ -32,13 +31,14 @@
 
 (define-signature tc-app^
   ([cnt tc/app (syntax? . -> . tc-results?)] 
-   [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)]
-   [cnt tc/funapp (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)]))
+   [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)]))
+
+(define-signature tc-apply^
+  ([cnt tc/apply (syntax? syntax? . -> . tc-results?)]))
 
 (define-signature tc-let^
   ([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)]
-   [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-results?)]
-   [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)]))
+   [cnt tc/letrec-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)]))
 
 (define-signature tc-dots^
   ([cnt tc/dots (syntax? . -> . (values Type/c symbol?))]))
diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt
index 9afae1e2..f00a8e29 100644
--- a/collects/typed-scheme/typecheck/tc-app.rkt
+++ b/collects/typed-scheme/typecheck/tc-app.rkt
@@ -1,31 +1,33 @@
-#lang scheme/unit
+#lang racket/unit
 
 (require (rename-in "../utils/utils.rkt" [infer r:infer])
-         "signatures.rkt" "tc-metafunctions.rkt"
-         "tc-app-helper.rkt" "find-annotation.rkt"
-         "tc-subst.rkt"
-         syntax/parse scheme/match mzlib/trace scheme/list 
+         "signatures.rkt" "tc-metafunctions.rkt" "check-below.rkt"
+         "tc-app-helper.rkt" "find-annotation.rkt" "tc-funapp.rkt"
+         "tc-subst.rkt" (prefix-in c: racket/contract)
+         syntax/parse racket/match racket/trace scheme/list 
 	 unstable/sequence unstable/debug
-         ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
+         ;; fixme - don't need to be bound in this phase - only to make tests work
          scheme/bool
+         racket/unsafe/ops
          (only-in racket/private/class-internal make-object do-make-object)
          (only-in '#%kernel [apply k:apply])
          ;; end fixme
          (for-syntax syntax/parse scheme/base (utils tc-utils))
          (private type-annotation)
-         (types utils abbrev union subtype resolve convenience)
+         (types utils abbrev union subtype resolve convenience type-table substitute)
          (utils tc-utils)
          (only-in srfi/1 alist-delete)
-         (except-in (env type-environments) extend)
-         (rep type-rep filter-rep object-rep)
+         (except-in (env type-env-structs tvar-env index-env) extend)
+         (rep type-rep filter-rep object-rep rep-utils)
          (r:infer infer)
          '#%paramz
-         (for-template 
+         (for-template
+          racket/unsafe/ops
           (only-in '#%kernel [apply k:apply])
           "internal-forms.rkt" scheme/base scheme/bool '#%paramz
           (only-in racket/private/class-internal make-object do-make-object)))
 
-(import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
+(import tc-expr^ tc-lambda^ tc-let^ tc-apply^)
 (export tc-app^)
 
 
@@ -41,7 +43,7 @@
 ;; typecheck eq? applications
 ;; identifier expr expr -> tc-results
 (define (tc/eq comparator v1 v2)  
-  (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e)))
+  (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e)))
   (define (eqv?-able e) (or (eq?-able e) (number? e)))
   (define (equal?-able e) #t)
   (define (ok? val)
@@ -78,9 +80,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Keywords
 
-(define (tc-keywords form arities kws kw-args pos-args expected)
-  (match arities
-    [(list (arr: dom rng rest #f ktys))
+(define (tc-keywords/internal arity kws kw-args error?)
+  (match arity
+    [(arr: dom rng rest #f ktys)
      ;; assumes that everything is in sorted order
      (let loop ([actual-kws kws]
                 [actuals (map tc-expr/t (syntax->list kw-args))]
@@ -89,28 +91,59 @@
          [('() '())
           (void)]
          [(_ '())
-          (tc-error/expr #:return (ret (Un))
-                         "Unexpected keyword argument ~a" (car actual-kws))]
+          (if error? 
+              (tc-error/expr #:return (ret (Un))
+                             "Unexpected keyword argument ~a" (car actual-kws))
+              #f)]
          [('() (cons fst rst))
           (match fst
             [(Keyword: k _ #t)
-             (tc-error/expr #:return (ret (Un))
-                            "Missing keyword argument ~a" k)]
+             (if error?
+                 (tc-error/expr #:return (ret (Un))
+                                "Missing keyword argument ~a" k)
+                 #f)]
             [_ (loop actual-kws actuals rst)])]
          [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest))
-          (cond [(eq? k k*) ;; we have a match
-                 (unless (subtype (car actuals) t)
-                   (tc-error/delayed
-                    "Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
-                    t (car actuals) k))
-                 (loop kws-rest (cdr actuals) form-rest)]
+          (cond [(eq? k k*) ;; we have a match                 
+                 (if (subtype (car actuals) t)
+                     ;; success
+                     (loop kws-rest (cdr actuals) form-rest)
+                     ;; failure
+                     (and error?
+                          (tc-error/delayed
+                           "Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
+                           t (car actuals) k)
+                          (loop kws-rest (cdr actuals) form-rest)))]
                 [req? ;; this keyword argument was required
-                 (tc-error/delayed "Missing keyword argument ~a" k*)
-                 (loop kws-rest (cdr actuals) form-rest)]
+                 (if error? 
+                     (begin (tc-error/delayed "Missing keyword argument ~a" k*)
+                            (loop kws-rest (cdr actuals) form-rest))
+                     #f)]
                 [else ;; otherwise, ignore this formal param, and continue
-                 (loop actual-kws actuals form-rest)])]))
-     (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function (list (make-arr* dom rng #:rest rest)))) (map tc-expr (syntax->list pos-args)) expected)]
-    [_ (int-err "case-lambda w/ keywords not supported")]))
+                 (loop actual-kws actuals form-rest)])]))]))
+
+(define (tc-keywords form arities kws kw-args pos-args expected)
+  (match arities
+    [(list (and a (arr: dom rng rest #f ktys))) 
+     (tc-keywords/internal a kws kw-args #t)
+     (tc/funapp (car (syntax-e form)) kw-args
+                (ret (make-Function (list (make-arr* dom rng #:rest rest))))
+                (map tc-expr (syntax->list pos-args)) expected)]
+    [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...)
+     (let ([new-arities 
+            (for/list ([a (in-list arities)]
+                       ;; find all the arities where the keywords match
+                       #:when (tc-keywords/internal a kws kw-args #f))
+              (match a
+                [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))])
+       (if (null? new-arities)
+           (tc-error/expr 
+            #:return (or expected (ret (Un)))
+            (string-append "No function domains matched in function application:\n"
+                           (domain-mismatches arities doms rests drests rngs (map tc-expr (syntax->list pos-args)) #f #f)))
+         (tc/funapp (car (syntax-e form)) kw-args
+                    (ret (make-Function new-arities))
+                    (map tc-expr (syntax->list pos-args)) expected)))]))
 
 (define (type->list t)
   (match t
@@ -204,210 +237,18 @@
        (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected)
        expected)]
     ;; special case when argument needs inference
-    [_     
+    [(_ body* _)
      (let ([ts (for/list ([ac (syntax->list actuals)]
                           [f (syntax->list args)])
-                 (or 
-                  (type-annotation f #:infer #t)
-                  (generalize (tc-expr/t ac))))])
+                 (let* ([infer-t (or (type-annotation f #:infer #t)
+                                     (find-annotation #'(begin . body*) f))])
+                   (if infer-t
+                       (begin (check-below (tc-expr/t ac) infer-t)
+                              infer-t)
+                       (generalize (tc-expr/t ac)))))])
        (tc/rec-lambda/check form args body lp ts expected)
        expected)]))
 
-(define (tc/apply f args)
-  (define (do-ret t)
-    (match t 
-      [(Values: (list (Result: ts _ _) ...)) (ret ts)]
-      [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)]
-      [_ (int-err "do-ret fails: ~a" t)]))
-  (define f-ty (single-value f))
-  ;; produces the first n-1 elements of the list, and the last element
-  (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))])
-                      (values f (car r))))
-  (define-values (fixed-args tail) (split (syntax->list args)))
-
-  (match f-ty
-    [(tc-result1: (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...)))
-     (when (null? doms)
-       (tc-error/expr #:return (ret (Un))
-                      "empty case-lambda given as argument to apply"))
-     (let ([arg-tys (map tc-expr/t fixed-args)])
-       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
-         (cond [(null? doms*)
-                (let-values ([(tail-ty tail-bound)
-                              (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))])
-                                (tc/dots tail))])
-                  (tc-error/expr #:return (ret (Un))
-                                 (string-append 
-                                  "Bad arguments to function in apply:~n"
-                                  (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))]
-               [(and (car rests*)
-                     (let-values ([(tail-ty tail-bound) 
-                                   (with-handlers ([exn:fail? (lambda _ (values #f #f))])
-                                     (tc/dots tail))])
-                       (and tail-ty
-                            (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty))
-                                     (apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
-                (printf/log "Non-poly apply, ... arg\n")
-                (do-ret (car rngs*))]
-               [(and (car rests*)
-                     (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)])
-                                      (tc-expr/t tail))])
-                       (and tail-ty
-                            (subtype (apply -lst* arg-tys #:tail tail-ty)
-                                     (apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
-                
-                    (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) 
-                                    "Simple arithmetic non-poly apply\n"
-                                    "Simple non-poly apply\n"))
-                    (do-ret (car rngs*))]
-               [(and (car drests*)
-                     (let-values ([(tail-ty tail-bound) 
-                                   (with-handlers ([exn:fail? (lambda (e) (values #f #f))])
-                                     (tc/dots tail))])
-                       (and tail-ty
-                            (eq? (cdr (car drests*)) tail-bound)
-                            (subtypes arg-tys (car doms*))
-                            (subtype tail-ty (car (car drests*))))))
-                (printf/log "Non-poly apply, ... arg\n")
-                (do-ret (car rngs*))]
-               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
-    [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
-     (let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
-                   [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
-                                           (tc/dots tail))])
-       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
-         (cond [(null? doms*)
-                (match f-ty 
-                  [(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
-                   (tc-error/expr #:return (ret (Un))
-                                 (string-append 
-                                  "Bad arguments to polymorphic function in apply:~n"
-                                  (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
-               ;; the actual work, when we have a * function and a list final argument
-               [(and (car rests*)
-                     (not tail-bound)
-                     (<= (length (car doms*))
-                         (length arg-tys))
-                     (infer/vararg vars
-                                   (cons tail-ty arg-tys) 
-                                   (cons (make-Listof (car rests*))
-                                         (car doms*))
-                                   (car rests*)
-                                   (car rngs*)
-                                   (fv (car rngs*))))
-                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
-               ;; actual work, when we have a * function and ... final arg
-               [(and (car rests*)
-                     tail-bound                     
-                     (<= (length (car doms*))
-                         (length arg-tys))
-                     (infer/vararg vars
-                                   (cons (make-Listof tail-ty) arg-tys)
-                                   (cons (make-Listof (car rests*))
-                                         (car doms*))
-                                   (car rests*)
-                                   (car rngs*)
-                                   (fv (car rngs*))))
-                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
-               ;; ... function, ... arg
-               [(and (car drests*)                     
-                     tail-bound
-                     (eq? tail-bound (cdr (car drests*)))
-                     (= (length (car doms*))
-                        (length arg-tys))
-                     (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
-                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
-               ;; if nothing matches, around the loop again
-               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
-    [(tc-result1: (Poly: vars (Function: '())))
-     (tc-error/expr #:return (ret (Un))
-                    "Function has no cases")]
-    [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
-                            (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
-     (let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
-                   [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
-                                           (tc/dots tail))])
-       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
-         (cond [(null? doms*)
-                (match f-ty 
-                  [(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
-                   (tc-error/expr #:return (ret (Un))
-                                 (string-append 
-                                  "Bad arguments to polymorphic function in apply:~n"
-                                  (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
-               ;; the actual work, when we have a * function and a list final argument
-               [(and (car rests*)
-                     (not tail-bound)
-                     (<= (length (car doms*))
-                         (length arg-tys))
-                     (infer/vararg vars
-                                   (cons tail-ty arg-tys) 
-                                   (cons (make-Listof (car rests*))
-                                         (car doms*))
-                                   (car rests*)
-                                   (car rngs*)
-                                   (fv (car rngs*))))
-                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
-               ;; actual work, when we have a * function and ... final arg
-               [(and (car rests*)
-                     tail-bound                     
-                     (<= (length (car doms*))
-                         (length arg-tys))
-                     (infer/vararg vars
-                                   (cons (make-Listof tail-ty) arg-tys)
-                                   (cons (make-Listof (car rests*))
-                                         (car doms*))
-                                   (car rests*)
-                                   (car rngs*)
-                                   (fv (car rngs*))))
-                => (lambda (substitution) 
-                     (do-ret (subst-all substitution (car rngs*))))]
-               ;; ... function, ... arg, same bound on ...
-               [(and (car drests*)
-                     tail-bound
-                     (eq? tail-bound (cdr (car drests*)))
-                     (= (length (car doms*))
-                        (length arg-tys))                     
-                     (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
-                => (lambda (substitution)
-                     (do-ret (subst-all substitution (car rngs*))))]
-               ;; ... function, ... arg, different bound on ...
-               [(and (car drests*)
-                     tail-bound
-                     (not (eq? tail-bound (cdr (car drests*))))
-                     (= (length (car doms*))
-                        (length arg-tys))
-                     (parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*)))
-                                                               (list (make-DottedBoth (make-F tail-bound))
-                                                                     (make-DottedBoth (make-F (cdr (car drests*)))))
-                                                               (current-tvars))])
-                       (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))
-                => (lambda (substitution) 
-                     (define drest-bound (cdr (car drests*)))
-                     (do-ret (substitute-dotted (cadr (assq drest-bound substitution))
-                                                tail-bound
-                                                drest-bound
-                                                (subst-all (alist-delete drest-bound substitution eq?)
-                                                           (car rngs*)))))]
-               ;; ... function, (List A B C etc) arg
-               [(and (car drests*)
-                     (not tail-bound)
-                     (eq? (cdr (car drests*)) dotted-var)
-                     (= (length (car doms*))
-                        (length arg-tys))
-                     (untuple tail-ty)
-                     (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*)
-                                 (car (car drests*)) (car rngs*) (fv (car rngs*))))
-                => (lambda (substitution) 
-                     (define drest-bound (cdr (car drests*)))
-                     (do-ret (subst-all substitution (car rngs*))))]
-               ;; if nothing matches, around the loop again
-               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
-    [(tc-result1: (PolyDots: vars (Function: '())))
-     (tc-error/expr #:return (ret (Un))
-                    "Function has no cases")]
-    [(tc-result1: f-ty) (tc-error/expr #:return (ret (Un))
-                         "Type of argument to apply is not a function type: ~n~a" f-ty)]))
 
 ;; the main dispatching function
 ;; syntax tc-results? -> tc-results?
@@ -415,7 +256,10 @@
   (syntax-parse form
     #:literals (#%plain-app #%plain-lambda letrec-values quote
                 values apply k:apply not list list* call-with-values do-make-object make-object cons
-                andmap ormap reverse extend-parameterization vector-ref)
+                map andmap ormap reverse extend-parameterization
+                vector-ref unsafe-vector-ref unsafe-vector*-ref
+                vector-set! unsafe-vector-set! unsafe-vector*-set!
+                unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!)
     [(#%plain-app extend-parameterization pmz args ...)
      (let loop ([args (syntax->list #'(args ...))])
        (if (null? args) (ret Univ)
@@ -430,37 +274,56 @@
                [(tc-result1: t) 
                 (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
                 (loop (cddr args))]))))]
-    ;; vector-ref on het vectors
-    [(#%plain-app (~and op (~literal vector-ref)) v e:expr)
+    ;; use the additional but normally ignored first argument to make-sequence to provide a better instantiation
+    [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) (~and quo ((~literal quote) (i:id))) arg:expr)
+     #:when (type-annotation #'i)     
+     (match (single-value #'op)
+         [(tc-result1: (and t Poly?))
+          (tc-expr/check #'quo (ret Univ))
+          (tc/funapp #'op #'(quo arg) 
+                     (ret (instantiate-poly t (list (type-annotation #'i))))
+                     (list (ret Univ) (single-value #'arg))
+                     expected)])]
+    ;; unsafe struct operations
+    [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr)
      (let ([e-t (single-value #'e)])
-       (match (single-value #'v)
-         [(tc-result1: (and t (HeterogenousVector: es)))
+       (match (single-value #'s)
+         [(tc-result1: 
+           (and t (or (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _)
+                      (? needs-resolving? 
+                         (app resolve-once
+                              (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _))))))
           (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
                           (match e-t
                             [(tc-result1: (Value: (? number? i))) i]
                             [_ #f]))])
             (cond [(not ival)
-                   (check-below e-t -Nat)
-                   (if expected 
-                       (check-below (ret (apply Un es)) expected)
-                       (ret (apply Un es)))]
-                  [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es))))
-                   (if expected 
-                       (check-below (ret (list-ref es ival)) expected)
-                       (ret (list-ref es ival)))]
+                   (check-below e-t -Integer)
+                   (if expected
+                       (check-below (ret (apply Un flds)) expected)
+                       (ret (apply Un flds)))]
+                  [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds))))
+                   (let ([result (if (list-ref muts ival)
+                                     (ret (list-ref flds ival))
+                                     ;; FIXME - could do something with paths here
+                                     (ret (list-ref flds ival)))])
+                     (if expected (check-below result expected) result))]
                   [(not (and (integer? ival) (exact? ival)))
-                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)]
+                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)]
                   [(< ival 0)
-                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)]
-                  [(not (<= ival (sub1 (length es))))
-                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))]
-         [v-ty
-          (let ([arg-tys (list v-ty e-t)])
-            (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))]))]
-    [(#%plain-app (~and op (~literal vector-set!)) v e:expr val:expr)
+                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)]
+                  [(not (<= ival (sub1 (length flds))))
+                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))]
+         [s-ty
+          (let ([arg-tys (list s-ty e-t)])
+            (tc/funapp #'op #'(s e) (single-value #'op) arg-tys expected))]))]
+    [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr)
      (let ([e-t (single-value #'e)])
-       (match (single-value #'v)
-         [(tc-result1: (and t (HeterogenousVector: es)))
+       (match (single-value #'s)
+         [(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)
+                                  (? needs-resolving? 
+                                     (app resolve-once 
+                                          (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))))
           (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
                           (match e-t
                             [(tc-result1: (Value: (? number? i))) i]
@@ -468,46 +331,159 @@
             (cond [(not ival)
                    (tc-error/expr #:stx #'e
                                   #:return (or expected (ret -Void))
-                                  "expected statically known index for heterogenous vector, but got ~a" (match e-t [(tc-result1: t) t]))]
-                  [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es))))
-                   (tc-expr/check #'val (ret (list-ref es ival)))
-                   (if expected 
+                                  "expected statically known index for unsafe struct mutation, but got ~a" (match e-t [(tc-result1: t) t]))]
+                  [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds))))
+                   (tc-expr/check #'val (ret (list-ref flds ival)))
+                   (if expected
                        (check-below (ret -Void) expected)
                        (ret -Void))]
                   [(not (and (integer? ival) (exact? ival)))
                    (single-value #'val)
-                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)]
+                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for unsafe struct mutation, but got ~a" ival)]
                   [(< ival 0)
                    (single-value #'val)
-                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)]
-                  [(not (<= ival (sub1 (length es))))
+                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)]
+                  [(not (<= ival (sub1 (length flds))))
                    (single-value #'val)
-                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))]
-         [v-ty
-          (let ([arg-tys (list v-ty e-t (single-value #'val))])
-            (tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))]))]
+                   (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))]
+         [s-ty
+          (let ([arg-tys (list s-ty e-t (single-value #'val))])
+            (tc/funapp #'op #'(s e val) (single-value #'op) arg-tys expected))]))]
+    ;; vector-ref on het vectors
+    [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr)
+     (let ([e-t (single-value #'e)])
+       (let loop ((v-t (single-value #'v)))
+	 (match v-t
+           [(tc-result1: (and t (HeterogenousVector: es)))
+	    (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
+			    (match e-t
+			      [(tc-result1: (Value: (? number? i))) i]
+			      [_ #f]))])
+	      (cond [(not ival)
+		     (check-below e-t -Integer)
+		     (if expected 
+			 (check-below (ret (apply Un es)) expected)
+			 (ret (apply Un es)))]
+		    [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es))))
+		     (if expected 
+			 (check-below (ret (list-ref es ival)) expected)
+			 (ret (list-ref es ival)))]
+		    [(not (and (integer? ival) (exact? ival)))
+		     (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)]
+		    [(< ival 0)
+		     (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)]
+		    [(not (<= ival (sub1 (length es))))
+		     (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))]
+	   [(tc-result1: (? needs-resolving? e) f o)
+	    (loop (ret (resolve-once e) f o))]
+	   [v-ty
+	    (let ([arg-tys (list v-ty e-t)])
+	      (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))])))]
+    [(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr)
+     (let ([e-t (single-value #'e)])
+       (let loop ((v-t (single-value #'v)))
+	 (match v-t
+           [(tc-result1: (and t (HeterogenousVector: es)))
+	    (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
+			    (match e-t
+			      [(tc-result1: (Value: (? number? i))) i]
+			      [_ #f]))])
+	      (cond [(not ival)
+		     (tc-error/expr #:stx #'e
+				    #:return (or expected (ret -Void))
+				    "expected statically known index for heterogenous vector, but got ~a" (match e-t [(tc-result1: t) t]))]
+		    [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es))))
+		     (tc-expr/check #'val (ret (list-ref es ival)))
+		     (if expected 
+			 (check-below (ret -Void) expected)
+			 (ret -Void))]
+		    [(not (and (integer? ival) (exact? ival)))
+		     (single-value #'val)
+		     (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)]
+		    [(< ival 0)
+		     (single-value #'val)
+		     (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)]
+		    [(not (<= ival (sub1 (length es))))
+		     (single-value #'val)
+		     (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))]
+	   [(tc-result1: (? needs-resolving? e) f o)
+	    (loop (ret (resolve-once e) f o))]
+	   [v-ty
+	    (let ([arg-tys (list v-ty e-t (single-value #'val))])
+	      (tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))])))]
     [(#%plain-app (~and op (~literal vector)) args:expr ...)
+     (let loop ([expected expected])
+       (match expected
+         [(tc-result1: (Vector: t))
+          (for ([e (in-list (syntax->list #'(args ...)))])
+            (tc-expr/check e (ret t)))
+          expected]
+         [(tc-result1: (HeterogenousVector: ts))
+          (unless (= (length ts) (length (syntax->list #'(args ...))))
+            (tc-error/expr "expected vector with ~a elements, but got ~a" 
+                           (length ts)
+                           (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))))
+          (for ([e (in-list (syntax->list #'(args ...)))]
+                [t (in-list ts)])
+            (tc-expr/check e (ret t)))
+          expected]
+         [(tc-result1: (? needs-resolving? e) f o)
+          (loop (ret (resolve-once e) f o))]
+         [(tc-result1: (and T (Union: (app (λ (ts)
+                                             (for/list ([t ts]
+                                                        #:when (let ([k (Type-key t)])
+                                                                 (eq? 'vector k)))
+                                               t))
+                                         ts))))
+          (if (null? ts)
+            (let ([arg-tys (map single-value (syntax->list #'(args ...)))])
+              (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))
+            (check-below (for/first ([t ts]) (loop (ret t)))
+                         expected))]
+	 ;; since vectors are mutable, if there is no expected type, we want to generalize the element type
+         [(or #f (tc-result1: _))
+	  (ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x)))
+					     (syntax->list #'(args ...)))))]
+         [_ (int-err "bad expected: ~a" expected)]))]
+    ;; since vectors are mutable, if there is no expected type, we want to generalize the element type
+    [(#%plain-app (~and op (~literal make-vector)) n elt)
      (match expected
        [(tc-result1: (Vector: t))
-        (for ([e (in-list (syntax->list #'(args ...)))])
-          (tc-expr/check e (ret t)))
-        expected]
-       [(tc-result1: (HeterogenousVector: ts))
-        (unless (= (length ts) (length (syntax->list #'(args ...))))
-          (tc-error/expr "expected vector with ~a elements, but got ~a" 
-                         (length ts)
-                         (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))))
-        (for ([e (in-list (syntax->list #'(args ...)))]
-              [t (in-list ts)])
-          (tc-expr/check e (ret t)))
+        (tc-expr/check #'n (ret -Integer))
+        (tc-expr/check #'elt (ret t))
         expected]
        [(or #f (tc-result1: _))
-        (let ([arg-tys (map single-value (syntax->list #'(args ...)))])
-            (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))
-        #;#;
-        (tc-error/expr "expected ~a, but got ~a" t (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...)))))
-        expected]
+        (tc/funapp #'op #'(n elt) (single-value #'op)
+                   (list (single-value #'n)
+                         (match (single-value #'elt)
+                           [(tc-result1: t) (ret (generalize t))]))
+                   expected)]
        [_ (int-err "bad expected: ~a" expected)])]
+    [(#%plain-app (~and op (~literal build-vector)) n proc)
+     (match expected
+       [(tc-result1: (Vector: t))
+        (tc-expr/check #'n (ret -Integer))
+        (tc-expr/check #'proc (ret (-NonnegativeFixnum . -> . t)))
+        expected]
+       [(or #f (tc-result1: _))
+        (tc/funapp #'op #'(n elt) (single-value #'op)
+                   (list (single-value #'n)
+                         (match (tc/funapp #'proc #'(1) ; valid nonnegative-fixnum
+                                           (single-value #'proc)
+                                           (list (ret -NonnegativeFixnum))
+                                           #f)
+                           [(tc-result1: t) (ret (-> -NonnegativeFixnum (generalize t)))]))
+                   expected)]
+       [_ (int-err "bad expected: ~a" expected)])]
+    ;; special case for `-' used like `sub1'
+    [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1)))
+     (add-typeof-expr #'arg2 (ret -PositiveFixnum))
+     (match-let ([(tc-result1: t) (single-value #'v)])
+       (cond
+        [(subtype t -PositiveFixnum) (ret -NonnegativeFixnum)]
+        [(subtype t -NonnegativeFixnum) (ret -Fixnum)]
+        [(subtype t -ExactPositiveInteger) (ret -Nat)]
+        [else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))]
     ;; call-with-values
     [(#%plain-app call-with-values prod con)
      (match (tc/funapp #'prod #'() (single-value #'prod) null #f)
@@ -528,10 +504,10 @@
         (ret -Boolean (make-FilterSet f- f+))])]
     ;; (apply values l) gets special handling
     [(#%plain-app apply values e)
-     (cond [(with-handlers ([exn:fail? (lambda _ #f)])
-              (untuple (tc-expr/t #'e)))
-            => ret]
-           [else (tc/apply #'values #'(e))])]
+     (match (single-value #'e)
+       [(tc-result1: (ListDots: dty dbound)) (values->tc-results (make-ValuesDots null dty dbound) #f)]
+       [(tc-result1: (List: ts)) (ret ts)]
+       [_ (tc/apply #'values #'(e))])]
     ;; rewrite this so that it takes advantages of all the special cases
     [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)]
     ;; handle apply specially
@@ -571,7 +547,7 @@
           (fail))
         (match (map single-value (syntax->list #'pos-args))
           [(list (tc-result1: argtys-t) ...)
-           (let* ([subst (infer vars argtys-t dom rng (fv rng) (and expected (tc-results->values expected)))])
+           (let* ([subst (infer vars null argtys-t dom rng (and expected (tc-results->values expected)))])
              (tc-keywords form (list (subst-all subst ar))
                           (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])]
        [(tc-result1: (Function: arities)) 
@@ -592,20 +568,43 @@
      (check-do-make-object #'cl #'args #'() #'())]
     [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...))
      (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
+    [(#%plain-app (~and map-expr (~literal map)) f arg0 arg ...)
+     (match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...))))
+       ;; if the argument is a ListDots
+       [((tc-result1: (ListDots: t0 bound0)) 
+         (list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var))
+                                ;; a devious hack - just generate #f so the test below succeeds
+                                ;; have to explicitly bind `var' since otherwise `var' appears on only one side of the or
+                                ;; NOTE: safe to include these, `map' will error if any list is not the same length as all the others
+                                (and (Listof: t var) (app (λ _ #f) bound))))
+               ...))
+        (=> fail)
+        (unless (for/and ([b bound]) (or (not b) (eq? bound0 b))) (fail))
+        (match (extend-tvars (list bound0)
+                 ;; just check that the function applies successfully to the element type
+                 (tc/funapp #'f #'(arg0 arg ...) (tc-expr #'f) (cons (ret t0) (map ret t)) expected))
+          [(tc-result1: t) (ret (make-ListDots t bound0))]
+          [(tc-results: ts)
+           (tc-error/expr #:return (ret (Un))
+                          "Expected one value, but got ~a" (-values ts))])]
+       ;; otherwise, if it's not a ListDots, defer to the regular function typechecking
+       [(res0 res)
+        (tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr) (list* (tc-expr #'f) res0 res) expected)])]
     ;; ormap/andmap of ... argument
-    [(#%plain-app (~or (~literal andmap) (~literal ormap)) f arg)
-     #:attr ty+bound
-     (with-handlers ([exn:fail? (lambda _ #f)])
-       (let-values ([(ty bound) (tc/dots #'arg)])
-         (list ty bound)))
-     #:when (attribute ty+bound)
-     (match-let ([(list ty bound) (attribute ty+bound)])
-       (parameterize ([current-tvars (extend-env (list bound)
-                                                 (list (make-DottedBoth (make-F bound)))
-                                                 (current-tvars))])
-         (match-let* ([ft (tc-expr #'f)]
-                      [(tc-result1: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)])
-           (ret (Un (-val #f) t)))))]
+    [(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg)
+     ;; check the arguments
+     (match-let* ([arg-ty (single-value #'arg)]
+                  [ft (tc-expr #'f)])
+       (match (match arg-ty
+                ;; if the argument is a ListDots
+                [(tc-result1: (ListDots: t bound))
+                 ;; just check that the function applies successfully to the element type
+                 (tc/funapp #'f #'(arg) ft (list (ret (substitute Univ bound t))) expected)]
+                ;; otherwise ...
+                [_ #f])
+         [(tc-result1: t) (ret (Un (-val #f) t))]
+         ;; if it's not a ListDots, defer to the regular function typechecking
+         [_ (tc/funapp #'fun #'(f arg) (single-value #'fun) (list ft arg-ty) expected)]))]
     ;; special case for `delay'
     [(#%plain-app 
       mp1 
@@ -722,140 +721,4 @@
   (in-range (length dom)))
 
 
-(define-syntax (handle-clauses stx)
-  (syntax-parse stx
-    [(_  (lsts ... arrs) f-stx args-stx pred infer t argtys expected)
-     (with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))])
-       (syntax/loc stx
-         (or (for/or ([vars lsts] ... [a arrs]
-                      #:when (pred vars ... a))
-               (let ([substitution (infer vars ... a)])
-                 (and substitution
-                      (tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f))))
-             (poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))]))
-
-(define (tc/funapp f-stx args-stx ftype0 argtys expected)
-  (match* (ftype0 argtys)
-    ;; we special-case this (no case-lambda) for improved error messages
-    [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws))))))
-      argtys)
-     (tc/funapp1 f-stx args-stx a argtys expected)]
-    [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...)))))
-      (and argtys (list (tc-result1: argtys-t) ...)))
-     (or 
-      ;; find the first function where the argument types match
-      (for/first ([dom doms] [rng rngs] [rest rests] [a arrs]
-                  #:when (subtypes/varargs argtys-t dom rest))
-        ;; then typecheck here
-        ;; we call the separate function so that we get the appropriate filters/objects
-        (tc/funapp1 f-stx args-stx a argtys expected #:check #f))
-      ;; if nothing matched, error
-      (tc-error/expr 
-       #:return (or expected (ret (Un)))
-       (string-append "No function domains matched in function application:\n"
-                      (domain-mismatches t doms rests drests rngs argtys-t #f #f))))]
-    ;; any kind of polymorphic function
-    [((tc-result1: (and t (PolyDots: 
-                           (and vars (list fixed-vars ... dotted-var))
-                           (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))))
-      (list (tc-result1: argtys-t) ...))
-     (handle-clauses (doms rngs rests drests arrs) f-stx args-stx
-                     ;; only try inference if the argument lengths are appropriate
-                     (lambda (dom _ rest drest a) 
-                       (cond [rest (<= (length dom) (length argtys))]
-                             [drest (and (<= (length dom) (length argtys))
-                                         (eq? dotted-var (cdr drest)))]
-                             [else (= (length dom) (length argtys))]))
-                     ;; only try to infer the free vars of the rng (which includes the vars in filters/objects)
-                     ;; note that we have to use argtys-t here, since argtys is a list of tc-results
-                     (lambda (dom rng rest drest a) 
-                       (if drest
-                           (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) 
-                                       #:expected (and expected (tc-results->values expected)))
-                           (infer/vararg vars argtys-t dom rest rng (fv rng) 
-                                         (and expected (tc-results->values expected)))))
-                     t argtys expected)]
-    ;; regular polymorphic functions without dotted rest, and without mandatory keyword args
-    [((tc-result1: 
-       (and t
-            (Poly: 
-             vars 
-             (Function: (list (and arrs (arr: doms rngs rests (and drests #f) (list (Keyword: _ _ #f) ...))) ...)))))
-      (list (tc-result1: argtys-t) ...))
-     (handle-clauses (doms rngs rests arrs) f-stx args-stx
-                     ;; only try inference if the argument lengths are appropriate
-                     (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys)))
-                     ;; only try to infer the free vars of the rng (which includes the vars in filters/objects)
-                     ;; note that we have to use argtys-t here, since argtys is a list of tc-results
-                     (lambda (dom rng rest a) (infer/vararg vars argtys-t dom rest rng (fv rng) (and expected (tc-results->values expected))))
-                     t argtys expected)]
-    ;; procedural structs
-    [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _ _))) _)
-     (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)]
-    ;; parameters are functions too
-    [((tc-result1: (Param: in out)) (list)) (ret out)]
-    [((tc-result1: (Param: in out)) (list (tc-result1: t)))
-     (if (subtype t in) 
-         (ret -Void true-filter)
-         (tc-error/expr #:return (ret -Void true-filter)
-                        "Wrong argument to parameter - expected ~a and got ~a" in t))]
-    [((tc-result1: (Param: _ _)) _) 
-     (tc-error/expr #:return (ret (Un))
-                    "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
-                    (length argtys))]
-    ;; resolve names, polymorphic apps, mu, etc
-    [((tc-result1: (? needs-resolving? t) f o) _)
-     (tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)]
-    ;; a union of functions can be applied if we can apply all of the elements
-    [((tc-result1: (Union: (and ts (list (Function: _) ...)))) _)
-     (ret (for/fold ([result (Un)]) ([fty ts])            
-            (match (tc/funapp f-stx args-stx (ret fty) argtys expected)
-              [(tc-result1: t) (Un result t)])))]
-    ;; error type is a perfectly good fcn type
-    [((tc-result1: (Error:)) _) (ret (make-Error))]
-    ;; otherwise fail
-    [((tc-result1: f-ty) _) 
-     ;(printf "ft: ~a argt: ~a~n" ftype0 argtys)
-     (tc-error/expr #:return (ret (Un))
-                    "Cannot apply expression of type ~a, since it is not a function type" f-ty)]))
-
-
-;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
-(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
-  ;(printf "got to here 0~a~n" args-stx)
-  (match* (ftype0 argtys)
-    ;; we check that all kw args are optional
-    [((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...)))
-      (list (tc-result1: t-a phi-a o-a) ...))
-     ;(printf "got to here 1~a~n" args-stx)
-     (when check?
-       (cond [(and (not rest) (not (= (length dom) (length t-a))))
-              (tc-error/expr #:return (ret t-r)
-                             "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
-             [(and rest (< (length t-a) (length dom)))
-              (tc-error/expr #:return (ret t-r)
-                             "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
-       (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] 
-             [a (in-list (syntax->list args-stx))]
-             [arg-t (in-list t-a)])
-         (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
-     ;(printf "got to here 2 ~a ~a ~a ~n" dom names o-a)
-     (let* ([dom-count (length dom)]
-            [arg-count (+ dom-count (if rest 1 0) (length kws))])
-       (let-values
-           ([(o-a t-a) (for/lists (os ts)
-                         ([nm (in-range arg-count)]
-                          [oa (in-sequence-forever (in-list o-a) (make-Empty))]
-                          [ta (in-sequence-forever (in-list t-a) (Un))])
-                         (values (if (>= nm dom-count) (make-Empty) oa)
-                                 ta))])
-         (define-values (t-r f-r o-r)
-           (for/lists (t-r f-r o-r) 
-             ([r (in-list results)])
-             (open-Result r o-a t-a)))
-         (ret t-r f-r o-r)))]
-    [((arr: _ _ _ drest '()) _)
-     (int-err "funapp with drest args NYI")]
-    [((arr: _ _ _ _ kws) _)
-     (int-err "funapp with keyword args NYI")]))
 
diff --git a/collects/typed-scheme/typecheck/tc-apply.rkt b/collects/typed-scheme/typecheck/tc-apply.rkt
new file mode 100644
index 00000000..a28ef371
--- /dev/null
+++ b/collects/typed-scheme/typecheck/tc-apply.rkt
@@ -0,0 +1,211 @@
+#lang racket/unit
+
+(require (rename-in "../utils/utils.rkt" [infer r:infer])
+         "signatures.rkt" "tc-app-helper.rkt"
+         racket/match racket/list
+         (for-syntax (utils tc-utils))
+         (private type-annotation)
+         (types utils abbrev union subtype resolve convenience type-table substitute)
+         (utils tc-utils)
+         (only-in srfi/1 alist-delete)
+         (except-in (env type-env-structs tvar-env index-env) extend)
+         (rep type-rep filter-rep object-rep rep-utils)
+         (r:infer infer)
+         '#%paramz
+         (for-template
+          racket/unsafe/ops
+          (only-in '#%kernel [apply k:apply])
+          "internal-forms.rkt" racket/base racket/bool '#%paramz
+          (only-in racket/private/class-internal make-object do-make-object)))
+
+(import tc-expr^ tc-lambda^ tc-let^ tc-app^)
+(export tc-apply^)
+
+(define (do-ret t)
+  (match t 
+    [(Values: (list (Result: ts _ _) ...)) (ret ts)]
+    [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)]
+    [_ (int-err "do-ret fails: ~a" t)]))
+
+(define (tc/apply f args)  
+  (define f-ty (single-value f))
+  ;; produces the first n-1 elements of the list, and the last element
+  (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))])
+                      (values f (car r))))
+  (define-values (fixed-args tail)
+    (let ([args* (syntax->list args)])
+      (if (null? args*)
+          (tc-error "apply requires a final list argument, given only a function argument of type ~a" (match f-ty [(tc-result1: t) t]))
+          (split args*))))
+
+  (match f-ty
+    ;; apply of simple function
+    [(tc-result1: (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...)))
+     ;; special case for (case-lambda)
+     (when (null? doms)
+       (tc-error/expr #:return (ret (Un))
+                      "empty case-lambda given as argument to apply"))
+     (match-let ([arg-tys (map tc-expr/t fixed-args)]
+                 [(tc-result1: tail-ty) (single-value tail)])
+       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
+         (cond 
+           ;; we've run out of cases to try, so error out           
+           [(null? doms*)
+            (tc-error/expr #:return (ret (Un))
+                           (string-append 
+                            "Bad arguments to function in apply:~n"
+                            (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty #f)))]
+           ;; this case of the function type has a rest argument
+           [(and (car rests*)
+                 ;; check that the tail expression is a subtype of the rest argument
+                 (subtype (apply -lst* arg-tys #:tail tail-ty)
+                          (apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))
+            (do-ret (car rngs*))]
+           ;; the function expects a dotted rest arg, so make sure we have a ListDots
+           [(and (car drests*)
+                 (match tail-ty
+                   [(ListDots: tail-ty tail-bound)
+                    ;; the check that it's the same bound
+                    (and (eq? (cdr (car drests*)) tail-bound)
+                         ;; and that the types are correct
+                         (subtypes arg-tys (car doms*))
+                         (subtype tail-ty (car (car drests*))))]
+                   [_ #f]))
+            (do-ret (car rngs*))]
+           ;; otherwise, nothing worked, move on to the next case
+           [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
+    ;; apply of simple polymorphic function
+    [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
+     (let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
+                   [(tail-ty tail-bound) (match (tc-expr/t tail)
+                                           [(ListDots: tail-ty tail-bound)
+                                            (values tail-ty tail-bound)]
+                                           [t (values t #f)])])
+       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
+         (cond [(null? doms*)
+                (match f-ty 
+                  [(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
+                   (tc-error/expr #:return (ret (Un))
+                                 (string-append 
+                                  "Bad arguments to polymorphic function in apply:~n"
+                                  (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
+               ;; the actual work, when we have a * function and a list final argument
+               [(and (car rests*)
+                     (not tail-bound)
+                     (<= (length (car doms*))
+                         (length arg-tys))
+                     (infer/vararg vars null
+                                   (cons tail-ty arg-tys) 
+                                   (cons (make-Listof (car rests*))
+                                         (car doms*))
+                                   (car rests*)
+                                   (car rngs*)))
+                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
+               ;; actual work, when we have a * function and ... final arg
+               [(and (car rests*)
+                     tail-bound                     
+                     (<= (length (car doms*))
+                         (length arg-tys))
+                     (infer/vararg vars null
+                                   (cons (make-Listof tail-ty) arg-tys)
+                                   (cons (make-Listof (car rests*))
+                                         (car doms*))
+                                   (car rests*)
+                                   (car rngs*)))
+                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
+               ;; ... function, ... arg
+               [(and (car drests*)                     
+                     tail-bound
+                     (eq? tail-bound (cdr (car drests*)))
+                     (= (length (car doms*))
+                        (length arg-tys))
+                     (infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) 
+                            (car rngs*)))
+                => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
+               ;; if nothing matches, around the loop again
+               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
+    [(tc-result1: (Poly: vars (Function: '())))
+     (tc-error/expr #:return (ret (Un))
+                    "Function has no cases")]
+    [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
+                            (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
+     (let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
+                   [(tail-ty tail-bound) (match (tc-expr/t tail)
+                                           [(ListDots: tail-ty tail-bound)
+                                            (values tail-ty tail-bound)]
+                                           [t (values t #f)])])
+       (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
+         (define (finish substitution) (do-ret (subst-all substitution (car rngs*))))
+         (cond [(null? doms*)
+                (match f-ty 
+                  [(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
+                   (tc-error/expr #:return (ret (Un))
+                                 (string-append 
+                                  "Bad arguments to polymorphic function in apply:~n"
+                                  (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
+               ;; the actual work, when we have a * function and a list final argument
+               [(and (car rests*)
+                     (not tail-bound)
+                     (<= (length (car doms*))
+                         (length arg-tys))
+                     (infer/vararg fixed-vars (list dotted-var)
+                                   (cons tail-ty arg-tys) 
+                                   (cons (make-Listof (car rests*))
+                                         (car doms*))
+                                   (car rests*)
+                                   (car rngs*)))
+                => finish]
+               ;; actual work, when we have a * function and ... final arg
+               [(and (car rests*)
+                     tail-bound                     
+                     (<= (length (car doms*))
+                         (length arg-tys))
+                     (infer/vararg fixed-vars (list dotted-var)
+                                   (cons (make-Listof tail-ty) arg-tys)
+                                   (cons (make-Listof (car rests*))
+                                         (car doms*))
+                                   (car rests*)
+                                   (car rngs*)))
+                => finish]
+               ;; ... function, ... arg, same bound on ...
+               [(and (car drests*)
+                     tail-bound
+                     (eq? tail-bound (cdr (car drests*)))
+                     (= (length (car doms*))
+                        (length arg-tys))                     
+                     (infer fixed-vars (list dotted-var)
+                            (cons (make-ListDots tail-ty tail-bound) arg-tys)
+                            (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*))
+                            (car rngs*)))
+                => finish]
+               ;; ... function, ... arg, different bound on ...
+               [(and (car drests*)
+                     tail-bound
+                     (not (eq? tail-bound (cdr (car drests*))))
+                     (= (length (car doms*))
+                        (length arg-tys))
+                     (extend-tvars (list tail-bound (cdr (car drests*)))
+                       (extend-indexes (cdr (car drests*)) 
+                         ;; don't need to add tail-bound - it must already be an index
+                         (infer fixed-vars (list dotted-var)
+                                (cons (make-ListDots tail-ty tail-bound) arg-tys)
+                                (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*))
+                                (car rngs*)))))
+                => finish]
+               ;; ... function, (List A B C etc) arg
+               [(and (car drests*)
+                     (not tail-bound)
+                     (eq? (cdr (car drests*)) dotted-var)
+                     (= (length (car doms*))
+                        (length arg-tys))
+                     (untuple tail-ty)
+                     (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*)
+                                 (car (car drests*)) (car rngs*) (fv (car rngs*))))
+                => finish]
+               ;; if nothing matches, around the loop again
+               [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
+    [(tc-result1: (PolyDots: vars (Function: '())))
+     (tc-error/expr #:return (ret (Un))
+                    "Function has no cases")]
+    [(tc-result1: f-ty) (tc-error/expr #:return (ret (Un))
+                         "Type of argument to apply is not a function type: ~n~a" f-ty)]))
diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt
index 274a52bb..c7c59fb5 100644
--- a/collects/typed-scheme/typecheck/tc-envops.rkt
+++ b/collects/typed-scheme/typecheck/tc-envops.rkt
@@ -9,17 +9,13 @@
          (rep type-rep object-rep)
          (utils tc-utils)
          (types resolve)
-         (only-in (env type-environments lexical-env) env? update-type/lexical env-map env-props replace-props)
+         (only-in (env type-env-structs lexical-env) 
+                  env? update-type/lexical env-map env-props replace-props)
          scheme/contract scheme/match
          mzlib/trace unstable/debug unstable/struct
          (typecheck tc-metafunctions)
          (for-syntax scheme/base))
 
-(define (replace-nth l i f)
-  (cond [(null? l) (error 'replace-nth "list not long enough" l i f)]
-        [(zero? i) (cons (f (car l)) (cdr l))]
-        [else (cons (car l) (replace-nth (cdr l) (sub1 i) f))]))
-
 ;(trace replace-nth)
 
 (define/contract (update t lo)
@@ -42,15 +38,25 @@
      (make-Syntax (update t (-not-filter u x rst)))]
     
     ;; struct ops
-    [((Struct: nm par flds proc poly pred cert acc-ids maker-id) 
+    [((Struct: nm par flds proc poly pred cert maker-id) 
       (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))     
      (make-Struct nm par 
-                  (replace-nth flds idx 
-                               (lambda (e) (update e (-filter u x rst))))
-                  proc poly pred cert acc-ids maker-id)]
-    [((Struct: nm par flds proc poly pred cert acc-ids maker-id) 
+                  (list-update flds idx 
+                            (match-lambda [(fld: e acc-id #f) 
+                                           (make-fld
+                                            (update e (-filter u x rst))
+                                            acc-id #f)]
+                                          [_ (int-err "update on mutable struct field")]))
+                  proc poly pred cert maker-id)]
+    [((Struct: nm par flds proc poly pred cert maker-id) 
       (NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
-     (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (-not-filter u x rst)))) proc poly pred cert acc-ids maker-id)]
+     (make-Struct nm par (list-update flds idx 
+                                      (match-lambda [(fld: e acc-id #f) 
+                                                     (make-fld
+                                                      (update e (-not-filter u x rst))
+                                                      acc-id #f)]
+                                          [_ (int-err "update on mutable struct field")]))
+                  proc poly pred cert maker-id)]
     
     ;; otherwise
     [(t (TypeFilter: u (list) _))
@@ -70,7 +76,7 @@
   (define-values (props atoms) (combine-props fs (env-props env) flag))
   (for/fold ([Γ (replace-props env (append atoms props))]) ([f atoms])
     (match f
-      [(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)]
+      [(Bot:) (set-box! flag #f) (env-map (lambda (k v) (Un)) Γ)]
       [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x))
        (update-type/lexical (lambda (x t) (let ([new-t (update t f)])
                                             (when (type-equal? new-t (Un))
diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt
index 6a102aca..b5a2b2bc 100644
--- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt
+++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt
@@ -1,19 +1,20 @@
 #lang scheme/unit
 
 
-(require (rename-in "../utils/utils.rkt" [private private-in]))
-(require syntax/kerncase mzlib/trace
+(require (rename-in "../utils/utils.rkt" [private private-in])
+         syntax/kerncase mzlib/trace
          scheme/match (prefix-in - scheme/contract)
          "signatures.rkt" "tc-envops.rkt" "tc-metafunctions.rkt" "tc-subst.rkt"
+         "check-below.rkt" "tc-funapp.rkt"
          (types utils convenience union subtype remove-intersect type-table filter-ops)
          (private-in parse-type type-annotation)
          (rep type-rep)
          (only-in (infer infer) restrict)
          (except-in (utils tc-utils stxclass-util))
-         (env lexical-env)
-         (only-in (env type-environments) lookup current-tvars extend-env)
+         (env lexical-env type-env-structs tvar-env index-env)
          racket/private/class-internal unstable/debug
          (except-in syntax/parse id)
+         unstable/function
          (only-in srfi/1 split-at))
 
 (require (for-template scheme/base racket/private/class-internal))
@@ -34,12 +35,22 @@
     [i:boolean (-val (syntax-e #'i))]
     [i:identifier (-val (syntax-e #'i))]
     [0 -Zero]
+    [(~var i (3d (conjoin number? fixnum? positive?))) -PositiveFixnum]
+    [(~var i (3d (conjoin number? fixnum? negative?))) -NegativeFixnum]
+    [(~var i (3d (conjoin number? fixnum?))) -Fixnum]
     [(~var i (3d exact-positive-integer?)) -ExactPositiveInteger]
     [(~var i (3d exact-nonnegative-integer?)) -ExactNonnegativeInteger]
     [(~var i (3d exact-integer?)) -Integer]
-    [(~var i (3d (lambda (e) (and (number? e) (exact? e) (rational? e))))) -ExactRational]
+    [(~var i (3d (conjoin number? exact? rational?))) -ExactRational]
+    [(~var i (3d (conjoin inexact-real?
+                          (lambda (x) (or (positive? x) (zero? x)))
+                          (lambda (x) (not (eq? x -0.0))))))
+     -NonnegativeFlonum]
     [(~var i (3d inexact-real?)) -Flonum]
     [(~var i (3d real?)) -Real]
+    ;; a complex number can't have an inexact imaginary part and an exact real part
+    [(~var i (3d (conjoin number? (lambda (x) (inexact-real? (imag-part x))))))
+     -InexactComplex]
     [(~var i (3d number?)) -Number]
     [i:str -String]
     [i:char -Char]
@@ -70,9 +81,8 @@
                     [t (in-list ts)])
            (tc-literal l t)))]
        ;; errors are handled elsewhere
-       [_ (make-Vector (apply Un 
-                              (for/list ([l (syntax-e #'i)])
-                                (tc-literal l #f))))])]
+       [_ (make-HeterogenousVector (for/list ([l (syntax-e #'i)])
+                                     (generalize (tc-literal l #f))))])]
     [(~var i (3d hash?))
      (let* ([h (syntax-e #'i)]
             [ks (hash-map h (lambda (x y) (tc-literal x)))]
@@ -118,15 +128,11 @@
                (let-values ([(all-but-last last-stx) (split-last (syntax->list inst))])
                  (match (syntax-e last-stx)
                    [(cons last-ty-stx (? identifier? last-id-stx))
-                    (unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
+                    (unless (bound-index? (syntax-e last-id-stx))
                       (tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
                     (if (= (length all-but-last) (sub1 (PolyDots-n ty)))
                         (let* ([last-id (syntax-e last-id-stx)]
-                               [last-ty
-                                (parameterize ([current-tvars (extend-env (list last-id)
-                                                                          (list (make-DottedBoth (make-F last-id)))
-                                                                          (current-tvars))])
-                                  (parse-type last-ty-stx))])
+                               [last-ty (extend-tvars (list last-id) (parse-type last-ty-stx))])
                           (instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id))
                         (tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
                                        ty (sub1 (PolyDots-n ty)) (length all-but-last)))]
@@ -160,91 +166,6 @@
   (match (tc-expr/check e t)
     [(tc-result1: t) t]))
 
-(define (print-object o)
-  (match o
-    [(Empty:) "no object"]
-    [_ (format "object ~a" o)]))
-
-;; check-below : (/\ (Results Type -> Result)
-;;                   (Results Results -> Result)
-;;                   (Type Results -> Type)
-;;                   (Type Type -> Type))
-(define (check-below tr1 expected)     
-  (define (filter-better? f1 f2)
-    (match* (f1 f2)
-      [(f f) #t]
-      [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-))
-       (and (implied-atomic? f2+ f1+)
-            (implied-atomic? f2- f1-))]
-      [(_ _) #f]))
-  (define (object-better? o1 o2)
-    (match* (o1 o2)
-      [(o o) #t]
-      [(o (or (NoObject:) (Empty:))) #t]
-      [(_ _) #f]))  
-  (match* (tr1 expected)
-    ;; these two have to be first so that errors can be allowed in cases where multiple values are expected
-    [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) (tc-results: ts2 (NoFilter:) (NoObject:)))
-     (ret ts2)]
-    [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _)
-     expected]
-    
-    [((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:)))
-     (unless (= (length ts) (length ts2))
-       (tc-error/expr "Expected ~a values, but got ~a" (length ts2) (length ts)))
-     (unless (for/and ([t ts] [s ts2]) (subtype t s))
-       (tc-error/expr "Expected ~a, but got ~a" (stringify ts2) (stringify ts)))
-     (if (= (length ts) (length ts2))
-         (ret ts2 fs os)
-         (ret ts2))]
-    [((tc-result1: t1 f1 o1) (tc-result1: t2 (FilterSet: (Top:) (Top:)) (Empty:)))
-     (cond 
-       [(not (subtype t1 t2))
-        (tc-error/expr "Expected ~a, but got ~a" t2 t1)])
-     expected]
-    [((tc-result1: t1 f1 o1) (tc-result1: t2 f2 o2))
-     (cond 
-       [(not (subtype t1 t2))
-        (tc-error/expr "Expected ~a, but got ~a" t2 t1)]
-       [(and (not (filter-better? f1 f2))
-             (object-better? o1 o2))
-        (tc-error/expr "Expected result with filter ~a, got filter ~a" f2 f1)]
-       [(and (filter-better? f1 f2)
-             (not (object-better? o1 o2)))
-        (tc-error/expr "Expected result with object ~a, got object ~a" o2 o1)]
-       [(and (not (filter-better? f1 f2))
-             (not (object-better? o1 o2)))
-        (tc-error/expr "Expected result with filter ~a and ~a, got filter ~a and ~a" f2 (print-object o2) f1 (print-object o1))])
-     expected]
-    [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound))
-     (unless (andmap subtype t1 t2)
-       (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
-     expected]
-    [((tc-results: t1 fs os) (tc-results: t2 fs os))
-     (unless (= (length t1) (length t2))
-       (tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1)))
-     (unless (for/and ([t t1] [s t2]) (subtype t s))
-       (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
-     expected]
-    [((tc-result1: t1 f o) (? Type? t2))
-     (unless (subtype t1 t2)
-       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
-     (ret t2 f o)]
-    [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:)))
-     (unless (subtype t1 t2)
-       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
-     t1]
-    [((? Type? t1) (tc-result1: t2 f o))
-     (if (subtype t1 t2)
-         (tc-error/expr "Expected result with filter ~a and ~a, got ~a" f (print-object o) t1)
-         (tc-error/expr "Expected ~a, but got ~a" t2 t1))
-     t1]
-    [((? Type? t1) (? Type? t2))
-     (unless (subtype t1 t2)
-       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
-     expected]
-    [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)]))
-
 (define (tc-expr/check/type form expected)
   #;(syntax? Type/c . -> . tc-results?)
   (tc-expr/check form (ret expected)))
@@ -255,23 +176,24 @@
     (unless (syntax? form) 
       (int-err "bad form input to tc-expr: ~a" form))
     ;; typecheck form
-    (let loop ([form form] [expected expected] [checked? #f])
-      (cond [(type-ascription form) 
+    (let loop ([form* form] [expected expected] [checked? #f])
+      (cond [(type-ascription form*) 
              => 
              (lambda (ann)
-               (let* ([r (tc-expr/check/internal form ann)]
+               (let* ([r (tc-expr/check/internal form* ann)]
                       [r* (check-below r expected)])
-                 (add-typeof-expr form expected)
+                 ;; add this to the *original* form, since the newer forms aren't really in the program
+                 (add-typeof-expr form ann)
                  ;; around again in case there is an instantiation
                  ;; remove the ascription so we don't loop infinitely
-                 (loop (remove-ascription form) r* #t)))]
-            [(syntax-property form 'type-inst)
+                 (loop (remove-ascription form*) r* #t)))]
+            [(syntax-property form* 'type-inst)
              ;; check without property first
              ;; to get the appropriate type to instantiate
-             (match (tc-expr (syntax-property form 'type-inst #f))
+             (match (tc-expr (syntax-property form* 'type-inst #f))
                [(tc-results: ts fs os)
                 ;; do the instantiation on the old type
-                (let* ([ts* (do-inst form ts)]
+                (let* ([ts* (do-inst form* ts)]
                        [ts** (ret ts* fs os)])
                   (add-typeof-expr form ts**)
                   ;; make sure the new type is ok
@@ -280,27 +202,10 @@
                [ty (add-typeof-expr form ty) ty])]
             ;; nothing to see here
             [checked? expected]
-            [else (let ([t (tc-expr/check/internal form expected)])
+            [else (let ([t (tc-expr/check/internal form* expected)])
                     (add-typeof-expr form t)
                     t)]))))
 
-#;
-(define (tc-or e1 e2 or-part [expected #f])
-  (match (single-value e1)
-    [(tc-result1: t1 (and f1 (FilterSet: fs+ fs-)) o1)
-     (let*-values ([(flag+ flag-) (values (box #t) (box #t))])
-       (match-let* ([(tc-result1: t2 f2 o2) (with-lexical-env 
-                                             (env+ (lexical-env) fs+ flag+) 
-                                             (with-lexical-env/extend 
-                                              (list or-part) (list (restrict t1 (-val #f))) (single-value e2 expected)))]
-                    [t1* (remove t1 (-val #f))]
-                    [f1* (-FS null (list (make-Bot)))])
-         ;; if we have the same number of values in both cases
-         (let ([r (combine-filter f1 f1* f2 t1* t2 o1 o2)])
-           (if expected 
-               (check-below r expected)
-               r))))]))
-
 ;; tc-expr/check : syntax tc-results -> tc-results
 (define (tc-expr/check/internal form expected)
   (parameterize ([current-orig-stx form])
@@ -384,11 +289,11 @@
          (and (identifier? #'name*) (free-identifier=? #'name #'name*))
          (match expected
            [(tc-result1: t)
-            (with-lexical-env/extend (list #'name) (list t) (tc-expr/check/internal #'expr expected))]
+            (with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))]
            [(tc-results: ts) 
             (tc-error/expr #:return (ret (Un)) "Expected ~a values, but got only 1" (length ts))])]
         [(letrec-values ([(name ...) expr] ...) . body)
-         (tc/letrec-values/check #'((name ...) ...) #'(expr ...) #'body form expected)]        
+         (tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form expected)]        
         ;; other
         [_ (tc-error/expr #:return (ret expected) "cannot typecheck unknown form : ~a~n" (syntax->datum form))]
         ))))
diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-scheme/typecheck/tc-funapp.rkt
new file mode 100644
index 00000000..63f12298
--- /dev/null
+++ b/collects/typed-scheme/typecheck/tc-funapp.rkt
@@ -0,0 +1,170 @@
+#lang racket/base
+
+(require (rename-in "../utils/utils.rkt" [infer r:infer])
+         "signatures.rkt" "tc-metafunctions.rkt"
+         "tc-app-helper.rkt" "find-annotation.rkt"
+         "tc-subst.rkt" "check-below.rkt"
+         (prefix-in c: racket/contract)
+         syntax/parse racket/match racket/list 
+	 unstable/sequence unstable/debug
+         ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
+         racket/bool
+         racket/unsafe/ops
+         (only-in racket/private/class-internal make-object do-make-object)
+         (only-in '#%kernel [apply k:apply])
+         ;; end fixme
+         (for-syntax syntax/parse racket/base (utils tc-utils))
+         (private type-annotation)
+         (types utils abbrev union subtype resolve convenience type-table substitute)
+         (utils tc-utils)
+         (only-in srfi/1 alist-delete)
+         (except-in (env type-env-structs tvar-env index-env) extend)
+         (rep type-rep filter-rep object-rep rep-utils)
+         (r:infer infer)
+         '#%paramz
+         (for-template
+          racket/unsafe/ops
+          (only-in '#%kernel [apply k:apply])
+          "internal-forms.rkt" racket/base racket/bool '#%paramz
+          (only-in racket/private/class-internal make-object do-make-object)))
+
+(provide tc/funapp)
+
+(define-syntax (handle-clauses stx)
+  (syntax-parse stx
+    [(_  (lsts ... arrs) f-stx args-stx pred infer t argtys expected)
+     (with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))])
+       (syntax/loc stx
+         (or (for/or ([vars lsts] ... [a arrs]
+                      #:when (pred vars ... a))
+               (let ([substitution (infer vars ... a)])
+                 (and substitution
+                      (tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f))))
+             (poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))]))
+
+(d/c (tc/funapp f-stx args-stx ftype0 argtys expected)
+  (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)
+  (match* (ftype0 argtys)
+    ;; we special-case this (no case-lambda) for improved error messages
+    [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: _) rest #f kws)))))) argtys)
+     (tc/funapp1 f-stx args-stx a argtys expected)]
+    [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...)))))
+      (and argtys (list (tc-result1: argtys-t) ...)))
+     (or 
+      ;; find the first function where the argument types match
+      (for/first ([dom doms] [rng rngs] [rest rests] [a arrs]
+                  #:when (subtypes/varargs argtys-t dom rest))
+        ;; then typecheck here
+        ;; we call the separate function so that we get the appropriate filters/objects
+        (tc/funapp1 f-stx args-stx a argtys expected #:check #f))
+      ;; if nothing matched, error
+      (tc-error/expr 
+       #:return (or expected (ret (Un)))
+       (string-append "No function domains matched in function application:\n"
+                      (domain-mismatches t doms rests drests rngs argtys-t #f #f))))]
+    ;; any kind of dotted polymorphic function without mandatory keyword args
+    [((tc-result1: (and t (PolyDots: 
+                           (and vars (list fixed-vars ... dotted-var))
+                           (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))))
+      (list (tc-result1: argtys-t) ...))
+     (handle-clauses (doms rngs rests drests arrs) f-stx args-stx
+                     ;; only try inference if the argument lengths are appropriate
+                     (lambda (dom _ rest drest a) 
+                       (cond [rest (<= (length dom) (length argtys))]
+                             [drest (and (<= (length dom) (length argtys))
+                                         (eq? dotted-var (cdr drest)))]
+                             [else (= (length dom) (length argtys))]))
+                     ;; only try to infer the free vars of the rng (which includes the vars in filters/objects)
+                     ;; note that we have to use argtys-t here, since argtys is a list of tc-results
+                     (lambda (dom rng rest drest a)
+                       (cond 
+                         [drest
+                          (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) 
+                                       #:expected (and expected (tc-results->values expected)))]
+                         [rest 
+                          (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng
+                                        (and expected (tc-results->values expected)))]
+                         ;; no rest or drest
+                         [else (infer fixed-vars (list dotted-var) argtys-t dom rng
+                                      (and expected (tc-results->values expected)))]))
+                     t argtys expected)]
+    ;; regular polymorphic functions without dotted rest, and without mandatory keyword args
+    [((tc-result1: 
+       (and t
+            (Poly: 
+             vars 
+             (Function: (list (and arrs (arr: doms rngs rests (and drests #f) (list (Keyword: _ _ #f) ...))) ...)))))
+      (list (tc-result1: argtys-t) ...))
+     (handle-clauses (doms rngs rests arrs) f-stx args-stx
+                     ;; only try inference if the argument lengths are appropriate
+                     (λ (dom _ rest a) ((if rest <= =) (length dom) (length argtys)))
+                     ;; only try to infer the free vars of the rng (which includes the vars in filters/objects)
+                     ;; note that we have to use argtys-t here, since argtys is a list of tc-results
+                     (λ (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected))))
+                     t argtys expected)]
+    ;; procedural structs
+    [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _)
+     (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)]
+    ;; parameters are functions too
+    [((tc-result1: (Param: in out)) (list)) (ret out)]
+    [((tc-result1: (Param: in out)) (list (tc-result1: t)))
+     (if (subtype t in) 
+         (ret -Void true-filter)
+         (tc-error/expr #:return (ret -Void true-filter)
+                        "Wrong argument to parameter - expected ~a and got ~a" in t))]
+    [((tc-result1: (Param: _ _)) _) 
+     (tc-error/expr #:return (ret (Un))
+                    "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
+                    (length argtys))]
+    ;; resolve names, polymorphic apps, mu, etc
+    [((tc-result1: (? needs-resolving? t) f o) _)
+     (tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)]
+    ;; a union of functions can be applied if we can apply all of the elements
+    [((tc-result1: (Union: (and ts (list (Function: _) ...)))) _)
+     (ret (for/fold ([result (Un)]) ([fty ts])            
+            (match (tc/funapp f-stx args-stx (ret fty) argtys expected)
+              [(tc-result1: t) (Un result t)])))]
+    ;; error type is a perfectly good fcn type
+    [((tc-result1: (Error:)) _) (ret (make-Error))]
+    ;; otherwise fail
+    [((tc-result1: f-ty) _) 
+     (tc-error/expr #:return (ret (Un))
+                    "Cannot apply expression of type ~a, since it is not a function type" f-ty)]))
+
+
+;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
+(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
+  ((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?)
+  (match* (ftype0 argtys)
+    ;; we check that all kw args are optional
+    [((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...)))
+      (list (tc-result1: t-a phi-a o-a) ...))
+     (when check?
+       (cond [(and (not rest) (not (= (length dom) (length t-a))))
+              (tc-error/expr #:return (ret t-r)
+                             "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
+             [(and rest (< (length t-a) (length dom)))
+              (tc-error/expr #:return (ret t-r)
+                             "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
+       (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] 
+             [a (in-list (syntax->list args-stx))]
+             [arg-t (in-list t-a)])
+         (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
+     (let* ([dom-count (length dom)]
+            [arg-count (+ dom-count (if rest 1 0) (length kws))])
+       (let-values
+           ([(o-a t-a) (for/lists (os ts)
+                         ([nm (in-range arg-count)]
+                          [oa (in-sequence-forever (in-list o-a) (make-Empty))]
+                          [ta (in-sequence-forever (in-list t-a) (Un))])
+                         (values (if (>= nm dom-count) (make-Empty) oa)
+                                 ta))])
+         (define-values (t-r f-r o-r)
+           (for/lists (t-r f-r o-r) 
+             ([r (in-list results)])
+             (open-Result r o-a t-a)))
+         (ret t-r f-r o-r)))]
+    [((arr: _ _ _ drest '()) _)
+     (int-err "funapp with drest args ~a ~a NYI" drest argtys)]
+    [((arr: _ _ _ _ kws) _)
+     (int-err "funapp with keyword args ~a NYI" kws)]))
diff --git a/collects/typed-scheme/typecheck/tc-if.rkt b/collects/typed-scheme/typecheck/tc-if.rkt
index aa50b85b..c415ef8b 100644
--- a/collects/typed-scheme/typecheck/tc-if.rkt
+++ b/collects/typed-scheme/typecheck/tc-if.rkt
@@ -1,18 +1,16 @@
-#lang scheme/unit
-
-
-(require (rename-in "../utils/utils.rkt" [infer r:infer]))
-(require "signatures.rkt"
+#lang racket/unit
+(require (rename-in "../utils/utils.rkt" [infer r:infer])
+         "signatures.rkt" "check-below.rkt"
          (rep type-rep filter-rep object-rep)
          (rename-in (types convenience subtype union utils comparison remove-intersect abbrev filter-ops)
                     [remove *remove])
-         (env lexical-env type-environments)
+         (env lexical-env type-env-structs)
          (r:infer infer)
 	 (utils tc-utils)
          (typecheck tc-envops tc-metafunctions)
          syntax/kerncase
-         mzlib/trace unstable/debug
-         scheme/match)
+         racket/trace unstable/debug
+         racket/match)
 
 ;; if typechecking   
 (import tc-expr^)
diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt
index f2438b08..b213cce5 100644
--- a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt
+++ b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt
@@ -3,7 +3,7 @@
 (require (rename-in "../utils/utils.rkt" [infer r:infer])
          "signatures.rkt"
          "tc-metafunctions.rkt"
-         "tc-subst.rkt"
+         "tc-subst.rkt" "check-below.rkt"
          mzlib/trace
          scheme/list
          syntax/private/util syntax/stx
@@ -13,7 +13,7 @@
                     [make-arr* make-arr])
          (private type-annotation)
          (types abbrev utils)
-	 (env type-environments lexical-env)
+	 (env type-env-structs lexical-env tvar-env index-env)
 	 (utils tc-utils)
          unstable/debug
          scheme/match)
@@ -87,15 +87,15 @@
       [(not rest)
        (check-body)]
       [drest
-       (with-dotted-env/extend
-        rest (car drest) (cdr drest)
+       (with-lexical-env/extend
+        (list rest) (list (make-ListDots (car drest) (cdr drest)))
         (check-body))]
       [(dotted? rest)
        =>
        (lambda (b)
          (let ([dty (get-type rest #:default Univ)])
-           (with-dotted-env/extend
-            rest dty b
+           (with-lexical-env/extend
+            (list rest) (list (make-ListDots dty b))
             (check-body))))]
       [else
        (let ([rest-type (cond
@@ -138,27 +138,21 @@
          [(dotted? #'rest)
           =>
           (lambda (bound)
-            (unless (Dotted? (lookup (current-tvars) bound
-                                     (lambda _ (tc-error/stx #'rest
-                                                             "Bound on ... type (~a) was not in scope" bound))))
-              (tc-error "Bound on ... type (~a) is not an appropriate type variable" bound))
-            (let ([rest-type (parameterize ([current-tvars 
-                                             (extend-env (list bound) 
-                                                         (list (make-DottedBoth (make-F bound)))
-                                                         (current-tvars))])
+            (unless (bound-index? bound)
+              (if (bound-tvar? bound)
+                  (tc-error "Bound on ... type (~a) is not an appropriate type variable" bound)
+                  (tc-error/stx #'rest "Bound on ... type (~a) was not in scope" bound)))
+            (let ([rest-type (extend-tvars (list bound)
                                (get-type #'rest #:default Univ))])
               (with-lexical-env/extend 
-               arg-list
-               arg-types
-               (parameterize ([dotted-env (extend-env (list #'rest)
-                                                      (list (cons rest-type bound))
-                                                      (dotted-env))])
-                 (make-lam-result
-                       (map list arg-list arg-types)
-                       null
-                       #f
-                       (cons #'rest (cons rest-type bound))
-                       (tc-exprs (syntax->list body)))))))]
+               (cons #'rest arg-list)
+               (cons (make-ListDots rest-type bound) arg-types)
+               (make-lam-result
+                (map list arg-list arg-types)
+                null
+                #f
+                (cons #'rest (cons rest-type bound))
+                (tc-exprs (syntax->list body))))))]
          [else
           (let ([rest-type (get-type #'rest #:default Univ)])
             (with-lexical-env/extend 
@@ -255,9 +249,7 @@
                         "Expected a polymorphic function without ..., but given function had ..."))
                      (or (and p (map syntax-e (syntax->list p)))
                          ns))]
-            [literal-tvars tvars]
-            [new-tvars (map make-F literal-tvars)]
-            [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
+            [ty (extend-tvars tvars
                   (maybe-loop form formals bodies (ret expected*)))])
        ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
        t)]
@@ -271,31 +263,23 @@
                     (values var dvar)]
                    [_ (tc-error "Expected a polymorphic function with ..., but given function had no ...")])
                  (values ns dvar)))])
-       (let* ([literal-tvars tvars]
-              [new-tvars (map make-F literal-tvars)]
-              [ty (parameterize ([current-tvars (extend-env (cons dotted literal-tvars)
-                                                            (cons (make-Dotted (make-F dotted))
-                                                                  new-tvars)
-                                                            (current-tvars))])
-                    (maybe-loop form formals bodies (ret expected*)))])
-         t))]
+       ;; check the body for side effect
+       (extend-indexes dotted 
+         (extend-tvars tvars
+           (maybe-loop form formals bodies (ret expected*))))
+       t)]
     [#f
      (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda)))
        [(list tvars ... dotted-var '...)
-        (let* ([literal-tvars tvars]
-               [new-tvars (map make-F literal-tvars)]
-               [ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars)
-                                                             (cons (make-Dotted (make-F dotted-var)) new-tvars)
-                                                             (current-tvars))])
-                     (tc/mono-lambda/type formals bodies #f))])
-          (make-PolyDots (append literal-tvars (list dotted-var)) ty))]
+        (let* ([ty (extend-indexes dotted-var
+                     (extend-tvars tvars
+                       (tc/mono-lambda/type formals bodies #f)))])
+          (make-PolyDots (append tvars (list dotted-var)) ty))]
        [tvars
-        (let* ([literal-tvars tvars]
-               [new-tvars (map make-F literal-tvars)]
-               [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
+        (let* ([ty (extend-tvars tvars
                      (tc/mono-lambda/type formals bodies #f))])
           ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
-          (make-Poly literal-tvars ty))])]
+          (make-Poly tvars ty))])]
     [(tc-result1: t) 
      (unless (check-below (tc/plambda form formals bodies #f) t)
        (tc-error/expr #:return expected
diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt
index 23cf379a..cbd401cc 100644
--- a/collects/typed-scheme/typecheck/tc-let-unit.rkt
+++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt
@@ -1,18 +1,19 @@
-#lang scheme/unit
+#lang racket/unit
 
 (require (rename-in "../utils/utils.rkt" [infer r:infer]))
 (require "signatures.rkt" "tc-metafunctions.rkt" "tc-subst.rkt"
+         "check-below.rkt"
          (types utils convenience)
          (private type-annotation parse-type)
-	 (env lexical-env type-alias-env type-env type-environments)
+	 (env lexical-env type-alias-env global-env type-env-structs)
          (rep type-rep)
          syntax/free-vars
-         mzlib/trace unstable/debug
-         scheme/match (prefix-in c: scheme/contract)
-         (except-in scheme/contract -> ->* one-of/c)
+         racket/trace unstable/debug
+         racket/match (prefix-in c: racket/contract)
+         (except-in racket/contract -> ->* one-of/c)
          syntax/kerncase syntax/parse
          (for-template 
-          scheme/base
+          racket/base
           "internal-forms.rkt"))
 
 (require (only-in srfi/1/list s:member))
@@ -83,12 +84,6 @@
           expected)
          (run (tc-exprs (syntax->list body)))))))
 
-(define (tc/letrec-values/check namess exprs body form expected)
-  (tc/letrec-values/internal namess exprs body form expected))
-
-(define (tc/letrec-values namess exprs body form)
-  (tc/letrec-values/internal namess exprs body form #f))
-
 (define (tc-expr/maybe-expected/t e name)
   (define expecteds
     (map (lambda (stx) (lookup-type stx (lambda () #f))) name))
@@ -102,7 +97,7 @@
      (tc-expr e)))
   tcr)
 
-(define (tc/letrec-values/internal namess exprs body form expected)
+(define (tc/letrec-values namess exprs body form [expected #f])
   (let* ([names (map syntax->list (syntax->list namess))]
          [orig-flat-names (apply append names)]
          [exprs (syntax->list exprs)]
diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt
index a6cc8330..c43bce64 100644
--- a/collects/typed-scheme/typecheck/tc-structs.rkt
+++ b/collects/typed-scheme/typecheck/tc-structs.rkt
@@ -1,17 +1,22 @@
 #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)
+	 (types convenience utils union resolve abbrev substitute type-table)
+	 (env global-env type-env-structs type-name-env tvar-env)
 	 (utils tc-utils)
          "def-binding.rkt"
          syntax/kerncase
          syntax/struct
          mzlib/trace      
          unstable/debug
+         racket/function
          scheme/match
+         (only-in racket/contract
+                  listof any/c or/c
+                  [->* c->*]
+                  [-> c->])
          (for-syntax scheme/base))
 
 
@@ -77,35 +82,54 @@
 ;; Option[Struct-Ty] -> Listof[Type]
 (define (get-parent-flds p)
   (match p
-    [(Struct: _ _ flds _ _ _ _ _ _) flds]
+    [(Struct: _ _ flds _ _ _ _ _) flds]
     [(Name: n) (get-parent-flds (lookup-type-name n))]
     [#f null]))
 
 
 ;; construct all the various types for structs, and then register the approriate names
-;; identifier listof[identifier] type listof[Type] listof[Type] boolean -> Type listof[Type] listof[Type]
-(define (mk/register-sty nm flds parent parent-field-types types 
-                         #:wrapper [wrapper values] 
-                         #:type-wrapper [type-wrapper values]
-                         #:pred-wrapper [pred-wrapper values]
-                         #:mutable [setters? #f]
-                         #:struct-info [si #f]
-                         #:proc-ty [proc-ty #f]
-                         #:maker [maker* #f]
-                         #:predicate [pred* #f]
-                         #:constructor-return [cret #f]
-                         #:poly? [poly? #f]
-                         #:type-only [type-only #f])
+;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> Type listof[Type] listof[Type]
+(d/c (mk/register-sty nm flds parent parent-fields types 
+                      #:wrapper [wrapper values] 
+                      #:type-wrapper [type-wrapper values]
+                      #:pred-wrapper [pred-wrapper values]
+                      #:mutable [setters? #f]
+                      #:struct-info [si #f]
+                      #:proc-ty [proc-ty #f]
+                      #:maker [maker* #f]
+                      #:predicate [pred* #f]
+                      #:constructor-return [cret #f]
+                      #:poly? [poly? #f]
+                      #:type-only [type-only #f])
+     (c->* (identifier? (listof identifier?) (or/c Type/c #f) (listof fld?) (listof Type/c)) 
+           (#:wrapper procedure?
+            #:type-wrapper procedure?
+            #:pred-wrapper procedure?
+            #:mutable boolean?
+            #:struct-info any/c
+            #:proc-ty (or/c #f Type/c)
+            #:maker (or/c #f identifier?)
+            #:predicate (or/c #f identifier?)
+            #:constructor-return (or/c #f Type/c)
+            #:poly? (or/c #f (listof symbol?))
+            #:type-only boolean?)
+           any/c)
   ;; create the approriate names that define-struct will bind
   (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
   (let* ([name (syntax-e nm)]
-         [fld-types (append parent-field-types types)]
-         [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters (or maker* maker))]
+         [fld-names flds]
+         [this-flds (for/list ([t (in-list types)]
+                               [g (in-list getters)])
+                       (make-fld t g setters?))]
+         [flds (append parent-fields this-flds)]
+         [sty (make-Struct name parent flds proc-ty poly? pred
+                           (syntax-local-certifier) (or maker* maker))]
          [external-fld-types/no-parent types]
-         [external-fld-types fld-types])
+         [external-fld-types (map fld-t flds)])
     (if type-only
         (register-type-name nm (wrapper sty))
-        (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? 
+        (register-struct-types nm sty fld-names external-fld-types
+                               external-fld-types/no-parent setters? 
                                #:wrapper wrapper
                                #:type-wrapper type-wrapper
                                #:pred-wrapper pred-wrapper
@@ -118,39 +142,64 @@
 ;; generate names, and register the approriate types give field types and structure type
 ;; optionally wrap things
 ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
-(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
-                               #:wrapper [wrapper values]
-                               #:struct-info [si #f]
-                               #:type-wrapper [type-wrapper values]
-                               #:pred-wrapper [pred-wrapper values]
-                               #:maker [maker* #f]
-                               #:predicate [pred* #f]
-                               #:poly? [poly? #f]
-                               #:constructor-return [cret #f])
+(d/c (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
+                            #:wrapper [wrapper values]
+                            #:struct-info [si #f]
+                            #:type-wrapper [type-wrapper values]
+                            #:pred-wrapper [pred-wrapper values]
+                            #:maker [maker* #f]
+                            #:predicate [pred* #f]
+                            #:poly? [poly? #f]
+                            #:constructor-return [cret #f])
+     (c->* (identifier? Struct? (listof identifier?) (listof Type/c) (listof Type/c) boolean?)
+           (#:wrapper procedure?
+            #:type-wrapper procedure?
+            #:pred-wrapper procedure?
+            #:struct-info any/c
+            #:maker (or/c #f identifier?)
+            #:predicate (or/c #f identifier?)
+            #:constructor-return (or/c #f Type/c)
+            #:poly? (or/c #f (listof symbol?)))
+           list?)
   ;; create the approriate names that define-struct will bind
   (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)))
+  (define parent-count (- (length external-fld-types) (length external-fld-types/no-parent)))
   ;; the list of names w/ types
   (define bindings
-    (append 
-     (list 
-      (cons struct-type-id
-            (make-StructType sty))
-      (cons (or maker* maker)
-            (wrapper (->* external-fld-types (if cret cret name))))
-      (cons (or pred* pred)
-            (make-pred-ty (if (and setters? poly?)
-                              (make-StructTop sty)
-                              (pred-wrapper name)))))
-     (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
-       (let ([func (if setters? 
-                       (->* (list name) t)
-		       (->acc (list name) t (list (make-StructPE name i))))])
-         (cons g (wrapper func))))
-     (if setters?
-         (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent)
-         null)))
+    (list* 
+     (cons struct-type-id
+           (make-StructType sty))
+     (cons (or maker* maker)
+           (wrapper (->* external-fld-types (if cret cret name))))
+     (cons (or pred* pred)
+           (make-pred-ty (if (not covariant?)
+                             (make-StructTop sty)
+                             (pred-wrapper name))))
+     (append
+      (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)])
+        (let* ([path (make-StructPE name i)]
+               [func (if setters? 
+                         (->* (list name) t)
+                         (->acc (list name) t (list path)))])
+          (add-struct-fn! g path #f)
+          (cons g (wrapper func))))
+      (if setters?
+          (for/list ([g (in-list setters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)])
+            (add-struct-fn! g (make-StructPE name i) #t)        
+            (cons g (wrapper (->* (list name t) -Void))))
+          null))))
   (register-type-name nm (wrapper sty))
   (cons
    (make-def-struct-stx-binding nm si)
@@ -162,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)
+(define (tc/poly-struct vars nm/par flds tys #:maker [maker #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
@@ -171,10 +220,10 @@
   ;; parse the types
   (define types
     ;; add the type parameters of this structure to the tvar env
-    (parameterize ([current-tvars (extend-env tvars new-tvars (current-tvars))]
-                   [current-poly-struct `#s(poly ,nm ,new-tvars)])
-      ;; parse the field types
-      (map parse-type tys)))
+    (extend-tvars tvars
+      (parameterize ([current-poly-struct `#s(poly ,nm ,new-tvars)])
+        ;; parse the field types
+        (map parse-type tys))))
   ;; instantiate the parent if necessary, with new-tvars
   (define concrete-parent 
     (if (Poly? parent)
@@ -186,19 +235,28 @@
   ;; that the outside world will see
   ;; then register them
   (mk/register-sty nm flds parent-name parent-field-types types
+                   #:maker maker
                    ;; wrap everything in the approriate forall
-                   #: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))
+                   #:wrapper (λ (t) (make-Poly tvars t))
+                   #:type-wrapper (λ (t) (make-App t new-tvars #f))
+                   #:pred-wrapper (λ (t) (subst-all (make-simple-substitution tvars (map (const Univ) tvars)) t))
+                   #:poly? tvars))
 
 
 ;; 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] #:mutable [mutable #f]
-                   #:predicate [pred #f]
-                   #:type-only [type-only #f])
+(d/c (tc/struct nm/par flds tys [proc-ty #f] 
+                #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
+                #:predicate [pred #f]
+                #:type-only [type-only #f])
+     (c->* (syntax? (listof identifier?) (listof syntax?))
+           ((or/c #f syntax?)
+            #:maker any/c
+            #:mutable boolean?
+            #:constructor-return any/c
+            #:predicate any/c
+            #:type-only boolean?)
+           any/c)
   ;; 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
@@ -222,9 +280,13 @@
 ;; register a struct type
 ;; convenience function for built-in structs
 ;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void
-(define (tc/builtin-struct nm parent flds tys parent-tys)
-  (let ([parent* (if parent (make-Name parent) #f)])
-    (mk/register-sty nm flds parent* parent-tys tys
+(d/c (tc/builtin-struct nm parent flds tys #;parent-tys)
+     (c-> identifier? (or/c #f identifier?) (listof identifier?)
+          (listof Type/c) #;(listof fld?)
+          any/c)
+  (let* ([parent-name (if parent (make-Name parent) #f)]
+         [parent-flds (if parent (get-parent-flds parent-name) null)])
+    (mk/register-sty nm flds parent-name parent-flds tys
                      #:mutable #t)))
 
 ;; syntax for tc/builtin-struct
@@ -233,11 +295,9 @@
     [(_ (nm par) ([fld : ty] ...) (par-ty ...))
      #'(tc/builtin-struct #'nm #'par
                           (list #'fld ...)
-                          (list ty ...)
-                          (list par-ty ...))]
-    [(_ nm ([fld : ty] ...) (par-ty ...))
+                          (list ty ...))]
+    [(_ nm ([fld : ty] ...))
      #'(tc/builtin-struct #'nm #f
                           (list #'fld ...)
-                          (list ty ...)
-                          (list par-ty ...))]))
+                          (list ty ...))]))
 
diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt
index 7db4b125..5acdfdbb 100644
--- a/collects/typed-scheme/typecheck/tc-toplevel.rkt
+++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt
@@ -11,14 +11,15 @@
          ;; to appease syntax-parse
          "internal-forms.rkt"
          (rep type-rep)
-         (types utils convenience)
+         (types utils convenience type-table)
          (private parse-type type-annotation type-contract)
-         (env type-env init-envs type-name-env type-alias-env lexical-env)
-         unstable/mutated-vars syntax/id-table
+         (env global-env init-envs type-name-env type-alias-env lexical-env)
+	 unstable/mutated-vars syntax/id-table
          (utils tc-utils)
          "provide-handling.rkt"
          "def-binding.rkt"
          (prefix-in c: racket/contract)
+         racket/dict         
          (for-template
           "internal-forms.rkt"
           unstable/location
@@ -26,15 +27,13 @@
           scheme/base))
 
 (c:provide/contract 
- [type-check (syntax? . c:-> . syntax?)] 
+ [type-check (syntax? . c:-> . syntax?)]
+ [tc-module (syntax? . c:-> . syntax?)]
  [tc-toplevel-form (syntax? . c:-> . c:any/c)])
 
 (define unann-defs (make-free-id-table))
 
 (define (tc-toplevel/pass1 form)
-  ;(printf "form-top: ~a~n" form)
-  ;; first, find the mutated variables:
-  (find-mutated-vars form)
   (parameterize ([current-orig-stx form])
     (syntax-parse form
       #:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal 
@@ -73,7 +72,7 @@
       
       [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
        (let* ([t (parse-type #'ty)]
-              [flds (Struct-flds (lookup-type-name (Name-id t)))]
+              [flds (map fld-t (Struct-flds (lookup-type-name (Name-id t))))]
               [mk-ty (flds #f . ->* . t)])
          (register-type #'nm mk-ty)
          (list (make-def-binding #'nm mk-ty)))]
@@ -93,6 +92,16 @@
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) 
 		  #:maker #'m #:constructor-return #'t)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
+						#:maker m)) 
+                                (#%plain-app values)))
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) 
+		  #:maker #'m)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...)
+						#:maker m)) 
+                                (#%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 nm ([fld : ty] ...) #:type-only))
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
@@ -126,16 +135,14 @@
            [(andmap (lambda (s) (lookup-type s (lambda () #f))) vars)
             (for-each finish-register-type vars)
             (map (lambda (s) (make-def-binding s (lookup-type s))) vars)]
-           ;; special case to infer types for top level defines - should handle the multiple values case here
-           [(= 1 (length vars))
-            (match (tc-expr #'expr)
-              [(tc-result1: t)
-               (register-type (car vars) t)
-               (free-id-table-set! unann-defs (car vars) #t)
-               (list (make-def-binding (car vars) t))]
-              [t (int-err "~a is not a tc-result" t)])]
+           ;; special case to infer types for top level defines
            [else
-            (tc-error "Untyped definition : ~a" (map syntax-e vars))]))]
+            (match (get-type/infer vars #'expr tc-expr tc-expr/check)
+              [(tc-results: ts)
+	       (for/list ([i (in-list vars)] [t (in-list ts)])
+		 (register-type i t)
+		 (free-id-table-set! unann-defs i #t)
+		 (make-def-binding i t))])]))]
       
       ;; to handle the top-level, we have to recur into begins
       [(begin . rest)
@@ -259,24 +266,56 @@
     ;; do pass 1, and collect the defintions
     (define defs (apply append (filter list? (map tc-toplevel/pass1 forms))))
     ;; separate the definitions into structures we'll handle for provides    
-    (define stx-defs (filter def-stx-binding? defs))
-    (define val-defs (filter def-binding? defs))
+    (define def-tbl
+      (for/fold ([h (make-immutable-free-id-table)])
+        ([def (in-list defs)])
+        (dict-set h (binding-name def) def)))
     ;; typecheck the expressions and the rhss of defintions
     (for-each tc-toplevel/pass2 forms)
     ;; check that declarations correspond to definitions
     (check-all-registered-types)
     ;; report delayed errors
     (report-all-errors)
+    (define syntax-provide? #f)
+    (define provide-tbl
+      (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)])
+        (syntax-parse p #:literals (#%provide)
+          [(#%provide form ...)
+           (for/fold ([h h]) ([f (syntax->list #'(form ...))])
+             (parameterize ([current-orig-stx f])
+               (syntax-parse f
+                 [i:id 
+                  (when (def-stx-binding? (dict-ref def-tbl #'i #f))
+                    (set! syntax-provide? #t))
+                  (dict-set h #'i #'i)]
+                 [((~datum rename) in out)
+                  (when (def-stx-binding? (dict-ref def-tbl #'in #f))
+                    (set! syntax-provide? #t))
+                  (dict-set h #'in #'out)]
+                 [((~datum protect) . _)
+                  (tc-error "provide: protect not supported by Typed Scheme")]
+                 [_ (int-err "unknown provide form")])))]
+          [_ (int-err "non-provide form! ~a" (syntax->datum p))])))
     ;; compute the new provides
     (with-syntax*
         ([the-variable-reference (generate-temporary #'blame)]
-         [((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)])
+         [(new-provs ...) 
+          (generate-prov def-tbl provide-tbl #'the-variable-reference)])
       #`(begin
-          (define the-variable-reference (quote-module-path))
-           #,(env-init-code)
+          #,(if (null? (syntax-e #'(new-provs ...)))
+                #'(begin)
+                #'(define the-variable-reference (quote-module-path)))
+           #,(env-init-code syntax-provide? provide-tbl def-tbl)
            #,(tname-env-init-code)
            #,(talias-env-init-code)
-           (begin new-provs ... ...)))))
+           (begin-for-syntax #,(make-struct-table-code))
+           (begin new-provs ...)))))
+
+;; typecheck a whole module
+;; syntax -> syntax
+(define (tc-module stx)
+  (syntax-parse stx
+    [(pmb . forms) (type-check #'forms)]))
 
 ;; typecheck a top-level form
 ;; used only from #%top-interaction
diff --git a/collects/typed-scheme/typecheck/typechecker.rkt b/collects/typed-scheme/typecheck/typechecker.rkt
index 1434e0b9..9a2d2962 100644
--- a/collects/typed-scheme/typecheck/typechecker.rkt
+++ b/collects/typed-scheme/typecheck/typechecker.rkt
@@ -8,10 +8,10 @@
                   define-values/invoke-unit/infer link)
          "signatures.rkt"
          "tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt"
-         "tc-let-unit.rkt" "tc-dots-unit.rkt"
+         "tc-let-unit.rkt" "tc-apply.rkt"
          "tc-expr-unit.rkt" "check-subforms-unit.rkt")
 
 (provide-signature-elements tc-expr^ check-subforms^)
 
 (define-values/invoke-unit/infer
-  (link tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@))
+  (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@))
diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt
index 615cc6b4..6063fdfa 100644
--- a/collects/typed-scheme/typed-scheme.rkt
+++ b/collects/typed-scheme/typed-scheme.rkt
@@ -1,23 +1,21 @@
-#lang scheme/base
+#lang racket/base
 
-(require (rename-in "utils/utils.rkt" [infer r:infer]))
-
-(require (private with-types)
+(require (rename-in "utils/utils.rkt" [infer r:infer])
+         (private with-types)
          (for-syntax 
           (except-in syntax/parse id)
-          scheme/base
-          (private type-contract optimize)
+          racket/match unstable/syntax racket/base unstable/match
+          (private type-contract)
+          (optimizer optimizer)
           (types utils convenience)
 	  (typecheck typechecker provide-handling tc-toplevel)
-	  (env type-environments type-name-env type-alias-env)
+	  (env type-name-env type-alias-env)
 	  (r:infer infer)
 	  (utils tc-utils)
 	  (rep type-rep)
 	  (except-in (utils utils) infer)
-          (only-in (r:infer infer-dummy) infer-param)
-          scheme/nest
-          syntax/kerncase
-          scheme/match))
+          (only-in (r:infer infer-dummy) infer-param)          
+          "tc-setup.rkt"))
 
 (provide (rename-out [module-begin #%module-begin]
                      [top-interaction #%top-interaction]
@@ -26,127 +24,55 @@
                      [require require])
          with-type)
 
-(define-for-syntax catch-errors? #f)
-
-;(begin (init-tnames))
-
-
 (define-syntax (module-begin stx)
-  (define module-name (syntax-property stx 'enclosing-module-name))
-  ;(printf "BEGIN: ~a~n" (syntax->datum stx))
   (syntax-parse stx
      [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...)
-      (nest
-          ([begin (set-box! typed-context? #t)
-                  (start-timing module-name)]
-           [with-handlers
-               ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e))))
-                 (lambda (e) (tc-error "Internal error: ~a" e))])]
-           [parameterize (;; enable fancy printing?
-                          [custom-printer #t]
-                          ;; a cheat to avoid units
-                          [infer-param infer]
-                          ;; do we report multiple errors
-                          [delay-errors? #t]
-                          ;; do we optimize?
-                          [optimize? (or (attribute opt?) (optimize?))]
-                          ;; this parameter is for parsing types
-                          [current-tvars initial-tvar-env]
-                          ;; this parameter is just for printing types
-                          ;; this is a parameter to avoid dependency issues
-                          [current-type-names
-                           (lambda ()
-                             (append 
-                              (type-name-env-map (lambda (id ty)
-                                                   (cons (syntax-e id) ty)))
-                              (type-alias-env-map (lambda (id ty)
-                                                    (cons (syntax-e id) ty)))))]
-                          ;; reinitialize seen type variables
-                          [type-name-references null])]
-           [begin (do-time "Initialized Envs")]
-           ;; local-expand the module
-           ;; pmb = #%plain-module-begin    
-           [with-syntax ([new-mod 
-                          (local-expand (syntax/loc stx
-                                          (#%plain-module-begin 
-                                           forms ...))
-                                        'module-begin 
-                                        null)])]
-           [with-syntax ([(pmb body2 ...) #'new-mod])]
-           [begin (do-time "Local Expand Done")]
-           [with-syntax ([after-code (parameterize ([orig-module-stx (or (orig-module-stx) stx)]
-                                                    [expanded-module-stx #'new-mod])
-                                       (type-check #'(body2 ...)))]
-                         [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
-                         [(transformed-body ...) (remove-provides #'(body2 ...))])]
-           [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]
-           
-           [with-syntax ([(transformed-body ...) 
-                          (if (optimize?)
-                              (begin (printf "optimizing ...\n")
-                                     (map optimize (syntax->list #'(transformed-body ...))))
-                              #'(transformed-body ...))])])
-        (do-time "Typechecked")
-        #;(printf "checked ~a~n" module-name)
-        #;(printf "created ~a types~n" (count!))
-        #;(printf "tried to create ~a types~n" (all-count!))
-        #;(printf "created ~a union types~n" (union-count!))
-        ;; reconstruct the module with the extra code
-        #'(#%module-begin transformed-body ... after-code check-syntax-help))]))
+      (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))])
+        (parameterize ([optimize? (or (optimize?) (attribute opt?))])
+          (tc-setup 
+           stx pmb-form 'module-begin new-mod tc-module after-code
+           (with-syntax*
+            (;; pmb = #%plain-module-begin    
+             [(pmb . body2) new-mod]
+             ;; add in syntax property on useless expression to draw check-syntax arrows
+             [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
+             ;; perform the provide transformation from [Culpepper 07]
+             [transformed-body (remove-provides #'body2)]
+             ;; add the real definitions of contracts on requires
+             [transformed-body (change-contract-fixups #'transformed-body)]
+             ;; potentially optimize the code based on the type information
+             [(optimized-body ...)
+              ;; do we optimize?
+              (if (optimize?)
+                  (begin0 (map optimize-top (syntax->list #'transformed-body))
+                    (do-time "Optimized"))
+                  #'transformed-body)])
+            ;; reconstruct the module with the extra code
+            ;; use the regular %#module-begin from `racket/base' for top-level printing
+            #`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))]))
 
 (define-syntax (top-interaction stx)
-  (syntax-case stx ()
-    [(_ . (module . rest))
-     (eq? 'module (syntax-e #'module))
+  (syntax-parse stx 
+    [(_ . ((~datum module) . rest))
      #'(module . rest)]
-    [(_ . form)     
-     (nest
-         ([begin (set-box! typed-context? #t)]
-          [parameterize (;; disable fancy printing
-                         [custom-printer #t]
-                         ;; a cheat to avoid units
-                         [infer-param infer]
-                         ;; this paramter is for parsing types
-                         [current-tvars initial-tvar-env]
-                         ;; this parameter is just for printing types
-                         ;; this is a parameter to avoid dependency issues
-                         [current-type-names
-                          (lambda () 
-                            (append 
-                             (type-name-env-map (lambda (id ty)
-                                                  (cons (syntax-e id) ty)))
-                             (type-alias-env-map (lambda (id ty)
-                                                   (cons (syntax-e id) ty)))))])]
-         ;(do-time "Initialized Envs")
-          ;; local-expand the module
-          [let ([body2 (local-expand #'(#%top-interaction . form) 'top-level null)])]
-          [parameterize ([orig-module-stx #'form]
-                         [expanded-module-stx body2])]
-          ;; typecheck the body, and produce syntax-time code that registers types
-          [let ([type (tc-toplevel-form body2)])])
-         (define-syntax-class invis-kw
-           #:literals (define-values define-syntaxes #%require #%provide begin)
-           (pattern define-values)
-           (pattern define-syntaxes)
-           (pattern #%require)
-           (pattern #%provide)
-           (pattern begin))
-       (syntax-parse body2
-         [(head:invis-kw . _) 
-          body2]
-         [_ (let ([ty-str (match type
-                            [(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f]
-                            [(tc-result1: t f o)
-                             (format "- : ~a\n" t)]
-                            [(tc-results: t)
-                             (format "- : ~a\n" (cons 'Values t))]
-                            [x (int-err "bad type result: ~a" x)])])
-              (if ty-str                  
-                  #`(let ([type '#,ty-str])
-                      (begin0 
-                        #,body2
-                        (display type)))
-                  body2))]))]))
+    [(_ . form)
+     (tc-setup
+      stx #'form 'top-level body2 tc-toplevel-form type
+      (syntax-parse body2
+        ;; any of these do not produce an expression to be printed
+        [(head:invis-kw . _) body2]
+        [_ (let ([ty-str (match type
+                           ;; don't print results of type void
+                           [(tc-result1: (== -Void type-equal?)) #f]
+                           [(tc-result1: t f o)
+                            (format "- : ~a\n" t)]
+                           [(tc-results: t)
+                            (format "- : ~a\n" (cons 'Values t))]
+                           [x (int-err "bad type result: ~a" x)])])
+             (if ty-str                  
+                 #`(let ([type '#,ty-str])
+                     (begin0 #,body2 (display type)))
+                 body2))]))]))
 
 
 
diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt
index 43bcdbbe..a8203f4e 100644
--- a/collects/typed-scheme/types/abbrev.rkt
+++ b/collects/typed-scheme/types/abbrev.rkt
@@ -3,19 +3,20 @@
 (require "../utils/utils.rkt")
 
 (require (rep type-rep object-rep filter-rep rep-utils)
-	 "printer.rkt" "utils.rkt" "resolve.rkt"
+	 #;"printer.rkt" "utils.rkt" "resolve.rkt"
          (utils tc-utils)
          scheme/list
          scheme/match         
          scheme/promise
          scheme/flonum (except-in scheme/contract ->* ->)
-         unstable/syntax unstable/mutated-vars
+         unstable/syntax
          (prefix-in c: scheme/contract)
          (for-syntax scheme/base syntax/parse)
 	 (for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum))
 
 (provide (all-defined-out)
-         (rename-out [make-Listof -lst]))
+         (rename-out [make-Listof -lst]
+                     [make-MListof -mlst]))
 
 ;; convenient constructors
 
@@ -26,7 +27,9 @@
 (define -val make-Value)
 (define -Param make-Param)
 (define -box make-Box)
+(define -channel make-Channel)
 (define -vec make-Vector)
+(define (-seq . args) (make-Sequence args))
 
 (define-syntax *Un
   (syntax-rules ()
@@ -34,6 +37,7 @@
 
 
 (define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
+(define (make-MListof elem) (-mu mlist-rec (*Un (-val null) (-mpair elem mlist-rec))))
 
 (define (-lst* #:tail [tail (-val null)] . args)
   (for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl)))
@@ -41,6 +45,9 @@
 (define (-Tuple l)
   (foldr -pair (-val '()) l))
 
+(define (-Tuple* l b)
+  (foldr -pair b l))
+
 (define (untuple t)
   (match (resolve t)
     [(Value: '()) null]
@@ -51,8 +58,8 @@
 (define-match-expander Listof:
   (lambda (stx)
     (syntax-parse stx
-      [(_ elem-pat)
-       #'(Mu: var (Union: (list (Value: '()) (Pair: elem-pat (F: var)))))])))
+      [(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var])))
+       (syntax/loc stx (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat))))))])))
 
 (define-match-expander List:
   (lambda (stx)
@@ -60,6 +67,12 @@
       [(_ elem-pats)
        #'(app untuple (? values elem-pats))])))
 
+(define-match-expander MListof:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ elem-pat)
+       #'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))])))
+
 
 (d/c (-result t [f -no-filter] [o -no-obj])
   (c:->* (Type/c) (FilterSet? Object?) Result?)
@@ -73,10 +86,12 @@
 
 ;; basic types
 
+(define promise-sym (string->uninterned-symbol "Promise"))
+
 (define make-promise-ty
-  (let ([s (string->uninterned-symbol "Promise")])
+  (let ([s promise-sym])
     (lambda (t)
-      (make-Struct s #f (list t) #f #f #'promise? values (list #'values) #'values))))
+      (make-Struct s #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values))))
 
 (define -Listof (-poly (list-elem) (make-Listof list-elem)))
 
@@ -91,6 +106,7 @@
 (define -String (make-Base 'String #'string?))
 (define -Keyword (make-Base 'Keyword #'keyword?))
 (define -Char (make-Base 'Char #'char?))
+(define -Thread (make-Base 'Thread #'thread?))
 (define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?))
 (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?))
 (define -Path (make-Base 'Path #'path?))
@@ -134,7 +150,13 @@
 ;; Numeric hierarchy
 (define -Number (make-Base 'Number #'number?))
 
+;; a complex number can't have an inexact imaginary part and an exact real part
+(define -InexactComplex (make-Base 'InexactComplex #'(and/c number? (lambda (x) (inexact-real? (imag-part x))))))
+
 (define -Flonum (make-Base 'Flonum #'inexact-real?))
+(define -NonnegativeFlonum (make-Base 'Nonnegative-Flonum #'(and/c inexact-real?
+                                                                   (or/c positive? zero?)
+                                                                   (lambda (x) (not (eq? x -0.0))))))
 
 (define -ExactRational 
   (make-Base 'Exact-Rational #'(and/c number? rational? exact?)))
@@ -142,12 +164,19 @@
 (define -ExactPositiveInteger
   (make-Base 'Exact-Positive-Integer #'exact-positive-integer?))
 
+(define -PositiveFixnum
+  (make-Base 'Positive-Fixnum #'(and/c number? fixnum? positive?)))
+(define -NegativeFixnum
+  (make-Base 'Negative-Fixnum #'(and/c number? fixnum? negative?)))
+
 (define -Zero (-val 0))
 (define -Real (*Un -Flonum -ExactRational))
+(define -Fixnum (*Un -PositiveFixnum -NegativeFixnum -Zero))
+(define -NonnegativeFixnum (*Un -PositiveFixnum -Zero))
 (define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero))
 (define -Nat -ExactNonnegativeInteger)
 
-(define -Byte -Number)
+(define -Byte -Integer)
 
 
 
@@ -263,8 +292,8 @@
 (define (make-arr-dots dom rng dty dbound)
   (make-arr* dom rng #:drest (cons dty dbound)))
 
-(define (-struct name parent flds accs constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
-  (make-Struct name parent flds proc poly pred cert accs constructor))
+(define (-struct name parent flds constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
+  (make-Struct name parent flds proc poly pred cert constructor))
 
 (d/c (-filter t i [p null])
      (c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c)
diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt
index ba991333..2569ab18 100644
--- a/collects/typed-scheme/types/printer.rkt
+++ b/collects/typed-scheme/types/printer.rkt
@@ -1,12 +1,12 @@
 #lang scheme/base
 
 (require unstable/sequence racket/require racket/match
-         (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt"
+         (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "types/abbrev.rkt"
                   "rep/rep-utils.rkt" "utils/utils.rkt" "utils/tc-utils.rkt"))
 
 ;; do we attempt to find instantiations of polymorphic types to print? 
 ;; FIXME - currently broken
-(define print-poly-types? #f)
+(define print-poly-types? #t)
 ;; do we use simple type aliases in printing
 (define print-aliases #t)
 
@@ -117,16 +117,15 @@
     [(? Rep-stx a)
      (fp "~a" (syntax->datum (Rep-stx a)))]
     [(Univ:) (fp "Any")]
-    ;; special case number until something better happens
-    ;;[(Base: 'Number _) (fp "Number")]
+    ;; names are just the printed as the original syntax
+    [(Name: stx) (fp "~a" (syntax-e stx))]
     [(app has-name? (? values name))
      (fp "~a" name)]
     [(StructTop: st) (fp "~a" st)]
     [(BoxTop:) (fp "Box")]
+    [(ChannelTop:) (fp "Channel")]
     [(VectorTop:) (fp "Vector")]
     [(MPairTop:) (fp "MPair")]
-    ;; names are just the printed as the original syntax
-    [(Name: stx) (fp "~a" (syntax-e stx))]
     [(App: rator rands stx) 
      (fp "~a" (list* rator rands))]
     ;; special cases for lists
@@ -134,16 +133,20 @@
      (fp "(Listof ~a)" elem-ty)]
     [(Mu: var (Union: (list (Pair: elem-ty (F: var)) (Value: '()))))
      (fp "(Listof ~a)" elem-ty)]
+    [(Mu: var (Union: (list (Value: '()) (MPair: elem-ty (F: var)))))
+     (fp "(MListof ~a)" elem-ty)]
+    [(Mu: var (Union: (list (MPair: elem-ty (F: var)) (Value: '()))))
+     (fp "(MListof ~a)" elem-ty)]
     [(Value: v) (cond [(or (symbol? v) (null? v))
                        (fp "'~a" v)]
                       [else (fp "~a" v)])]
     [(? tuple? t)
      (fp "~a" (cons 'List (tuple-elems t)))]
-    [(Base: n cnt) (fp "~a" n)]      
+    [(Base: n cnt) (fp "~s" n)]      
     [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
-    [(Struct: 'Promise par (list fld) proc _ _ _ _ _) (fp "(Promise ~a)" fld)]      
-    [(Struct: nm par flds proc _ _ _ _ _) 
-     (fp "#(struct:~a ~a" nm flds)
+    [(Struct: (== promise-sym) #f  (list (fld: t _ _)) _    _ _ _ _) (fp "(Promise ~a)" t)]
+    [(Struct: nm       par (list (fld: t _ _) ...)       proc _ _ _ _)
+     (fp "#(struct:~a ~a" nm t)
      (when proc
        (fp " ~a" proc))
      (fp ")")]
@@ -165,13 +168,16 @@
                                (fp " ~a" i))
                              (fp ")")]
     [(Box: e) (fp "(Boxof ~a)" e)]
+    [(Channel: e) (fp "(Channelof ~a)" e)]
     [(Union: elems) (fp "~a" (cons 'U elems))]
     [(Pair: l r) (fp "(Pairof ~a ~a)" l r)]
+    [(ListDots: dty dbound) 
+     (fp "(List ~a ...~a~a)" dty (if (special-dots-printing?) "" " ") dbound)]
     [(F: nm) (fp "~a" nm)]   
     ;; FIXME
     [(Values: (list v)) (fp "~a" v)]
-    [(Values: (list v ...)) (fp "~a" (cons 'values v))]
-    [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))]
+    [(Values: (list v ...)) (fp "~s" (cons 'values v))]
+    [(ValuesDots: v dty dbound) (fp "~s" (cons 'values (append v (list dty '... dbound))))]
     [(Param: in out) 
      (if (equal? in out)
          (fp "(Parameterof ~a)" in)           
@@ -209,9 +215,15 @@
     [(Result: t (FilterSet: (Top:) (Top:)) (Empty:)) (fp "~a" t)]
     [(Result: t fs (Empty:)) (fp "(~a : ~a)" t fs)]
     [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)]
+    [(MPair: s t) (fp "(MPairof ~a ~a)" s t)]
     [(Refinement: parent p? _)
      (fp "(Refinement ~a ~a)" parent (syntax-e p?))]
+    [(Sequence: ts)
+     (fp "(Sequenceof")
+     (for ([t ts]) (fp " ~a" t))
+     (fp ")")]
     [(Error:) (fp "Error")]
+    [(fld: t a m) (fp "(fld ~a)" t)]
     [else (fp "(Unknown Type: ~a)" (struct->vector c))]
     ))
 
diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt
index 6f21b58e..a646a54c 100644
--- a/collects/typed-scheme/types/remove-intersect.rkt
+++ b/collects/typed-scheme/types/remove-intersect.rkt
@@ -50,19 +50,33 @@
          [(or (list (Pair: _ _) _)
               (list _ (Pair: _ _)))
           #f]
-         [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _ _))
-              (list (Struct: n _ flds _ _ _ _ _ _) (Value: '())))
+         [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _))
+              (list (Struct: n _ flds _ _ _ _ _) (Value: '())))
           #f]
-         [(list (Struct: n _ flds _ _ _ _ _ _)
-                (Struct: n _ flds* _ _ _ _ _ _))
-          (for/and ([f flds] [f* flds*]) (overlap f f*))]
+         [(list (Struct: n _ flds _ _ _ _ _)
+                (Struct: n _ flds* _ _ _ _ _))
+          (for/and ([f flds] [f* flds*]) 
+            (match* (f f*)
+              [((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
+         [(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* _ _ _ _ _ _))
+         [(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*]) 
+                 (match* (f f*)
+                   [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))]
+         [(list (== (-val eof))
+                (Function: _))
           #f]
-         [(list (Struct: n p flds _ _ _ _ _ _)
-                (Struct: n* p* flds* _ _ _ _ _ _))
-          (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))]
          [else #t])])))
 
 
diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-scheme/types/substitute.rkt
new file mode 100644
index 00000000..a2957404
--- /dev/null
+++ b/collects/typed-scheme/types/substitute.rkt
@@ -0,0 +1,155 @@
+#lang racket/base
+
+(require "../utils/utils.rkt"
+         (rep type-rep filter-rep object-rep rep-utils)
+         (utils tc-utils)
+         (only-in (rep free-variance) combine-frees)
+         (env index-env tvar-env)
+         scheme/match
+         scheme/contract)
+
+(provide subst-all substitute substitute-dots substitute-dotted subst
+         (struct-out t-subst) (struct-out i-subst) (struct-out i-subst/starred) (struct-out i-subst/dotted)
+         substitution/c make-simple-substitution)
+
+(define (subst v t e) (substitute t v e))
+
+(d/c (make-simple-substitution vs ts)
+  (([vs (listof symbol?)] [ts (listof Type/c)]) () #:pre-cond (= (length vs) (length ts)) . ->d . [_ substitution/c])
+  (for/hash ([v (in-list vs)] [t (in-list ts)])
+    (values v (t-subst t))))
+
+(d-s/c subst-rhs () #:transparent)
+(d-s/c (t-subst subst-rhs) ([type Type/c]) #:transparent)
+(d-s/c (i-subst subst-rhs) ([types (listof Type/c)]) #:transparent)
+(d-s/c (i-subst/starred subst-rhs) ([types (listof Type/c)] [starred Type/c]) #:transparent)
+(d-s/c (i-subst/dotted subst-rhs) ([types (listof Type/c)] [dty Type/c] [dbound symbol?]) #:transparent)
+
+(define substitution/c (hash/c symbol? subst-rhs? #:immutable #t))
+
+;; substitute : Type Name Type -> Type
+(d/c (substitute image name target #:Un [Un (get-union-maker)])
+  ((Type/c symbol? Type?) (#:Un procedure?) . ->* . Type?)
+  (define (sb t) (substitute image name t))
+  (if (hash-ref (free-vars* target) name #f)
+      (type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
+                 target
+                 [#:Union tys (Un (map sb tys))]
+                 [#:F name* (if (eq? name* name) image target)]
+                 [#:arr dom rng rest drest kws
+                        (begin
+                          (when (and (pair? drest)
+                                     (eq? name (cdr drest))
+                                     (not (bound-tvar? name)))
+                            (int-err "substitute used on ... variable ~a in type ~a" name target))
+                          (make-arr (map sb dom)
+                                    (sb rng)
+                                    (and rest (sb rest))
+                                    (and drest (cons (sb (car drest)) (cdr drest)))
+                                    (map sb kws)))]
+                 [#:ValuesDots types dty dbound
+                               (begin
+                                 (when (and (eq? name dbound) (not (bound-tvar? name)))
+                                   (int-err "substitute used on ... variable ~a in type ~a" name target))
+                                 (make-ValuesDots (map sb types) (sb dty) dbound))]
+                 [#:ListDots dty dbound
+                             (begin
+                               (when (and (eq? name dbound) (not (bound-tvar? name)))
+                                 (int-err "substitute used on ... variable ~a in type ~a" name target))
+                               (make-ListDots (sb dty) dbound))])
+      target))
+
+;; implements angle bracket substitution from the formalism
+;; substitute-dots : Listof[Type] Option[type] Name Type -> Type
+(d/c (substitute-dots images rimage name target)
+  ((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?)
+  (define (sb t) (substitute-dots images rimage name t))
+  (if (or (hash-ref (free-idxs* target) name #f) (hash-ref (free-vars* target) name #f))
+      (type-case (#:Type sb #:Filter (sub-f sb)) target
+                 [#:ListDots dty dbound
+                             (if (eq? name dbound)
+                                 ;; We need to recur first, just to expand out any dotted usages of this.
+                                 (let ([expanded (sb dty)])
+                                   (for/fold ([t (make-Value null)])
+                                     ([img images])
+                                     (make-Pair (substitute img name expanded) t)))
+                                 (make-ListDots (sb dty) dbound))]
+                 [#:ValuesDots types dty dbound
+                               (if (eq? name dbound)
+                                   (make-Values
+                                    (append 
+                                     (map sb types)
+                                     ;; We need to recur first, just to expand out any dotted usages of this.
+                                     (let ([expanded (sb dty)])
+                                       (for/list ([img images])
+                                         (make-Result
+                                          (substitute img name expanded)
+                                          (make-FilterSet (make-Top) (make-Top))
+                                          (make-Empty))))))
+                                   (make-ValuesDots (map sb types) (sb dty) dbound))]
+                 [#:arr dom rng rest drest kws
+                        (if (and (pair? drest)
+                                 (eq? name (cdr drest)))
+                            (make-arr (append 
+                                       (map sb dom)
+                                       ;; We need to recur first, just to expand out any dotted usages of this.
+                                       (let ([expanded (sb (car drest))])
+                                         (map (lambda (img) (substitute img name expanded)) images)))
+                                      (sb rng)
+                                      rimage
+                                      #f
+                                      (map sb kws))
+                            (make-arr (map sb dom)
+                                      (sb rng)
+                                      (and rest (sb rest))
+                                      (and drest (cons (sb (car drest)) (cdr drest)))
+                                      (map sb kws)))])
+      target))
+
+;; implements curly brace substitution from the formalism
+;; substitute-dotted : Type Name Name Type -> Type
+(define (substitute-dotted image image-bound name target)
+  (define (sb t) (substitute-dotted image image-bound name t))
+  (if (hash-ref (free-idxs* target) name #f)
+      (type-case (#:Type sb #:Filter (sub-f sb))
+                 target
+                 [#:ValuesDots types dty dbound
+                               (make-ValuesDots (map sb types)
+                                                (sb dty)
+                                                (if (eq? name dbound) image-bound dbound))]
+                 [#:ListDots dty dbound
+                             (make-ListDots (sb dty)
+                                            (if (eq? name dbound) image-bound dbound))]
+                 [#:F name*
+                      (if (eq? name* name)
+                          image
+                          target)]
+                 [#:arr dom rng rest drest kws
+                        (make-arr (map sb dom)
+                                  (sb rng)
+                                  (and rest (sb rest))
+                                  (and drest
+                                       (cons (substitute image (cdr drest) (sb (car drest)))
+                                             (if (eq? name (cdr drest)) image-bound (cdr drest))))
+                                  (map sb kws))])
+       target))
+
+;; substitute many variables
+;; substitution = Listof[U List[Name,Type] List[Name,Listof[Type]]]
+;; subst-all : substitution Type -> Type
+(d/c (subst-all s t)
+  (substitution/c Type? . -> . Type?)
+  (for/fold ([t t]) ([(v r) s])
+    (match r
+      [(t-subst img)
+       (substitute img v t)]
+      [(i-subst imgs)
+       (substitute-dots imgs #f v t)]
+      [(i-subst/starred imgs rest)
+       (substitute-dots imgs rest v t)]     
+      [(i-subst/dotted null dty dbound)
+       (substitute-dotted dty dbound v t)]
+      [(i-subst/dotted imgs dty dbound)
+       (int-err "i-subst/dotted nyi")
+       #;
+       (substitute-dotted imgs rest v t)])))
\ No newline at end of file
diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt
index 9cb832da..6fa2969c 100644
--- a/collects/typed-scheme/types/subtype.rkt
+++ b/collects/typed-scheme/types/subtype.rkt
@@ -2,7 +2,7 @@
 (require "../utils/utils.rkt"
          (rep type-rep filter-rep object-rep rep-utils)
          (utils tc-utils)
-	 (types utils comparison resolve abbrev)
+	 (types utils comparison resolve abbrev substitute)
          (env type-name-env)
          (only-in (infer infer-dummy) unify)
          scheme/match unstable/match
@@ -16,7 +16,7 @@
 
 (define-struct (exn:subtype exn:fail) (s t))
 
-;; inference failure - masked before it gets to the user program
+;; subtyping failure - masked before it gets to the user program
 (define-syntax fail!
   (syntax-rules ()
     [(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))]))
@@ -196,6 +196,13 @@
        [else (make-arr (apply map (lambda args (make-Union (sort args type<?))) (cons dom1 dom)) rng1 #f #f '())])]
     [_ #f]))
 
+(define (subtype/flds* A flds flds*)
+  (for/fold ([A A]) ([f (in-list flds)] [f* (in-list flds*)])
+    (match* (f f*)
+      [((fld: t _ #t) (fld: t* _ #t))
+       (subtype* (subtype* A t* t) t t*)]
+      [((fld: t _ #f) (fld: t* _ #f))
+       (subtype* A t t*)])))
 
 ;; the algorithm for recursive types transcribed directly from TAPL, pg 305
 ;; List[(cons Number Number)] type type -> List[(cons Number Number)]
@@ -226,10 +233,11 @@
 	      [((Union: (list)) _) A0]
 	      ;; value types              
 	      [((Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))]
-	      ;; now we encode the numeric hierarchy - bletch	      
+	      ;; now we encode the numeric hierarchy - bletch
 	      [((Base: 'Integer _) (Base: 'Number _)) A0]
 	      [((Base: 'Flonum _)  (== -Real =t)) A0]
 	      [((Base: 'Integer _)  (== -Real =t)) A0]
+              [((Base: 'Flonum _)  (Base: 'InexactComplex _)) A0]
 	      [((Base: 'Flonum _)  (Base: 'Number _)) A0]
 	      [((Base: 'Exact-Rational _) (Base: 'Number _)) A0]
 	      [((Base: 'Integer _) (Base: 'Exact-Rational _)) A0]
@@ -237,11 +245,33 @@
 	      [((Base: 'Exact-Positive-Integer _) (Base: 'Number _)) A0]
 	      [((Base: 'Exact-Positive-Integer _) (== -Nat =t)) A0]
 	      [((Base: 'Exact-Positive-Integer _) (Base: 'Integer _)) A0]
+
+              [((Base: 'Positive-Fixnum _) (Base: 'Exact-Positive-Integer _)) A0]
+	      [((Base: 'Positive-Fixnum _) (Base: 'Exact-Rational _)) A0]
+	      [((Base: 'Positive-Fixnum _) (Base: 'Number _)) A0]
+	      [((Base: 'Positive-Fixnum _) (== -Nat =t)) A0]
+	      [((Base: 'Positive-Fixnum _) (Base: 'Integer _)) A0]
+
+	      [((Base: 'Negative-Fixnum _) (Base: 'Exact-Rational _)) A0]
+	      [((Base: 'Negative-Fixnum _) (Base: 'Number _)) A0]
+	      [((Base: 'Negative-Fixnum _) (Base: 'Integer _)) A0]
+              
 	      [((== -Nat =t) (Base: 'Number _)) A0]
 	      [((== -Nat =t) (Base: 'Exact-Rational _)) A0]
 	      [((== -Nat =t) (Base: 'Integer _)) A0]
 
-	      ;; values are subtypes of their "type"
+	      [((== -Fixnum =t) (Base: 'Number _)) A0]
+	      [((== -Fixnum =t) (Base: 'Exact-Rational _)) A0]
+	      [((== -Fixnum =t) (Base: 'Integer _)) A0]
+
+              [((Base: 'Nonnegative-Flonum _) (Base: 'Flonum _)) A0]
+              [((Base: 'Nonnegative-Flonum _) (Base: 'InexactComplex _)) A0]
+              [((Base: 'Nonnegative-Flonum _) (Base: 'Number _)) A0]
+
+              [((Base: 'InexactComplex _) (Base: 'Number _)) A0]
+
+              
+              ;; values are subtypes of their "type"
 	      [((Value: (? exact-integer? n)) (Base: 'Integer _)) A0]
 	      [((Value: (and n (? number?) (? exact?) (? rational?))) (Base: 'Exact-Rational _)) A0]
 	      [((Value: (? exact-nonnegative-integer? n)) (== -Nat =t)) A0]
@@ -256,7 +286,26 @@
 	      [((Value: (? symbol? n)) (Base: 'Symbol _)) A0]
 	      [((Value: (? string? n)) (Base: 'String _)) A0]
 	      ;; tvars are equal if they are the same variable
-	      [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))]
+	      [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))]              
+              ;; sequences are covariant
+              [((Sequence: ts) (Sequence: ts*))
+               (subtypes* A0 ts ts*)]
+              [((Listof: t) (Sequence: (list t*)))
+               (subtype* A0 t t*)]
+              [((List: ts) (Sequence: (list t*)))
+               (subtypes* A0 ts (map (λ _ t*) ts))]
+              [((HeterogenousVector: ts) (Sequence: (list t*)))
+               (subtypes* A0 ts (map (λ _ t*) ts))]
+              [((Vector: t) (Sequence: (list t*)))
+               (subtype* A0 t t*)]
+              [((Base: 'String _) (Sequence: (list t*)))
+               (subtype* A0 -Char t*)]
+              [((Base: 'Bytes _) (Sequence: (list t*)))
+               (subtype* A0 -Nat t*)]
+              [((Base: 'Input-Port _) (Sequence: (list t*)))
+               (subtype* A0 -Nat t*)]
+              [((Hashtable: k v) (Sequence: (list k* v*)))
+               (subtypes* A0 (list k v) (list k* v*))]
               ;; special-case for case-lambda/union
               [((Function: arr1) (Function: (list arr2)))
                (when (null? arr1) (fail! s t))
@@ -276,13 +325,17 @@
 	      [((Pair: a d) (Pair: a* d*))
 	       (let ([A1 (subtype* A0 a a*)])
 		 (and A1 (subtype* A1 d d*)))]
+              ;; recur structurally on dotted lists, assuming same bounds
+              [((ListDots: s-dty dbound) (ListDots: t-dty dbound))
+               (subtype* A0 s-dty t-dty)]
+              [((ListDots: s-dty dbound) (Listof: t-elem))
+               (subtype* A0 (substitute Univ dbound s-dty) t-elem)]
 	      ;; quantification over two types preserves subtyping
 	      [((Poly: ns b1) (Poly: ms b2)) 
 	       (=> unmatch)
 	       (unless (= (length ns) (length ms)) 
 		       (unmatch))
-					;(printf "Poly: ~n~a ~n~a~n" b1 (subst-all (map list ms (map make-F ns)) b2))
-	       (subtype* A0 b1 (subst-all (map list ms (map make-F ns)) b2))]
+	       (subtype* A0 b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))]
 	      [((Refinement: par _ _) t)
                (subtype* A0 par t)]
 	      ;; use unification to see if we can use the polytype here
@@ -308,14 +361,16 @@
                                    (fail! s t))]
 	      [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)
                                    (fail! s t))]
-	      ;; subtyping on immutable structs is covariant
-	      [((Struct: nm _ flds #f _ _ _ _ _) (Struct: nm _ flds* #f _ _ _ _ _))
-	       (subtypes* A0 flds flds*)]
-	      [((Struct: nm _ flds proc _ _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _ _))
-	       (subtypes* A0 (cons proc flds) (cons proc* flds*))]
-              [((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s)))))
+	      ;; subtyping on immutable structs is covariant	      
+	      [((Struct: nm _ flds proc _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _))
+               (let ([A (cond [(and proc proc*) (subtype* proc proc*)]
+                              [proc* (fail! proc proc*)]
+                              [else A0])])
+                 (subtype/flds* A flds flds*))]
+              [((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?)))
                A0]
               [((Box: _) (BoxTop:)) A0]
+              [((Channel: _) (ChannelTop:)) A0]
               [((Vector: _) (VectorTop:)) A0]
               [((HeterogenousVector: _) (VectorTop:)) A0]
               [((HeterogenousVector: (list e ...)) (Vector: e*))
@@ -323,11 +378,11 @@
               [((MPair: _ _) (MPairTop:)) A0]
               [((Hashtable: _ _) (HashtableTop:)) A0]
 	      ;; subtyping on structs follows the declared hierarchy
-	      [((Struct: nm (? Type? parent) flds proc _ _ _ _ _) other) 
+	      [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) 
                ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
 	       (subtype* A0 parent other)]
 	      ;; Promises are covariant
-	      [((Struct: 'Promise _ (list t) _ _ _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _ _ _)) (subtype* A0 t t*)]
+	      [((Struct: (== promise-sym) _ (list t) _ _ _ _ _) (Struct: (== promise-sym) _ (list t*) _ _ _ _ _)) (subtype* A0 t t*)]
 	      ;; subtyping on values is pointwise
 	      [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)]
               ;; trivial case for Result
diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt
index a8c17fbf..8e742f21 100644
--- a/collects/typed-scheme/types/type-table.rkt
+++ b/collects/typed-scheme/types/type-table.rkt
@@ -1,6 +1,8 @@
 #lang scheme/base
 
-(require unstable/debug "../utils/utils.rkt" (rep type-rep) (only-in (types abbrev utils) tc-results?) scheme/contract)
+(require unstable/debug scheme/contract "../utils/utils.rkt" syntax/id-table racket/dict racket/match
+         (rep type-rep object-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils)
+         (env init-envs) mzlib/pconvert)
 
 (define table (make-hasheq))
 
@@ -10,8 +12,41 @@
   (when (optimize?)
     (hash-set! table e t)))
 
-(define (type-of e) (hash-ref table e))
+(define (type-of e) (hash-ref table e (lambda () (int-err (format "no type for ~a" (syntax->datum e))))))
+
+(define struct-fn-table (make-free-id-table))
+
+(define (add-struct-fn! id pe mut?) (dict-set! struct-fn-table id (list pe mut?)))
+
+(define-values (struct-accessor? struct-mutator?) 
+  (let ()
+    (define ((mk mut?) id)
+      (cond [(dict-ref struct-fn-table id #f)
+             => (match-lambda [(list pe m) (and (eq? m mut?) pe)] [_ #f])]
+            [else #f]))
+    (values (mk #f) (mk #t))))
+
+(define (struct-fn-idx id)
+  (match (dict-ref struct-fn-table id #f)
+    [(list (StructPE: _ idx) _) idx]
+    [_ (int-err (format "no struct fn table entry for ~a" (syntax->datum id)))]))
+
+(define (make-struct-table-code)
+  (parameterize ([current-print-convert-hook converter]
+                 [show-sharing #f])
+    #`(begin #,@(for/list ([(k v) (in-dict struct-fn-table)]
+                           #:when (bound-in-this-module k))
+                  (match v
+                    [(list pe mut?)
+                     #`(add-struct-fn! (quote-syntax #,k) 
+                                       #,(print-convert pe)
+                                       #,mut?)])))))
 
 (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)]
      [type-of (syntax? . -> . tc-results?)]
-     [reset-type-table (-> any/c)])
\ No newline at end of file
+     [reset-type-table (-> any/c)]
+     [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)]
+     [struct-accessor? (identifier? . -> . (or/c #f StructPE?))]
+     [struct-mutator? (identifier? . -> . (or/c #f StructPE?))]
+     [struct-fn-idx (identifier? . -> . exact-integer?)]
+     [make-struct-table-code (-> syntax?)])
\ No newline at end of file
diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt
index 68d6452c..af9780bf 100644
--- a/collects/typed-scheme/types/utils.rkt
+++ b/collects/typed-scheme/types/utils.rkt
@@ -4,20 +4,16 @@
 
 (require (rep type-rep filter-rep object-rep rep-utils)
          (utils tc-utils)
+         "substitute.rkt"
          (only-in (rep free-variance) combine-frees)
+         (env index-env tvar-env)
          scheme/match
          scheme/list
          mzlib/trace
          scheme/contract
          (for-syntax scheme/base syntax/parse))
 
-(provide fv fv/list
-         substitute
-         substitute-dots
-         substitute-dotted
-         subst-all
-         subst 
-         ;ret
+(provide fv fv/list fi
          instantiate-poly
          instantiate-poly-dotted
          tc-result?
@@ -25,9 +21,6 @@
          effects-equal?
          tc-result-t
          unfold
-         (struct-out Dotted)
-         (struct-out DottedBoth)
-         just-Dotted?
          tc-error/expr
          lookup-fail
          lookup-type-fail
@@ -35,106 +28,6 @@
          current-poly-struct)
 
 
-;; substitute : Type Name Type -> Type
-(define (substitute image name target #:Un [Un (get-union-maker)])
-  (define (sb t) (substitute image name t))
-  (if (hash-ref (free-vars* target) name #f)
-      (type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
-                 target
-                 [#:Union tys (Un (map sb tys))]
-                 [#:F name* (if (eq? name* name) image target)]
-                 [#:arr dom rng rest drest kws
-                        (begin
-                          (when (and (pair? drest)
-                                     (eq? name (cdr drest))
-                                     (just-Dotted? name))
-                            (int-err "substitute used on ... variable ~a in type ~a" name target))
-                          (make-arr (map sb dom)
-                                    (sb rng)
-                                    (and rest (sb rest))
-                                    (and drest (cons (sb (car drest)) (cdr drest)))
-                                    (map sb kws)))]
-                 [#:ValuesDots types dty dbound
-                               (begin
-                                 (when (eq? name dbound)
-                                   (int-err "substitute used on ... variable ~a in type ~a" name target))
-                                 (make-ValuesDots (map sb types) (sb dty) dbound))])
-      target))
-
-;; substitute-dots : Listof[Type] Option[type] Name Type -> Type
-(define (substitute-dots images rimage name target)    
-  (define (sb t) (substitute-dots images rimage name t))
-  (if (hash-ref (free-vars* target) name #f)
-      (type-case (#:Type sb #:Filter (sub-f sb)) target
-                 [#:ValuesDots types dty dbound
-                               (if (eq? name dbound)
-                                   (make-Values
-                                    (append 
-                                     (map sb types)
-                                     ;; We need to recur first, just to expand out any dotted usages of this.
-                                     (let ([expanded (sb dty)])
-                                       (for/list ([img images])
-                                         (make-Result
-                                          (substitute img name expanded)
-                                          (make-FilterSet (make-Top) (make-Top))
-                                          (make-Empty))))))
-                                   (make-ValuesDots (map sb types) (sb dty) dbound))]
-                 [#:arr dom rng rest drest kws
-                        (if (and (pair? drest)
-                                 (eq? name (cdr drest)))                            
-                            (make-arr (append 
-                                       (map sb dom)
-                                       ;; We need to recur first, just to expand out any dotted usages of this.
-                                       (let ([expanded (sb (car drest))])
-                                         (map (lambda (img) (substitute img name expanded)) images)))
-                                      (sb rng)
-                                      rimage
-                                      #f
-                                      (map sb kws))
-                            (make-arr (map sb dom)
-                                      (sb rng)
-                                      (and rest (sb rest))
-                                      (and drest (cons (sb (car drest)) (cdr drest)))
-                                      (map sb kws)))])
-      target))
-
-;; implements sd from the formalism
-;; substitute-dotted : Type Name Name Type -> Type
-(define (substitute-dotted image image-bound name target)
-  (define (sb t) (substitute-dotted image image-bound name t))
-  (if (hash-ref (free-vars* target) name #f)
-      (type-case (#:Type sb #:Filter (sub-f sb))
-                 target
-                 [#:ValuesDots types dty dbound
-                               (make-ValuesDots (map sb types)
-                                                (sb dty)
-                                                (if (eq? name dbound) image-bound dbound))]
-                 [#:F name*
-                      (if (eq? name* name)
-                          image
-                          target)]
-                 [#:arr dom rng rest drest kws
-                        (make-arr (map sb dom)
-                                  (sb rng)
-                                  (and rest (sb rest))
-                                  (and drest
-                                       (cons (sb (car drest))
-                                             (if (eq? name (cdr drest)) image-bound (cdr drest))))
-                                  (map sb kws))])
-       target))
-
-;; substitute many variables
-;; substitution = Listof[U List[Name,Type] List[Name,Listof[Type]]]
-;; subst-all : substitution Type -> Type
-(define (subst-all s t)
-  (for/fold ([t t]) ([e s])
-    (match e
-      [(list v (list imgs ...) starred)
-       (substitute-dots imgs starred v t)]
-      [(list v img)
-       (substitute img v t)])))
-
-
 ;; unfold : Type -> Type
 ;; must be applied to a Mu
 (define (unfold t)
@@ -147,13 +40,13 @@
     [(Poly: ns body) 
      (unless (= (length types) (length ns))
        (int-err "instantiate-poly: wrong number of types: expected ~a, got ~a" (length ns) (length types)))
-     (subst-all (map list ns types) body)]
+     (subst-all (make-simple-substitution ns types) body)]
     [(PolyDots: (list fixed ... dotted) body)
      (unless (>= (length types) (length fixed))
        (int-err "instantiate-poly: wrong number of types: expected at least ~a, got ~a" (length fixed) (length types)))
      (let* ([fixed-tys (take types (length fixed))]
             [rest-tys (drop types (length fixed))]
-            [body* (subst-all (map list fixed fixed-tys) body)])
+            [body* (subst-all (make-simple-substitution fixed fixed-tys) body)])
        (substitute-dots rest-tys #f dotted body*))]
     [_ (int-err "instantiate-poly: requires Poly type, got ~a" t)]))
 
@@ -163,7 +56,7 @@
      (unless (= (length fixed) (length types))
        (int-err "instantiate-poly-dotted: wrong number of types: expected ~a, got ~a, types were ~a" 
                 (length fixed) (length types) types))
-     (let ([body* (subst-all (map list fixed types) body)])
+     (let ([body* (subst-all (make-simple-substitution fixed types) body)])
        (substitute-dotted image var dotted body*))]
     [_ (int-err "instantiate-poly-dotted: requires PolyDots type, got ~a" t)]))
 
@@ -260,8 +153,6 @@
     [(list (tc-result1: t f o) ...)
      (ret t f o)]))
 
-(define (subst v t e) (substitute t v e))
-
 
 ;; type comparison
 
@@ -276,18 +167,11 @@
 
 ;; fv : Type -> Listof[Name]
 (define (fv t) (hash-map (free-vars* t) (lambda (k v) k)))
+(define (fi t) (for/list ([(k v) (in-hash (free-idxs* t))]) k))
 
 ;; fv/list : Listof[Type] -> Listof[Name]
 (define (fv/list ts) (hash-map (combine-frees (map free-vars* ts)) (lambda (k v) k)))
 
-;; t is (make-F v)
-(define-struct Dotted (t))
-(define-struct (DottedBoth Dotted) ())
-
-(define (just-Dotted? S)
-    (and (Dotted? S)
-         (not (DottedBoth? S))))
-
 (define (tc-error/expr msg #:return [return (make-Union null)] #:stx [stx (current-orig-stx)] . rest)
   (tc-error/delayed #:stx stx (apply format msg rest))
   return)
@@ -316,4 +200,4 @@
 (define to-be-abstr
   (make-weak-hash))
 
-(provide to-be-abstr)
\ No newline at end of file
+(provide to-be-abstr)
diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-scheme/utils/tc-utils.rkt
index b946a22a..90a96e0f 100644
--- a/collects/typed-scheme/utils/tc-utils.rkt
+++ b/collects/typed-scheme/utils/tc-utils.rkt
@@ -7,7 +7,7 @@ don't depend on any other portion of the system
 
 (provide (all-defined-out))
 (require "syntax-traversal.rkt"
-	 "utils.rkt"
+	 "utils.rkt" racket/dict
 	 syntax/parse (for-syntax scheme/base syntax/parse) scheme/match unstable/debug
          (for-syntax unstable/syntax))
 
@@ -16,6 +16,11 @@ don't depend on any other portion of the system
 (define orig-module-stx (make-parameter #f))
 (define expanded-module-stx (make-parameter #f))
 
+;; a parameter holding the mutated variables for the form currently being checked
+(define mutated-vars (make-parameter #hash()))
+
+(define (is-var-mutated? id) (dict-ref (mutated-vars) id #f))
+
 (define (stringify l [between " "])
   (define (intersperse v l)
     (cond [(null? l) null]
@@ -104,15 +109,16 @@ don't depend on any other portion of the system
 
 ;; produce a type error, using the current syntax
 (define (tc-error msg . rest)  
-  (let ([stx (locate-stx (current-orig-stx))])
+  (let* ([ostx (current-orig-stx)]
+         [ostxs (if (list? ostx) ostx (list ostx))]
+         [stxs (map locate-stx ostxs)])
     ;; If this isn't original syntax, then we can get some pretty bogus error messages.  Note
     ;; that this is from a macro expansion, so that introduced vars and such don't confuse the user.
     (cond
-      [(not (orig-module-stx))
-       (raise-typecheck-error (apply format msg rest) (list stx))]
-      [(eq? (syntax-source (current-orig-stx)) (syntax-source (orig-module-stx)))
-       (raise-typecheck-error (apply format msg rest) (list stx))]
-      [else (raise-typecheck-error (apply format (string-append "Error in macro expansion -- " msg) rest) (list stx))])))
+      [(or (not (orig-module-stx))
+           (for/and ([s ostxs]) (eq? (syntax-source s) (syntax-source (orig-module-stx)))))
+       (raise-typecheck-error (apply format msg rest) stxs)]
+      [else (raise-typecheck-error (apply format (string-append "Error in macro expansion -- " msg) rest) stxs)])))
 
 ;; produce a type error, given a particular syntax
 (define (tc-error/stx stx msg . rest)
diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt
index 493ab95a..afed7b55 100644
--- a/collects/typed-scheme/utils/utils.rkt
+++ b/collects/typed-scheme/utils/utils.rkt
@@ -11,7 +11,7 @@ at least theoretically.
 	 scheme/pretty mzlib/pconvert syntax/parse)
 
 ;; to move to unstable
-(provide reverse-begin)
+(provide reverse-begin list-update list-set)
 
 (provide
  ;; optimization
@@ -23,9 +23,10 @@ at least theoretically.
  ;; struct printing
  custom-printer define-struct/printer
  ;; provide macros
- rep utils typecheck infer env private)
+ rep utils typecheck infer env private types)
 
 (define optimize? (make-parameter #f))
+(define-for-syntax enable-contracts? #f)
 
 ;; fancy require syntax
 (define-syntax (define-requirer stx)
@@ -82,6 +83,7 @@ at least theoretically.
 (define-requirer env env-out)
 (define-requirer private private-out)
 (define-requirer types types-out)
+(define-requirer optimizer optimizer-out)
 
 ;; run `h' last, but drop its return value
 (define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h))
@@ -152,13 +154,13 @@ at least theoretically.
   (syntax-parse stx
     [(form name (flds ...) printer:expr)
      #`(define-struct name (flds ...) 
+         #:property prop:custom-print-quotable 'never
          #:property prop:custom-write 
          (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))
-         #:inspector #f)]))
+         #:transparent)]))
 
 
 ;; turn contracts on and off - off by default for performance.
-(define-for-syntax enable-contracts? #f)
 (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c d/c/p)
 
 (define-syntax-rule (d/c/p (name . args) c . body)
@@ -213,3 +215,13 @@ at least theoretically.
      (if enable-contracts?
          (list #'[contracted (nm cnt)])     
          (list #'nm))]))
+
+(define (list-update l i f)
+  (cond [(null? l) (error 'list-update "list not long enough" l i f)]
+        [(zero? i) (cons (f (car l)) (cdr l))]
+        [else (cons (car l) (list-update (cdr l) (sub1 i) f))]))
+
+(define (list-set l k v)
+  (if (zero? k)
+      (cons v (cdr l))
+      (cons (car l) (list-set (cdr l) (sub1 k) v))))
diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt
index 6f7c5c75..b728ae5f 100644
--- a/collects/typed/racket/base.rkt
+++ b/collects/typed/racket/base.rkt
@@ -4,7 +4,7 @@
 
 (providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct)
                  (except typed-scheme/private/prims)
-                 (except typed-scheme/private/base-types-new)
+                 (except typed-scheme/private/base-types)
                  (except typed-scheme/private/base-types-extra))
 	   (basics #%module-begin		   		   		   
 		   #%top-interaction
diff --git a/collects/typed/racket/base/no-check.rkt b/collects/typed/racket/base/no-check.rkt
new file mode 100644
index 00000000..755a07f3
--- /dev/null
+++ b/collects/typed/racket/base/no-check.rkt
@@ -0,0 +1,4 @@
+#lang racket/base
+
+(require racket/require typed-scheme/no-check (subtract-in typed/racket/base typed-scheme/no-check))
+(provide (all-from-out typed/racket/base typed-scheme/no-check))
\ No newline at end of file
diff --git a/collects/typed/racket/base/no-check/lang/reader.rkt b/collects/typed/racket/base/no-check/lang/reader.rkt
new file mode 100644
index 00000000..af4b238d
--- /dev/null
+++ b/collects/typed/racket/base/no-check/lang/reader.rkt
@@ -0,0 +1,8 @@
+#lang s-exp syntax/module-reader
+
+typed/racket/base/no-check
+
+#:read r:read
+#:read-syntax r:read-syntax
+
+(require (prefix-in r: typed-scheme/typed-reader))
diff --git a/collects/typed/racket/no-check.rkt b/collects/typed/racket/no-check.rkt
new file mode 100644
index 00000000..eb8a3c78
--- /dev/null
+++ b/collects/typed/racket/no-check.rkt
@@ -0,0 +1,4 @@
+#lang racket/base
+
+(require racket/require typed-scheme/no-check (subtract-in typed/racket typed-scheme/no-check))
+(provide (all-from-out typed/racket typed-scheme/no-check))
\ No newline at end of file
diff --git a/collects/typed/racket/no-check/lang/reader.rkt b/collects/typed/racket/no-check/lang/reader.rkt
new file mode 100644
index 00000000..7d16e804
--- /dev/null
+++ b/collects/typed/racket/no-check/lang/reader.rkt
@@ -0,0 +1,8 @@
+#lang s-exp syntax/module-reader
+
+typed/racket/no-check
+
+#:read r:read
+#:read-syntax r:read-syntax
+
+(require (prefix-in r: typed-scheme/typed-reader))
diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt
index fa662f89..2a751ed8 100644
--- a/collects/typed/scheme/base.rkt
+++ b/collects/typed/scheme/base.rkt
@@ -4,7 +4,7 @@
 
 (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct)
                  (except typed-scheme/private/prims)
-                 (except typed-scheme/private/base-types-new)
+                 (except typed-scheme/private/base-types)
                  (except typed-scheme/private/base-types-extra))
 	   (basics #%module-begin		   		   		   
 		   #%top-interaction
diff --git a/collects/unstable/mutated-vars.rkt b/collects/unstable/mutated-vars.rkt
index 1665b820..3b3162bf 100644
--- a/collects/unstable/mutated-vars.rkt
+++ b/collects/unstable/mutated-vars.rkt
@@ -1,57 +1,43 @@
 #lang racket/base
 
-(require (for-template racket/base)
-         syntax/boundmap syntax/kerncase)
-
-;; mapping telling whether an identifer is mutated
-;; maps id -> boolean
-(define table (make-module-identifier-mapping))
+(require (for-template racket/base) racket/dict
+         syntax/id-table syntax/kerncase)
 
 ;; find and add to mapping all the set!'ed variables in form
-;; syntax -> void
-(define (find-mutated-vars form)
-  ;; syntax -> void
-  (define (fmv/list lstx)
-    (for-each find-mutated-vars (syntax->list lstx)))
-  (kernel-syntax-case* form #f ()
-    ;; what we care about: set!
-    [(set! v e)
-     (begin
-       (module-identifier-mapping-put! table #'v #t))]
-    [(define-values (var ...) expr)
-     (find-mutated-vars #'expr)]
-    [(#%plain-app . rest) (fmv/list #'rest)]
-    [(begin . rest) (fmv/list #'rest)]
-    [(begin0 . rest) (fmv/list #'rest)]
-    [(#%plain-lambda _ . rest) (fmv/list #'rest)]
-    [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))]
-    [(if . es) (fmv/list #'es)]
-    [(with-continuation-mark . es) (fmv/list #'es)]
-    [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
-                                         (fmv/list #'b))]
-    [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
-                                            (fmv/list #'b))]
-    [(letrec-syntaxes+values _ ([_ e] ...) . b) (begin (fmv/list #'(e ...))
-						       (fmv/list #'b))]
-    [(#%expression e) (find-mutated-vars #'e)]
-    ;; all the other forms don't have any expression subforms (like #%top)
-    [_ (void)]))
+;; if the supplied mapping is mutable, mutates it
+;; default is immutability
+;; syntax [table] -> table
+(define (find-mutated-vars form [tbl (make-immutable-free-id-table)])
+  (define add (if (dict-mutable? tbl)
+                  (lambda (t i) (dict-set! t i #t) t)
+                  (lambda (t i) (dict-set t i #t))))
+  (let loop ([stx form] [tbl tbl])
+    ;; syntax-list -> table
+    (define (fmv/list lstx)
+      (for/fold ([tbl tbl])
+          ([stx (in-list (syntax->list lstx))])
+        (loop stx tbl)))
+    (kernel-syntax-case* stx #f (#%top-interaction)
+      ;; what we care about: set!
+      [(set! v e)
+       (add (loop #'e tbl) #'v)]
+      ;; forms with expression subforms
+      [(define-values (var ...) expr)
+       (loop #'expr tbl)]
+      [(#%expression e) (loop #'e tbl)]
+      [(#%plain-app . rest) (fmv/list #'rest)]
+      [(begin . rest) (fmv/list #'rest)]
+      [(begin0 . rest) (fmv/list #'rest)]
+      [(#%plain-lambda _ . rest) (fmv/list #'rest)]
+      [(case-lambda (_  rest ...) ...)
+       (fmv/list #'(rest ... ...))]
+      [(if . es) (fmv/list #'es)]
+      [(with-continuation-mark . es) (fmv/list #'es)]
+      [(let-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
+      [(letrec-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
+      [(letrec-syntaxes+values _ ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
+      [(#%plain-module-begin . forms) (fmv/list #'forms)]
+      ;; all the other forms don't have any expression subforms (like #%top)
+      [_ tbl])))
 
-;; checks to see if a particular variable is ever set!'d
-;; is-var-mutated? : identifier -> boolean
-(define (is-var-mutated? id) (module-identifier-mapping-get table id (lambda _ #f)))
-
-;; Eli:
-;; - The `for-template' doesn't look like it's needed.
-;; - This is the *worst* looking interface I've seen in a while.  Seems very
-;;   specific to some unclear optimization needs.  (Either that, or translated
-;;   from C.)
-;; - Besides weird, identifiers maps are (IIRC) not weak, which makes this even
-;;   less general.
-;; - What's with the typed-scheme literals?  If they were needed, then
-;;   typed-scheme is probably broken now.
-;; ryanc:
-;; - The for-template is needed.
-;; - I've removed the bogus literals.
-
-(provide find-mutated-vars is-var-mutated?)
+(provide find-mutated-vars)