svn merge -r11635:11656 http://svn.plt-scheme.org/plt/trunk

Okay, now we're up to the present day, from here on out the mergeinfo should
be correct :p

svn: r11657

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "10sep2008")
+#lang scheme/base (provide stamp) (define stamp "11sep2008")

collects/tests/run-automated-tests.ss

@@ -31,7 +31,8 @@
 (define tests
   '([load "mzscheme/quiet.ss" (lib "scheme/init")]
     [require "typed-scheme/main.ss"]
-    [require "match/plt-match-tests.ss"]))
+    [require "match/plt-match-tests.ss"]
+    [require "stepper/automatic-tests.ss"]))
 
 
 (require scheme/runtime-path)

collects/tests/stepper/automatic-tests.ss

@@ -1,7 +1,8 @@
 (module automatic-tests mzscheme
   (require "through-tests.ss")
   
-  (parameterize ([display-only-errors #t])
+  (parameterize ([display-only-errors #t]
-    (if (run-all-tests-except '(check-expect begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3))
+                 [current-output-port (open-output-string)])
+    (if (run-all-tests-except '(check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3))
         (exit 1)
         (exit 0))))

collects/tests/stepper/run-nightly-tests.ss

@@ -1,5 +0,0 @@
-(module run-nightly-tests mzscheme
-  (require "through-tests.ss")
-  
-  (parameterize ([display-only-errors #t])
-    (run-all-tests-except '(prims qq-splice time set! local-set! lazy1 lazy2 lazy3))))

collects/tests/stepper/through-tests.ss

@@ -1368,21 +1368,6 @@
          (before-after (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite (+ 2 2)) 4))
                        (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite 4) 4))))))
   
-  (t1 check-expect-2
-      (test-upto-int/lam
-       "(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 3 1) 4) (+ 4 5)"
-       `((before-after ((hilite (+ 4 5)))
-                       ((hilite 9)))
-         (before-after (9 (check-expect (+ 3 4) (hilite (+ 8 9))))
-                       (9 (check-expect (+ 3 4) (hilite 17))))
-         (before-after (9 (check-expect (hilite (+ 3 4)) 17))
-                       (9 (check-expect (hilite 7) 17)))
-         (before-after (9 (check-expect (hilite (+ 3 1)) 4))
-                       (9 (check-expect (hilite 4) 4))))))
-  
-  
-  
-  
   (t1 check-within
       (test-bwla-to-int/lam
        "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)"

collects/tests/typed-scheme/fail/values-dots.ss

@@ -7,7 +7,7 @@
 (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b)))))
 (define (map-with-funcs . fs)
   (lambda bs
-    (apply values* (map (lambda: ([f : (b ... b -> b)])
+    (apply values (map (lambda: ([f : (b ... b -> b)])
                          (apply f bs)) fs))))
 
 (map-with-funcs (lambda () 1))

collects/tests/typed-scheme/succeed/nested-poly.ss

@@ -13,7 +13,7 @@
               (B ... B -> (values A ... A))))))
 (define (map-with-funcs . fs)
   (lambda as
-    (apply values* (map (lambda: ([f : (B ... B -> A)])
+    (apply values (map (lambda: ([f : (B ... B -> A)])
                                  (apply f as))
                         fs))))
 

collects/tests/typed-scheme/succeed/values-dots.ss

@@ -5,15 +5,15 @@
 
 (call-with-values (lambda () (values 1 2)) (lambda: ([x : Number] [y : Number]) (+ x y)))
 
-(#{call-with-values* @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y)))
+(#{call-with-values @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y)))
 
 
-(call-with-values* (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y)))
+(call-with-values (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y)))
 
 (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b)))))
 (define (map-with-funcs . fs)
   (lambda bs
-    (apply values* (map (lambda: ([f : (b ... b -> b)])
+    (apply values (map (lambda: ([f : (b ... b -> b)])
                          (apply f bs)) fs))))
 
 (map-with-funcs + - * /)

collects/tests/typed-scheme/unit-tests/all-tests.ss

@@ -12,7 +12,7 @@
  "subst-tests.ss"
  "infer-tests.ss")
 
-(require (private planet-requires infer infer-dummy))
+(require (utils planet-requires) (r:infer infer infer-dummy))
 
 (require (schemeunit))
 

collects/tests/typed-scheme/unit-tests/infer-tests.ss

@@ -1,7 +1,10 @@
 #lang scheme/base
 (require "test-utils.ss" (for-syntax scheme/base))
-(require (private planet-requires type-effect-convenience type-rep union infer type-utils)
+(require (utils planet-requires)
-         (prefix-in table: (private tables)))
+	 (rep type-rep)
+	 (r:infer infer)
+	 (private type-effect-convenience union type-utils)
+         (prefix-in table: (utils tables)))
 (require (schemeunit)) 
 
 

collects/tests/typed-scheme/unit-tests/module-tests.ss

@@ -1,6 +1,6 @@
 #lang scheme
 (require "test-utils.ss")
-(require (private planet-requires))
+(require (utils planet-requires))
 (require (schemeunit))
 
 (provide module-tests)

collects/tests/typed-scheme/unit-tests/parse-type-tests.ss

@@ -1,8 +1,10 @@
 #lang scheme/base
 (require "test-utils.ss" (for-syntax scheme/base))
-(require (private planet-requires type-comparison parse-type type-rep
+(require (utils planet-requires tc-utils)
-                  tc-utils type-environments type-alias-env subtype
+	 (env type-alias-env type-environments type-name-env init-envs)
-                  type-name-env init-envs union type-utils))
+	 (rep type-rep)
+	 (private type-comparison parse-type subtype
+		  union type-utils))
 
 (require (rename-in (private type-effect-convenience) [-> t:->])
          (except-in (private base-types) Un)

collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss

@@ -1,6 +1,9 @@
 #lang scheme/base
 (require "test-utils.ss" (for-syntax scheme/base))
-(require (private type-rep type-effect-convenience planet-requires remove-intersect subtype union infer))
+(require (rep type-rep)
+	 (utils planet-requires)
+	 (r:infer infer)
+	 (private type-effect-convenience remove-intersect subtype union))
 
 (require (schemeunit))
 

collects/tests/typed-scheme/unit-tests/subst-tests.ss

@@ -1,7 +1,9 @@
 #lang scheme/base
 
 (require "test-utils.ss" (for-syntax scheme/base))
-(require (private planet-requires type-utils type-effect-convenience type-rep))
+(require (utils planet-requires)
+	 (rep type-rep)
+	 (private type-utils type-effect-convenience))
 (require (schemeunit))
 
 (define-syntax-rule (s img var tgt result)

collects/tests/typed-scheme/unit-tests/subtype-tests.ss

@@ -2,8 +2,12 @@
 
 (require "test-utils.ss")
 
-(require (private subtype type-rep type-effect-convenience 
+(require (private subtype type-effect-convenience union)
-                  planet-requires init-envs type-environments union infer infer-dummy))
+	 (rep type-rep)
+	 (utils planet-requires)
+	 (env init-envs type-environments)
+	 (r:infer infer infer-dummy))
+
 
 (require (schemeunit)
          (for-syntax scheme/base))

collects/tests/typed-scheme/unit-tests/test-utils.ss

@@ -3,25 +3,12 @@
 
 (require scheme/require-syntax
          scheme/match
+	 typed-scheme/utils/utils
          (for-syntax scheme/base))
 
-(define-require-syntax private
-  (lambda (stx)
-    (syntax-case stx ()
-      [(_ id ...)
-       (andmap identifier? (syntax->list #'(id ...)))
-       (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax 
-                                                   id 
-                                                   (string->symbol 
-                                                    (string-append 
-                                                     "typed-scheme/private/" 
-                                                     (symbol->string (syntax-e id))))
-                                                   id id))
-                                     (syntax->list #'(id ...)))])
-         (syntax/loc stx (combine-in id* ...)))])))
-
-(require (private planet-requires type-comparison utils type-utils))
 
+(require (utils planet-requires) (private type-comparison type-utils))
+(provide private typecheck (rename-out [infer r:infer]) utils env rep)
 (require (schemeunit))
 
 (define (mk-suite ts)

collects/tests/typed-scheme/unit-tests/type-annotation-test.ss

@@ -1,8 +1,10 @@
 #lang scheme/base
 (require "test-utils.ss"
          (for-syntax scheme/base))
-(require (private planet-requires type-annotation tc-utils type-rep type-effect-convenience type-environments
+(require (private type-annotation type-effect-convenience parse-type)
-		 parse-type  init-envs type-name-env))
+	 (env type-environments type-name-env init-envs)
+	 (utils planet-requires tc-utils)
+	 (rep type-rep))
 
 (require (schemeunit))
 

collects/tests/typed-scheme/unit-tests/type-equal-tests.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
 
 (require "test-utils.ss" (for-syntax scheme/base))
-(require (private planet-requires type-rep type-comparison type-effect-convenience union subtype))
+(require (utils planet-requires) (rep type-rep)
+	 (private type-comparison type-effect-convenience union subtype))
 (require (schemeunit))
 
 (provide type-equal-tests)

collects/tests/typed-scheme/unit-tests/typecheck-tests.ss

@@ -3,14 +3,16 @@
 (require "test-utils.ss" 
          (for-syntax scheme/base)
          (for-template scheme/base))
-(require (private base-env))
+(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation)
+	 (typecheck typechecker)
+	 (rep type-rep effect-rep)
+         (utils tc-utils planet-requires)
+         (env type-name-env type-environments init-envs))
 
-(require (private planet-requires typechecker
+(require (for-syntax (utils tc-utils)
-                  type-rep type-effect-convenience type-env
+                     (typecheck typechecker)
-                  prims type-environments tc-utils union
+	             (env type-env)
-                  type-name-env init-envs mutated-vars
+	             (private base-env))
-                  effect-rep type-annotation type-utils)
-         (for-syntax (private tc-utils typechecker base-env type-env))
          (for-template (private base-env base-types)))
 (require (schemeunit))
 
@@ -669,7 +671,7 @@
    (tc-l #t (-val #t))
    (tc-l "foo" -String)
    (tc-l foo (-val 'foo))
-   (tc-l #:foo -Keyword)
+   (tc-l #:foo (-val '#:foo))
    (tc-l #f (-val #f))
    (tc-l #"foo" -Bytes)
    [tc-l () (-val null)]

collects/typed-scheme/env/init-envs.ss

@@ -1,11 +1,16 @@
 #lang scheme/base
 (provide (all-defined-out))
+(require "../utils/utils.ss")
 
-(require "type-env.ss" "type-rep.ss" "type-name-env.ss" "union.ss" "effect-rep.ss"
+(require "type-env.ss" 
-         "type-effect-convenience.ss" "type-alias-env.ss"
+	 "type-name-env.ss"
-         "type-alias-env.ss")
+	 (rep type-rep effect-rep)
-(require mzlib/pconvert scheme/match mzlib/shared
+	 (for-template (rep type-rep effect-rep) 
-         (for-template mzlib/pconvert mzlib/shared scheme/base "type-rep.ss" "union.ss" "effect-rep.ss"))    
+		       (private union)
+		       mzlib/pconvert mzlib/shared scheme/base)
+	 (private type-effect-convenience union)
+         "type-alias-env.ss"
+	 mzlib/pconvert scheme/match mzlib/shared)
 
 (define (initialize-type-name-env initial-type-names)
   (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names))

collects/typed-scheme/env/lexical-env.ss

@@ -1,6 +1,12 @@
 #lang scheme/base
 
-(require "type-environments.ss" "tc-utils.ss" "type-env.ss" "mutated-vars.ss" "type-utils.ss" "type-effect-convenience.ss")
+(require (except-in "../utils/utils.ss" extend))
+(require "type-environments.ss" 
+	 (utils tc-utils)
+	 "type-env.ss"
+	 (private mutated-vars)
+	 (private type-utils)
+	 (private type-effect-convenience))
 
 (provide (all-defined-out))
 

collects/typed-scheme/env/type-alias-env.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
 
+(require (except-in "../utils/utils.ss" extend))
 (require syntax/boundmap
-         "tc-utils.ss"
+         (utils tc-utils)
          mzlib/trace
          scheme/match)
 

collects/typed-scheme/env/type-env.ss

@@ -1,7 +1,9 @@
 #lang scheme/base
 
+(require (except-in "../utils/utils.ss" extend))
 (require syntax/boundmap
-         "tc-utils.ss" "type-utils.ss")
+         (utils tc-utils)
+	 (private type-utils))
 
 (provide register-type
          finish-register-type

collects/typed-scheme/env/type-environments.ss

@@ -10,8 +10,9 @@
          initial-tvar-env
          with-dotted-env/extend)
 
+(require (prefix-in r: "../utils/utils.ss"))
 (require scheme/match
-         "tc-utils.ss")
+         (r:utils tc-utils))
 
 ;; eq? has the type of equal?, and l is an alist (with conses!)
 (define-struct env (eq? l))

collects/typed-scheme/env/type-name-env.ss

@@ -1,9 +1,10 @@
 #lang scheme/base
+(require "../utils/utils.ss")
 
 (require syntax/boundmap
          mzlib/trace
-         "tc-utils.ss"
+         (utils tc-utils)
-         "type-utils.ss")
+         (private type-utils))
 
 (provide register-type-name
          lookup-type-name

collects/typed-scheme/infer/constraint-structs.ss

@@ -1,6 +1,7 @@
 #lang scheme/base
 
-(require "type-rep.ss"
+(require (except-in "../utils/utils.ss" extend))
+(require (rep type-rep)
          scheme/contract)
 
 ;; S, T types

collects/typed-scheme/infer/constraints.ss

@@ -1,8 +1,9 @@
 #lang scheme/unit
 
-(require "type-effect-convenience.ss" "type-rep.ss" 
+(require (except-in "../utils/utils.ss" extend))
-         "type-utils.ss" "union.ss" "tc-utils.ss" 
+(require (private type-effect-convenience type-utils union subtype)
-         "subtype.ss" "utils.ss"
+	 (rep type-rep)
+	 (utils tc-utils)
          "signatures.ss" "constraint-structs.ss"
          scheme/match)
 

collects/typed-scheme/infer/dmap.ss

@@ -1,6 +1,8 @@
 #lang scheme/unit
 
-(require "signatures.ss" "utils.ss" "tc-utils.ss" "constraint-structs.ss"
+(require (except-in "../utils/utils.ss" extend))
+(require "signatures.ss" "constraint-structs.ss"
+	 (utils tc-utils)
          scheme/match)
 
 (import constraints^)

collects/typed-scheme/infer/infer-dummy.ss

@@ -0,0 +1,8 @@
+#lang scheme/base
+(require "../utils/utils.ss")
+
+(require (rep type-rep) (utils tc-utils))
+
+(define infer-param (make-parameter (lambda e (int-err "infer not initialized"))))
+(define (unify X S T) ((infer-param) X S T (make-Univ) null))
+(provide unify infer-param)

collects/typed-scheme/infer/infer-unit.ss

@@ -1,12 +1,14 @@
 #lang scheme/unit
 
-(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss"
+(require (except-in "../utils/utils.ss"))
-         "free-variance.ss" 
+(require (rep free-variance type-rep effect-rep rep-utils)
-         (except-in "type-utils.ss" Dotted)
+	 (private type-effect-convenience union subtype remove-intersect)
-         "union.ss" "tc-utils.ss" "type-name-env.ss"
+	 (utils tc-utils)
-         "subtype.ss" "remove-intersect.ss" "signatures.ss" "utils.ss"
+	 (env type-name-env)
+         (except-in (private type-utils) Dotted)
          "constraint-structs.ss"
-         (only-in "type-environments.ss" lookup current-tvars)
+	 "signatures.ss"
+         (only-in (env type-environments) lookup current-tvars)
          scheme/match
          mzlib/etc
          mzlib/trace
@@ -111,15 +113,15 @@
 (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 t-thn-eff t-els-eff)
+    [((arr: ts t #f #f '() t-thn-eff t-els-eff)
-      (arr: ss s #f #f s-thn-eff s-els-eff))
+      (arr: ss s #f #f '() s-thn-eff s-els-eff))
      (cset-meet* 
       (list (cgen/list V X ss ts)
             (cg t s)
             (cgen/eff/list V X t-thn-eff s-thn-eff)
             (cgen/eff/list V X t-els-eff s-els-eff)))]
-    [((arr: ts t t-rest #f t-thn-eff t-els-eff)
+    [((arr: ts t t-rest #f '() t-thn-eff t-els-eff)
-      (arr: ss s s-rest #f s-thn-eff s-els-eff))
+      (arr: ss s s-rest #f '() s-thn-eff s-els-eff))
      (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)))]
@@ -135,8 +137,8 @@
         (list arg-mapping ret-mapping
               (cgen/eff/list V X t-thn-eff s-thn-eff)
               (cgen/eff/list V X t-els-eff s-els-eff))))]
-    [((arr: ts t #f (cons dty dbound) t-thn-eff t-els-eff)
+    [((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff)
-      (arr: ss s #f #f                s-thn-eff s-els-eff))
+      (arr: ss s #f #f                '() s-thn-eff s-els-eff))
      (unless (memq dbound X)
        (fail! S T))
      (unless (<= (length ts) (length ss))
@@ -146,10 +148,10 @@
                         (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 t-thn-eff t-els-eff) s-arr)])
+            [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)])
        (move-vars-to-dmap new-cset dbound vars))]
-    [((arr: ts t #f #f                t-thn-eff t-els-eff)
+    [((arr: ts t #f #f                '() t-thn-eff t-els-eff)
-      (arr: ss s #f (cons dty dbound) s-thn-eff s-els-eff))
+      (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff))
      (unless (memq dbound X)
        (fail! S T))
      (unless (<= (length ss) (length ts))
@@ -159,10 +161,10 @@
                         (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 s-thn-eff s-els-eff))])
+            [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))])
        (move-vars-to-dmap new-cset dbound vars))]
-    [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff)
+    [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
-      (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff))
+      (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
      (unless (= (length ts) (length ss))
        (fail! S T))
      ;; If we want to infer the dotted bound, then why is it in both types?
@@ -175,8 +177,8 @@
         (list arg-mapping darg-mapping ret-mapping
               (cgen/eff/list V X t-thn-eff s-thn-eff)
               (cgen/eff/list V X t-els-eff s-els-eff))))]
-    [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff)
+    [((arr: ts t #f (cons t-dty dbound)  '() t-thn-eff t-els-eff)
-      (arr: ss s #f (cons s-dty dbound*) s-thn-eff s-els-eff))
+      (arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff))
      (unless (= (length ts) (length ss))
        (fail! S T))
      (let* ([arg-mapping (cgen/list V X ss ts)]
@@ -186,8 +188,8 @@
         (list arg-mapping darg-mapping ret-mapping
               (cgen/eff/list V X t-thn-eff s-thn-eff)
               (cgen/eff/list V X t-els-eff s-els-eff))))]
-    [((arr: ts t t-rest #f                  t-thn-eff t-els-eff)
+    [((arr: ts t t-rest #f                  '() t-thn-eff t-els-eff)
-      (arr: ss s #f     (cons s-dty dbound) s-thn-eff s-els-eff))
+      (arr: ss s #f     (cons s-dty dbound) '() s-thn-eff s-els-eff))
      (unless (memq dbound X)
        (fail! S T))
      (if (<= (length ts) (length ss))
@@ -205,11 +207,11 @@
                 [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) s-thn-eff s-els-eff))])
+                                    (make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))])
            (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) t-thn-eff t-els-eff)
+    [((arr: ts t #f     (cons t-dty dbound) '() t-thn-eff t-els-eff)
-      (arr: ss s s-rest #f                  s-thn-eff s-els-eff))
+      (arr: ss s s-rest #f                  '() s-thn-eff s-els-eff))
      (unless (memq dbound X)
        (fail! S T))
      (cond [(< (length ts) (length ss))

collects/typed-scheme/infer/infer.ss

@@ -1,9 +1,10 @@
 #lang scheme/base
 
+(require (except-in "../utils/utils.ss" infer))
 (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss"
          "restrict.ss" "promote-demote.ss"
          (only-in scheme/unit provide-signature-elements)
-         "unit-utils.ss")
+         (utils unit-utils))
          
 (provide-signature-elements restrict^ infer^)
 

collects/typed-scheme/infer/promote-demote.ss

@@ -1,7 +1,8 @@
 #lang scheme/unit
 
-(require "type-effect-convenience.ss" "type-rep.ss" 
+(require "../utils/utils.ss")
-         "type-utils.ss" "union.ss" 
+(require (rep type-rep)
+	 (private type-effect-convenience union type-utils)
          "signatures.ss"
          scheme/list)
 
@@ -26,7 +27,7 @@
              [#:Param in out
                           (make-Param (var-demote in V)
                                           (vp out))]
-             [#:arr dom rng rest drest thn els
+             [#:arr dom rng rest drest kws thn els
                     (cond
                       [(apply V-in? V (append thn els))
                        (make-arr null (Un) Univ #f null null)]
@@ -35,6 +36,8 @@
                                  (vp rng)
                                  (var-demote (car drest) V)
                                  #f
+                                 (for/list ([(kw kwt) (in-pairs kws)])
+                                   (cons kw (var-demote kwt V)))
                                  thn
                                  els)]
                       [else
@@ -44,6 +47,8 @@
                                  (and drest
                                       (cons (var-demote (car drest) V)
                                             (cdr drest)))
+                                 (for/list ([(kw kwt) (in-pairs kws)])
+                                   (cons kw (var-demote kwt V)))
                                  thn
                                  els)])]))
 
@@ -61,7 +66,7 @@
              [#:Param in out
                           (make-Param (var-promote in V)
                                           (vd out))]
-             [#:arr dom rng rest drest thn els
+             [#:arr dom rng rest drest kws thn els
                     (cond
                       [(apply V-in? V (append thn els))
                        (make-arr null (Un) Univ #f null null)]
@@ -70,6 +75,8 @@
                                  (vd rng)
                                  (var-promote (car drest) V)
                                  #f
+                                 (for/list ([(kw kwt) (in-pairs kws)])
+                                   (cons kw (var-promote kwt V)))
                                  thn
                                  els)]
                       [else
@@ -79,5 +86,7 @@
                                  (and drest
                                       (cons (var-promote (car drest) V)
                                             (cdr drest)))
+                                 (for/list ([(kw kwt) (in-pairs kws)])
+                                   (cons kw (var-promote kwt V)))
                                  thn
                                  els)])]))

collects/typed-scheme/infer/restrict.ss

@@ -1,8 +1,8 @@
 #lang scheme/unit
 
-(require "type-rep.ss" 
+(require "../utils/utils.ss")
-         "type-utils.ss" "union.ss" 
+(require (rep type-rep)
-         "subtype.ss" "remove-intersect.ss" 
+	 (private type-utils union remove-intersect subtype)
          "signatures.ss"
          scheme/match)
 

collects/typed-scheme/infer/signatures.ss

@@ -0,0 +1,29 @@
+#lang scheme/base
+(require scheme/unit)
+(provide (all-defined-out))
+
+(define-signature dmap^
+  (dmap-meet))
+
+(define-signature promote-demote^
+  (var-promote var-demote))
+
+(define-signature constraints^
+  (exn:infer?
+   fail-sym
+   ;; inference failure - masked before it gets to the user program
+   (define-syntaxes (fail!)
+     (syntax-rules ()
+       [(_ s t) (raise fail-sym)]))
+   cset-meet cset-meet*
+   no-constraint
+   empty-cset
+   insert
+   cset-combine
+   c-meet))
+
+(define-signature restrict^
+  (restrict))
+
+(define-signature infer^
+  (infer infer/vararg infer/dots))

collects/typed-scheme/no-check.ss

@@ -0,0 +1,5 @@
+#lang scheme/base
+
+(require "private/prims.ss")
+(provide (all-from-out scheme/base)
+	 (all-from-out "private/prims.ss"))

collects/typed-scheme/no-check/lang/reader.ss

@@ -0,0 +1,13 @@
+#lang scheme/base
+(require (prefix-in r: "../../typed-reader.ss")
+         (only-in syntax/module-reader wrap-read-all))
+
+(define (*read in modpath line col pos)
+  (wrap-read-all 'typed-scheme/no-check in r:read modpath #f line col pos))
+
+(define (*read-syntax src in modpath line col pos)
+  (wrap-read-all
+   'typed-scheme/no-check in (lambda (in) (r:read-syntax src in))
+   modpath src line col pos))
+
+(provide (rename-out [*read read] [*read-syntax read-syntax]))

collects/typed-scheme/private/base-env.ss

@@ -3,6 +3,7 @@
 ;; these are libraries providing functions we add types to that are not in scheme/base
 (require
  "extra-procs.ss"
+ "../utils/utils.ss"
  (only-in scheme/list cons? take drop add-between last filter-map)
  (only-in rnrs/lists-6 fold-left)
  '#%paramz
@@ -15,13 +16,12 @@
 ;; these are all for constructing the types given to variables
 (require (for-syntax
           scheme/base
-          "init-envs.ss"
+          (env init-envs)          
-          "effect-rep.ss"
+          (except-in (rep effect-rep type-rep) make-arr)
-          (except-in "type-rep.ss" make-arr)
           "type-effect-convenience.ss"
           (only-in "type-effect-convenience.ss" [make-arr* make-arr])
           "union.ss"
-          "tc-structs.ss"))
+          (typecheck tc-structs)))
 
 (define-for-syntax (initialize-others) 
   (d-s date 
@@ -57,6 +57,9 @@
               [qq-append qq-append-ty]
               [id ty] ...)))]))
 
+(define-for-syntax (one-of/c . args)
+  (apply Un (map -val args)))
+
 
 (define-initial-env initial-env
   ;; make-promise
@@ -145,9 +148,13 @@
      [string-append (->* null -String -String)]
      [open-input-string (-> -String -Input-Port)]
      [open-output-file 
-      (cl->
+      (->key -Pathlike
-       [(-Pathlike) -Port]
+             #:mode (one-of/c 'binary 'text) #f
-       [(-Pathlike Sym) -Port])]
+             #:exists (one-of/c 'error 'append 'update 'can-update                                
+                                'replace 'truncate                                
+                                'must-truncate 'truncate/replace) 
+             #f
+             -Output-Port)]
      [read (cl-> 
             [(-Port) -Sexp]
             [() -Sexp])]
@@ -206,8 +213,6 @@
                      (cl-> [((-lst a) (-lst a)) (-lst a)]
                            [((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))]
           
-     [call-with-values (-poly (a b) (-> (-> a) (-> a b) b))]
-     
      (error 
       (make-Function (list 
                       (make-arr null (Un))
@@ -246,7 +251,6 @@
      (- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N)))
      (max (->* (list N) N N))
      (min (->* (list N) N N))
-     [values  (make-Poly '(a) (-> (-v a) (-v a)))]
      [vector-ref 
       (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))]
      [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))]
@@ -467,7 +471,7 @@
                 [(-Bytes N) -Bytes]
                 [(-Bytes N N) -Bytes])]
      [bytes-length (-> -Bytes N)]
-     [open-input-file (-> -Pathlike -Input-Port)]
+     [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 (cl->
@@ -553,8 +557,11 @@
      [syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a))
                                         (-> (-Syntax Univ) Univ Univ)))]
      
-     [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
+     [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
-     [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> .  b))]
+     [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> .  b))]
+  
+     [eof (-val eof)]
+     [read-accept-reader (-Param B B)]
      )
 
 (begin-for-syntax 

collects/typed-scheme/private/base-types.ss

@@ -1,9 +1,10 @@
 #lang scheme/base
 
+(require (except-in "../utils/utils.ss" extend))
 (require (for-syntax
           scheme/base
-          "init-envs.ss"
+          (env init-envs)
-          (except-in "type-rep.ss" make-arr)
+          (except-in (rep type-rep) make-arr)
           "type-effect-convenience.ss"
           (only-in "type-effect-convenience.ss" [make-arr* make-arr])
           "union.ss"))

collects/typed-scheme/private/extra-procs.ss

@@ -1,5 +1,5 @@
 #lang scheme/base
-(provide assert call-with-values* values*)
+(provide assert call-with-values* values* foo)
 
 (define (assert v)
   (unless v
@@ -16,3 +16,6 @@
 
 (define call-with-values* call-with-values)
 (define values* values)
+
+(define (foo x #:bar [bar #f])
+  bar)

collects/typed-scheme/private/infer-dummy.ss

@@ -1,7 +0,0 @@
-#lang scheme/base
-
-(require "type-rep.ss")
-
-(define infer-param (make-parameter (lambda e (error 'infer "not initialized"))))
-(define (unify X S T) ((infer-param) X S T (make-Univ) null))
-(provide unify infer-param)

collects/typed-scheme/private/mutated-vars.ss

@@ -14,12 +14,11 @@
   ;; syntax -> void
   (define (fmv/list lstx)
     (for-each find-mutated-vars (syntax->list lstx)))
-  ;(printf "called with ~a~n" (syntax->datum form))
+  ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form)))
   (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal)     
     ;; what we care about: set!
     [(set! v e)
      (begin
-       ;(printf "mutated var found: ~a~n" (syntax-e #'v))
        (module-identifier-mapping-put! table #'v #t))]
     [(define-values (var ...) expr)
      (find-mutated-vars #'expr)]
@@ -28,15 +27,13 @@
     [(begin0 . rest) (fmv/list #'rest)]
     [(#%plain-lambda _ . rest) (fmv/list #'rest)]
     [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))]
-    [(if e1 e2) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e2))]
+    [(if . es) (fmv/list #'es)]
-    [(if e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))]
+    [(with-continuation-mark . es) (fmv/list #'es)]
-    [(with-continuation-mark e1 e2 e3) (begin (find-mutated-vars #'e1) 
-                                              (find-mutated-vars #'e1)
-                                              (find-mutated-vars #'e3))]
     [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
                                          (fmv/list #'b))]
     [(letrec-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)]))
 

collects/typed-scheme/private/parse-type.ss

@@ -2,15 +2,14 @@
 
 (provide parse-type parse-type/id)
 
-(require (except-in "type-rep.ss" make-arr)
+(require (except-in "../utils/utils.ss" extend))
+(require (except-in (rep type-rep) make-arr)
          "type-effect-convenience.ss"
          (only-in "type-effect-convenience.ss" [make-arr* make-arr])
-         "tc-utils.ss"
+         (utils tc-utils)
          "union.ss"
          syntax/stx
-         (except-in "type-environments.ss")
+         (env type-environments type-name-env type-alias-env)
-         "type-name-env.ss"
-         "type-alias-env.ss"
 	 "type-utils.ss"
          scheme/match)
 
@@ -213,7 +212,7 @@
           ;(printf "found a type name ~a~n" #'id)
           (make-Name #'id)]
          [else
-          (tc-error/delayed "unbound type ~a" (syntax-e #'id))
+          (tc-error/delayed "unbound type name ~a" (syntax-e #'id))
           Univ])]
 
       [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")]

collects/typed-scheme/private/prims.ss

@@ -22,20 +22,20 @@ This file defines two sorts of primitives. All of them are provided into any mod
 (provide (all-defined-out)
 	 (rename-out [define-typed-struct define-struct:]))
 
+(require (except-in "../utils/utils.ss" extend))
 (require (for-syntax 
           scheme/base
-          "type-rep.ss"
+          (rep type-rep)
           mzlib/match
           "parse-type.ss"
           syntax/struct
           syntax/stx
-          "utils.ss"
+	  (utils utils tc-utils)
-          "tc-utils.ss"
+          (env type-name-env)
-          "type-name-env.ss"
           "type-contract.ss"))
 
 (require "require-contract.ss"
-         "internal-forms.ss"
+         (typecheck internal-forms)
          (except-in mzlib/contract ->)
          (only-in mzlib/contract [-> c->])
          mzlib/struct

collects/typed-scheme/private/remove-intersect.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
 
-(require "type-rep.ss" "union.ss" "subtype.ss"
+(require (except-in "../utils/utils.ss" extend))
-         "type-utils.ss" "resolve-type.ss" "type-effect-convenience.ss"         
+(require (rep type-rep)
+	 (private union subtype resolve-type type-effect-convenience type-utils)
          mzlib/plt-match mzlib/trace)
 
 (provide (rename-out [*remove remove]) overlap)

collects/typed-scheme/private/resolve-type.ss

@@ -1,6 +1,7 @@
 #lang scheme/base
+(require "../utils/utils.ss")
 
-(require "type-rep.ss"  "type-name-env.ss" "tc-utils.ss"
+(require (rep type-rep)  (env type-name-env) (utils tc-utils)
          "type-utils.ss"
          mzlib/plt-match
          mzlib/trace)

collects/typed-scheme/private/subtype.ss

@@ -1,12 +1,13 @@
 #lang scheme/base
+(require "../utils/utils.ss")
 
-(require (except-in "type-rep.ss" sub-eff) "type-utils.ss"
+(require (except-in (rep type-rep effect-rep) sub-eff)
-         "tc-utils.ss"
+         (utils tc-utils)
-         "effect-rep.ss"
+	 "type-utils.ss"
          "type-comparison.ss"
          "resolve-type.ss"
-         "type-name-env.ss"
+         (env type-name-env)
-         (only-in "infer-dummy.ss" unify)
+         (only-in (infer infer-dummy) unify)
          mzlib/plt-match
          mzlib/trace)
 
@@ -100,10 +101,13 @@
     (match (list s t)
       ;; top for functions is above everything
       [(list _ (top-arr:)) A0]
-      [(list (arr: s1 s2 #f #f thn-eff els-eff) (arr: t1 t2 #f #f thn-eff  els-eff))
+      [(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) 
-       (let ([A1 (subtypes* A0 t1 s1)])
+             (arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff  els-eff))       
+       (let* ([A1 (subtypes* A0 t1 s1)]
+              [A2 (subtypes* A1 t-kw-ty s-kw-ty)])
          (subtype* A1 s2 t2))]
-      [(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*))
+      [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff)
+             (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*))
        (unless 
            (or (and (null? thn-eff*) (null? els-eff*))
                (and (effects-equal? thn-eff thn-eff*)
@@ -115,10 +119,11 @@
                 (andmap sub-eff els-eff els-eff*)))
          (fail! s t))
        ;; either the effects have to be the same, or the supertype can't have effects
-       (let ([A (subtypes*/varargs A0 t1 s1 s3)])
+       (let* ([A2 (subtypes*/varargs A0 t1 s1 s3)]
+              [A3 (subtypes* A2 t-kw-ty s-kw-ty)])
          (if (not t3)
-             (subtype* A s2 t2)
+             (subtype* A3 s2 t2)
-             (let ([A1 (subtype* A t3 s3)])
+             (let ([A1 (subtype* A3 t3 s3)])
                (subtype* A1 s2 t2))))]
       [else 
        (fail! s t)])))

collects/typed-scheme/private/type-annotation.ss

@@ -1,7 +1,11 @@
 #lang scheme/base
 
-(require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss"
+(require (except-in "../utils/utils.ss" extend))
-         "type-env.ss" "type-effect-convenience.ss" "resolve-type.ss" "union.ss"
+(require (rep type-rep)
+	 (utils tc-utils)
+	 (env type-env)
+	 "parse-type.ss" "subtype.ss"
+         "type-effect-convenience.ss" "resolve-type.ss" "union.ss"
          scheme/match mzlib/trace)
 (provide type-annotation
          get-type

collects/typed-scheme/private/type-comparison.ss

@@ -1,3 +1,4 @@
 #lang scheme/base
-(require "type-rep.ss" "type-utils.ss")
+(require "../utils/utils.ss")
+(require (rep type-rep) "type-utils.ss")
 (provide type-equal? tc-result-equal? type<? type-compare effects-equal?)

collects/typed-scheme/private/type-contract.ss

@@ -2,14 +2,14 @@
 
 (provide type->contract define/fixup-contract? generate-contract-def change-contract-fixups)
 
+(require (except-in "../utils/utils.ss" extend))
 (require
- "type-rep.ss"   
+ (rep type-rep)
+ (typecheck internal-forms)
+ (utils tc-utils)
+ (env type-name-env)
  "parse-type.ss"
- "utils.ss"      
- "type-name-env.ss"
  "require-contract.ss"
- "internal-forms.ss"
- "tc-utils.ss"
  "resolve-type.ss"
  "type-utils.ss"   
  (only-in "type-effect-convenience.ss" Any-Syntax)
@@ -80,13 +80,13 @@
            (define (f a)
              (define-values (dom* rngs* rst)
                (match a
-                 [(arr: dom (Values: rngs) #f #f _ _)
+                 [(arr: dom (Values: rngs) #f #f '() _ _)
                   (values (map t->c dom) (map t->c rngs) #f)]
-                 [(arr: dom rng #f #f _ _)
+                 [(arr: dom rng #f #f '() _ _)
                   (values (map t->c dom) (list (t->c rng)) #f)]
-                 [(arr: dom (Values: rngs) rst #f _ _)
+                 [(arr: dom (Values: rngs) rst #f '() _ _)
                   (values (map t->c dom) (map t->c rngs) (t->c rst))]
-                 [(arr: dom rng rst #f _ _)
+                 [(arr: dom rng rst #f '() _ _)
                   (values (map t->c dom) (list (t->c rng)) (t->c rst))]))
              (with-syntax 
                  ([(dom* ...) dom*]

collects/typed-scheme/private/type-effect-convenience.ss

@@ -1,14 +1,16 @@
 #lang scheme/base  
-(require "type-rep.ss" 
+(require "../utils/utils.ss")
-         "effect-rep.ss"
+
+(require (rep type-rep effect-rep)
+         (utils tc-utils)
          scheme/match
          "type-comparison.ss"
          "type-effect-printer.ss"
          "union.ss"
          "subtype.ss"
          "type-utils.ss" 
-         "tc-utils.ss"
          scheme/promise
+         (for-syntax macro-debugger/stxclass/stxclass)
          (for-syntax scheme/base))
 
 (provide (all-defined-out))
@@ -33,7 +35,7 @@
     [(Latent-Remove-Effect: t) (make-Remove-Effect t v)]
     [(True-Effect:) eff]
     [(False-Effect:) eff]
-    [_ (error 'internal-tc-error "can't add var to effect ~a" eff)]))
+    [_ (int-err "can't add var ~a to effect ~a" v eff)]))
 
 (define-syntax (-> stx)
   (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
@@ -78,11 +80,26 @@
       [(Function: as) as]))
   (make-Function (map car (map funty-arities args))))
 
+(define-syntax (->key stx)
+  (syntax-parse stx
+                [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng)
+                 #'(make-Function
+                    (list
+                     (make-arr* (list ty ...)
+                                rng
+                                #f
+                                #f
+                                (list (make-Keyword 'k kty opt) ...)
+                                null
+                                null)))]))
+
 (define make-arr*
-  (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))]
+  (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))]
-               [(dom rng rest) (make-arr dom rng rest #f (list) (list))]
+               [(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
-               [(dom rng rest eff1 eff2) (make-arr dom rng rest #f eff1 eff2)]
+               [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
-               [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest eff1 eff2)]))
+               [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]
+               [(dom rng rest drest kws eff1 eff2)
+                (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword<?) eff1 eff2)]))
 
 (define (make-arr-dots dom rng dty dbound)
   (make-arr* dom rng #f (cons dty dbound) null null))

collects/typed-scheme/private/type-effect-printer.ss

@@ -1,5 +1,9 @@
 #lang scheme/base
-(require "type-rep.ss" "effect-rep.ss" "rep-utils.ss" "tc-utils.ss" "planet-requires.ss" scheme/match)
+
+(require "../utils/utils.ss")
+(require (rep type-rep effect-rep rep-utils)
+	 (utils planet-requires tc-utils)
+	 scheme/match)
 
 ;; do we attempt to find instantiations of polymorphic types to print? 
 ;; FIXME - currently broken
@@ -46,9 +50,15 @@
     (match a
       [(top-arr:)
        (fp "Procedure")]
-      [(arr: dom rng rest drest thn-eff els-eff)
+      [(arr: dom rng rest drest kws thn-eff els-eff)
        (fp "(")
        (for-each (lambda (t) (fp "~a " t)) dom)
+       (for ([kw kws])
+         (match kw
+           [(Keyword: k t req?)
+            (if req?
+                (fp "~a ~a " k t)
+                (fp "[~a ~a] " k t))]))
        (when rest
          (fp "~a* " rest))
        (when drest
@@ -102,7 +112,7 @@
                           (lambda (e) (fp " ") (print-arr e))
                           b)
                          (fp ")")]))]
-    [(arr: _ _ _ _ _ _) (print-arr c)]
+    [(arr: _ _ _ _ _ _ _) (print-arr c)]
     [(Vector: e) (fp "(Vectorof ~a)" e)]
     [(Box: e) (fp "(Box ~a)" e)]
     [(Union: elems) (fp "~a" (cons 'U elems))]

collects/typed-scheme/private/type-utils.ss

@@ -1,10 +1,10 @@
 #lang scheme/base
 
-(require "type-rep.ss"
+(require "../utils/utils.ss")
-         "effect-rep.ss"
+
-         "tc-utils.ss"
+(require (rep type-rep effect-rep rep-utils)
-         "rep-utils.ss"
+         (utils tc-utils)
-         (only-in "free-variance.ss" combine-frees)
+         (only-in (rep free-variance) combine-frees)
          mzlib/plt-match
          scheme/list
          mzlib/trace
@@ -37,7 +37,7 @@
   (if (hash-ref (free-vars* target) name #f)
       (type-case sb target
                  [#:F name* (if (eq? name* name) image target)]
-                 [#:arr dom rng rest drest thn-eff els-eff
+                 [#:arr dom rng rest drest kws thn-eff els-eff
                         (begin
                           (when (and (pair? drest)
                                      (eq? name (cdr drest))
@@ -47,6 +47,8 @@
                                     (sb rng)
                                     (and rest (sb rest))
                                     (and drest (cons (sb (car drest)) (cdr drest)))
+                                    (for/list ([kw kws])
+                                      (cons (car kw) (sb (cdr kw))))
                                     (map (lambda (e) (sub-eff sb e)) thn-eff)
                                     (map (lambda (e) (sub-eff sb e)) els-eff)))]
                  [#:ValuesDots types dty dbound
@@ -70,7 +72,7 @@
                                      (let ([expanded (sb dty)])
                                        (map (lambda (img) (substitute img name expanded)) images))))
                                    (make-ValuesDots (map sb types) (sb dty) dbound))]
-                 [#:arr dom rng rest drest thn-eff els-eff
+                 [#:arr dom rng rest drest kws thn-eff els-eff
                         (if (and (pair? drest)
                                  (eq? name (cdr drest)))                            
                             (make-arr (append 
@@ -81,12 +83,16 @@
                                       (sb rng)
                                       rimage
                                       #f
+                                      (for/list ([kw kws])
+                                        (cons (car kw) (sb (cdr kw))))
                                       (map (lambda (e) (sub-eff sb e)) thn-eff)
                                       (map (lambda (e) (sub-eff sb e)) els-eff))
                             (make-arr (map sb dom)
                                       (sb rng)
                                       (and rest (sb rest))
                                       (and drest (cons (sb (car drest)) (cdr drest)))
+                                      (for/list ([kw kws])
+                                        (cons (car kw) (sb (cdr kw))))
                                       (map (lambda (e) (sub-eff sb e)) thn-eff)
                                       (map (lambda (e) (sub-eff sb e)) els-eff)))])
       target))
@@ -105,13 +111,15 @@
                       (if (eq? name* name)
                           image
                           target)]
-                 [#:arr dom rng rest drest thn-eff els-eff
+                 [#:arr dom rng rest drest kws thn-eff els-eff
                         (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))))
+                                  (for/list ([kw kws])
+                                    (cons (car kw) (sb (cdr kw))))
                                   (map (lambda (e) (sub-eff sb e)) thn-eff)
                                   (map (lambda (e) (sub-eff sb e)) els-eff))])
        target))

collects/typed-scheme/private/union.ss

@@ -1,7 +1,11 @@
 #lang scheme/base
 
-(require "type-rep.ss" "subtype.ss" "tc-utils.ss"
+(require "../utils/utils.ss")
-         "type-effect-printer.ss" "rep-utils.ss"
+
+(require (rep type-rep rep-utils)
+	 (utils tc-utils)
+	 "subtype.ss" 
+         "type-effect-printer.ss" 
          "type-comparison.ss"
          scheme/match mzlib/trace)
 

collects/typed-scheme/rep/free-variance.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
+(require "../utils/utils.ss")
 
 (require (for-syntax scheme/base)
-         "tc-utils.ss"
+         (utils tc-utils)
          mzlib/etc)
 
 ;; this file contains support for calculating the free variables/indexes of types
@@ -27,8 +28,8 @@
 (define var-table (make-weak-hasheq))
 ;; maps Type to List[Cons[Symbol,Variance]]
 
-(define (free-idxs* t) (hash-ref index-table t (lambda _ (error "type not in index-table" (syntax-e t)))))
+(define (free-idxs* t) (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" (syntax-e t)))))
-(define (free-vars* t) (hash-ref var-table t (lambda _ (error "type not in var-table" (syntax-e t)))))
+(define (free-vars* t) (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" (syntax-e t)))))
 
 
 (define empty-hash-table (make-immutable-hasheq null))

collects/typed-scheme/rep/rep-utils.ss

@@ -1,18 +1,18 @@
 #lang scheme/base
+(require "../utils/utils.ss")
 
 (require mzlib/struct 
          mzlib/plt-match
          syntax/boundmap
-         "planet-requires.ss"
+         (utils planet-requires)
          "free-variance.ss"
-         "utils.ss"
          "interning.ss"
          mzlib/etc
          (for-syntax 
           scheme/base
           syntax/struct
           syntax/stx
-          "utils.ss"))
+          (utils utils)))
 
 (provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq)
 
@@ -150,7 +150,9 @@
                      (lambda (s)
                        (... 
                         (syntax-case s ()
-                          [(__ . fs) (quasisyntax/loc s (struct nm #, (syntax/loc #'fs (_ . fs))))]))))
+                          [(__ . fs) 
+                           (with-syntax ([flds** (syntax/loc s (_ . fs))])
+                             (quasisyntax/loc s (struct nm flds**)))]))))
                    (begin-for-syntax
                      (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
                    intern

collects/typed-scheme/rep/type-rep.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
+(require "../utils/utils.ss")
 
-(require "planet-requires.ss" "rep-utils.ss" "effect-rep.ss" "tc-utils.ss"
+(require (utils planet-requires tc-utils) 
-         "free-variance.ss"
+	 "rep-utils.ss" "effect-rep.ss" "free-variance.ss"
          mzlib/trace scheme/match
          (for-syntax scheme/base))
 
@@ -90,16 +91,27 @@
                          pred-id
                          cert)])
 
+;; kw : keyword?
+;; ty : Type
+;; required? : Boolean
+(dt Keyword (kw ty required?)
+    [#:frees (free-vars* ty)
+             (free-idxs* ty)]
+    [#:fold-rhs (*Keyword kw (type-rec-id ty))])
+
 ;; dom : Listof[Type]
 ;; rng : Type
 ;; rest : Option[Type]
 ;; drest : Option[Cons[Type,Name or nat]]
+;; kws : Listof[Keyword]
 ;; rest and drest NOT both true
 ;; thn-eff : Effect
 ;; els-eff : Effect
 ;; arr is NOT a Type
-(dt arr (dom rng rest drest thn-eff els-eff)
+(dt arr (dom rng rest drest kws thn-eff els-eff)
-    [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) dom)))
+    [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null)
+                                                                                (map Keyword-ty kws)
+                                                                                dom)))
                                     (match drest
                                       [(cons t (? symbol? bnd))
                                        (list (fix-bound (flip-variances (free-vars* t)) bnd))]
@@ -108,7 +120,9 @@
                                     (list (free-vars* rng))
                                     (map make-invariant
                                          (map free-vars* (append thn-eff els-eff)))))
-             (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) dom)))
+             (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null)
+                                                                                (map Keyword-ty kws)
+                                                                                dom)))
                                     (match drest
                                       [(cons t (? number? bnd))
                                        (list (fix-bound (flip-variances (free-idxs* t)) bnd))]
@@ -121,6 +135,8 @@
                       (type-rec-id rng)
                       (and rest (type-rec-id rest))
                       (and drest (cons (type-rec-id (car drest)) (cdr drest)))
+                      (for/list ([kw kws])
+                        (cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw)))
                       (map effect-rec-id thn-eff)
                       (map effect-rec-id els-eff))])
 
@@ -248,9 +264,11 @@
             (define cl (quasisyntax/loc src (#,pat #,(body-f rid erid))))
             cl)
           (syntax-case stx ()
-            [(tc rec-id ty [kw pats ... es] ...)
+            [(tc rec-id ty clauses ...)
-             #;(andmap (lambda (k) (keyword? (syntax-e k))) (syntax->list #'(kw ...)))
+             (syntax-case #'(clauses ...) ()
-             (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty [kw pats ... es] ...))]
+               [([kw pats ... es] ...) #t]
+               [_ #f])
+             (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))]
             [(tc rec-id e-rec-id ty clauses  ...)
              (begin 
                (map add-clause (syntax->list #'(clauses ...)))
@@ -296,7 +314,7 @@
        ;; necessary to avoid infinite loops
        [#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
        ;; functions 
-       [#:arr dom rng rest drest thn-eff els-eff
+       [#:arr dom rng rest drest kws thn-eff els-eff
               (*arr (map sb dom)
                     (sb rng)
                     (if rest (sb rest) #f)
@@ -304,6 +322,8 @@
                         (cons (sb (car drest))
                               (if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
                         #f)
+                    (for/list ([kw kws])
+                      (cons (car kw) (sb (cdr kw))))
                     (map (lambda (e) (sub-eff sb e)) thn-eff)
                     (map (lambda (e) (sub-eff sb e)) els-eff))]
        [#:ValuesDots tys dty dbound
@@ -340,7 +360,7 @@
        ;; necessary to avoid infinite loops
        [#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
        ;; functions
-       [#:arr dom rng rest drest thn-eff els-eff
+       [#:arr dom rng rest drest kws thn-eff els-eff
               (*arr (map sb dom)
                     (sb rng)
                     (if rest (sb rest) #f)
@@ -348,6 +368,8 @@
                         (cons (sb (car drest))
                               (if (eqv? (cdr drest) (+ count outer)) (F-n image) (cdr drest)))
                         #f)
+                    (for/list ([kw kws])
+                      (cons (car kw) (sb (cdr kw))))
                     (map (lambda (e) (sub-eff sb e)) thn-eff)
                     (map (lambda (e) (sub-eff sb e)) els-eff))]
        [#:ValuesDots tys dty dbound
@@ -401,7 +423,7 @@
   (match t
     [(Poly: n scope)
      (unless (= (length names) n)
-       (error "Wrong number of names"))
+       (int-err "Wrong number of names: expected ~a got ~a" n (length names)))
      (instantiate-many (map *F names) scope)]))
 
 ;; the 'smart' constructor
@@ -416,7 +438,7 @@
   (match t
     [(PolyDots: n scope)
      (unless (= (length names) n)
-       (error "Wrong number of names"))
+       (int-err "Wrong number of names: expected ~a got ~a" n (length names)))
      (instantiate-many (map *F names) scope)]))
 
 (print-struct #t)

collects/typed-scheme/typecheck/check-subforms-unit.ss

@@ -1,15 +1,12 @@
 #lang scheme/unit
 
+(require (except-in "../utils/utils.ss" extend))
 (require syntax/kerncase
          scheme/match
          "signatures.ss"
-         "type-utils.ss"
+         (private type-utils type-effect-convenience union subtype)
-         "type-rep.ss" ;; doesn't need tests
+	 (utils tc-utils)
-         "type-effect-convenience.ss" ;; maybe needs tests
+	 (rep type-rep))
-         "union.ss"
-         "subtype.ss" ;; has tests
-         "tc-utils.ss" ;; doesn't need tests
-         )
 
 (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
 (export check-subforms^)
@@ -21,7 +18,7 @@
   (define body-ty #f)    
   (define (get-result-ty t)
     (match t
-      [(Function: (list (arr: _ rngs #f _ _ _) ...)) (apply Un rngs)]
+      [(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)]
       [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)]))
   (let loop ([form form])
     (parameterize ([current-orig-stx form])

collects/typed-scheme/typecheck/provide-handling.ss

@@ -1,11 +1,12 @@
 #lang scheme/base
 
+(require (except-in "../utils/utils.ss" extend))
 (require (only-in srfi/1/list s:member)
          syntax/kerncase 
          mzlib/trace
-         "type-contract.ss"
+         (private type-contract)
-         "type-rep.ss"
+         (rep type-rep)
-         "tc-utils.ss"
+	 (utils tc-utils)
          "def-binding.ss")
 
 (require (for-template scheme/base

collects/typed-scheme/typecheck/signatures.ss

@@ -2,41 +2,11 @@
 (require scheme/unit)
 (provide (all-defined-out))
 
-(define-signature dmap^
-  (dmap-meet))
-
-(define-signature promote-demote^
-  (var-promote var-demote))
-
-(define-signature constraints^
-  (exn:infer?
-   fail-sym
-   ;; inference failure - masked before it gets to the user program
-   (define-syntaxes (fail!)
-     (syntax-rules ()
-       [(_ s t) (raise fail-sym)]))
-   cset-meet cset-meet*
-   no-constraint
-   empty-cset
-   insert
-   cset-combine
-   c-meet))
-
-(define-signature restrict^
-  (restrict))
-
-(define-signature infer^
-  (infer infer/vararg infer/dots))
-
-
-
-;; cycle 2
-
 (define-signature typechecker^
   (type-check tc-toplevel-form))
 
 (define-signature tc-expr^
-  (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t #;check-expr))
+  (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t))
 
 (define-signature check-subforms^
   (check-subforms/ignore check-subforms/with-handlers check-subforms/with-handlers/check))

collects/typed-scheme/typecheck/tc-app-unit.ss

@@ -1,19 +1,13 @@
 #lang scheme/unit
 
+(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer]))
 (require "signatures.ss"
-         "type-rep.ss"
+         (rep type-rep effect-rep)
-         "effect-rep.ss"
+	 (utils tc-utils)
-         "tc-utils.ss"
+	 (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type
-         "subtype.ss"
+		  type-annotation)
-         "infer.ss"
+         (r:infer infer)
-         (only-in "utils.ss" debug in-syntax printf/log in-pairs)
+	 (env type-environments)
-         "union.ss"
-         "type-utils.ss"
-         "type-effect-convenience.ss"
-         "type-effect-printer.ss"
-         "type-annotation.ss"
-         "resolve-type.ss"
-         "type-environments.ss"
          (only-in srfi/1 alist-delete)
          (only-in scheme/private/class-internal make-object do-make-object)
          mzlib/trace mzlib/pretty syntax/kerncase scheme/match
@@ -21,7 +15,7 @@
          (for-template 
           "internal-forms.ss" scheme/base 
           (only-in scheme/private/class-internal make-object do-make-object)))
-(require "constraint-structs.ss")
+(require (r:infer constraint-structs))
 
 (import tc-expr^ tc-lambda^ tc-dots^)
 (export tc-app^)
@@ -159,7 +153,7 @@
   (define-values (fixed-args tail) (split (syntax->list args)))
 
   (match f-ty
-    [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...)))
+    [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...)))
      (when (null? doms)
        (tc-error/expr #:return (ret (Un))
                       "empty case-lambda given as argument to apply"))
@@ -204,7 +198,7 @@
                 (printf/log "Non-poly apply, ... arg\n")
                 (ret (car rngs*))]
                [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
-    [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1))))
+    [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..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))])
@@ -214,7 +208,7 @@
        (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
          (cond [(null? doms*)
                 (match f-ty 
-                  [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1))))
+                  [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
                    (tc-error/expr #:return (ret (Un))
                                  (string-append 
                                   "Bad arguments to polymorphic function in apply:~n"
@@ -259,14 +253,14 @@
      (tc-error/expr #:return (ret (Un))
                     "Function has no cases")]
     [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var))
-                            (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1))))
+                            (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..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-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1))))
+                  [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
                    (tc-error/expr #:return (ret (Un))
                                  (string-append 
                                   "Bad arguments to polymorphic function in apply:~n"
@@ -378,8 +372,8 @@
 
 (define (poly-fail t argtypes #:name [name #f])
   (match t
-    [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))
+    [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))
-         (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))))
+         (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))))
      (let ([fcn-string (if name
                            (format "function ~a (over ~~a)" (syntax->datum name))
                            "function over ~a")])
@@ -429,7 +423,8 @@
                              "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
                              (length argtypes))])]
         ;; single clause functions
-        [(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs))))
+        ;; FIXME - error on non-optional keywords
+        [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs))))
                      thn-eff els-eff)
          (let-values ([(thn-eff els-eff)
                        (tc-args argtypes arg-thn-effs arg-els-effs dom rest 
@@ -437,7 +432,7 @@
                                 (syntax->list args))])
            (ret rng thn-eff els-eff))]
         ;; non-polymorphic case-lambda functions
-        [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1)))
+        [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1)))
                      thn-eff els-eff)
          (let loop ([doms* doms] [rngs rngs] [rests* rests])
            (cond [(null? doms*) 
@@ -453,19 +448,19 @@
         ;; simple polymorphic functions, no rest arguments
         [(tc-result: (and t
                           (or (Poly: vars 
-                                     (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))
+                                     (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))
                               (PolyDots: (list vars ... _)
-                                         (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))))))
+                                         (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))))))
          (handle-clauses (doms rngs) f-stx
                          (lambda (dom _) (= (length dom) (length argtypes)))
                          (lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected))
                          t argtypes expected)]
         ;; polymorphic varargs
         [(tc-result: (and t
-                          (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))
+                          (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))
                               ;; we want to infer the dotted-var here as well, and we don't use these separately
                               ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var)
-                              (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))))))
+                              (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))))))
          (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx))
          (handle-clauses (doms rests rngs) f-stx
                          (lambda (dom rest rng) (<= (length dom) (length argtypes)))
@@ -474,7 +469,7 @@
         ;; polymorphic ... type
         [(tc-result: (and t (PolyDots: 
                              (and vars (list fixed-vars ... dotted-var))
-                             (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...)))))
+                             (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...)))))
          (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx))
          (handle-clauses (doms dtys dbounds rngs) f-stx
                          (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes))
@@ -566,6 +561,47 @@
         [(tc-result: t)
          (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
 
+(define (tc-keywords form arities kws kw-args pos-args expected)
+  (match arities
+    [(list (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))]
+                [formals ktys])
+       (match* (actual-kws formals)
+         [('() '())
+          (void)]
+         [(_ '())
+          (tc-error/expr #:return (ret (Un))
+                         "Unexpected keyword argument ~a" (car actual-kws))]
+         [('() (cons fst rst))
+          (match fst
+            [(Keyword: k _ #t)
+             (tc-error/expr #:return (ret (Un))
+                            "Missing keyword argument ~a" k)]
+            [_ (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)]
+                [req? ;; this keyword argument was required
+                 (tc-error/delayed "Missing keyword argument ~a" k*)
+                 (loop kws-rest (cdr actuals) form-rest)]
+                [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 arities)) (map tc-expr (syntax->list pos-args)) expected)]
+    [_ (int-err "case-lambda w/ keywords not supported")]))
+
+
+(define (type->list t)
+  (match t
+    [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))]
+    [(Value: '()) null]
+    [_ (int-err "bad value in type->list: ~a" t)]))
+
 (define (tc/app/internal form expected)
   (kernel-syntax-case* form #f 
     (values apply not list list* call-with-values do-make-object make-object cons
@@ -585,7 +621,7 @@
            [(Values: ts) ts]
            [_ (list t)]))
        (match prod-t
-         [(Function: (list (arr: (list) vals _ #f _ _)))
+         [(Function: (list (arr: (list) vals _ #f '()  _ _)))
           (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
          [_ (tc-error/expr #:return (ret (Un)) 
                            "First argument to call with values must be a function that can accept no arguments, got: ~a"
@@ -622,10 +658,22 @@
         (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
     ;; special case for `apply'
     [(#%plain-app apply f . args) (tc/apply #'f #'args)]
+    ;; special case for keywords
+    [(#%plain-app
+      (#%plain-app kpe kws num fn)
+      kw-list
+      (#%plain-app list . kw-arg-list)
+      . pos-args)
+     (eq? (syntax-e #'kpe) 'keyword-procedure-extract)
+     (match (tc-expr #'fn)
+       [(tc-result: (Function: arities)) 
+        (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
+       [t (tc-error/expr #:return (ret (Un))
+                         "Cannot apply expression of type ~a, since it is not a function type" t)])]
     ;; even more special case for match
     [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
      (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))
-     (let-loop-check #'form #'lp #'actuals #'args #'body expected)]
+     (let-loop-check form #'lp #'actuals #'args #'body expected)]
     ;; or/andmap of ... argument
     [(#%plain-app or/andmap f arg)
      (and 

collects/typed-scheme/typecheck/tc-dots-unit.ss

@@ -1,10 +1,11 @@
 #lang scheme/unit
 
+(require (except-in "../utils/utils.ss" extend))
 (require "signatures.ss"
-         "tc-utils.ss"
+         (utils tc-utils)
-         "type-environments.ss"
+         (env type-environments)
-         "type-utils.ss"
+         (private type-utils)
-         "type-rep.ss"
+         (rep type-rep)
          syntax/kerncase
          scheme/match)
 

collects/typed-scheme/typecheck/tc-expr-unit.ss

@@ -1,21 +1,15 @@
 #lang scheme/unit
 
 
+(require (rename-in "../utils/utils.ss" [private r:private]))
 (require syntax/kerncase
          scheme/match
          "signatures.ss"
-         "type-utils.ss"
+         (r:private type-utils type-effect-convenience union subtype parse-type type-annotation)
-         "utils.ss" ;; doesn't need tests
+         (rep type-rep effect-rep)
-         "type-rep.ss" ;; doesn't need tests
+         (utils tc-utils)
-         "type-effect-convenience.ss" ;; maybe needs tests
+         (env lexical-env)
-         "union.ss"
+         (only-in (env type-environments) lookup current-tvars extend-env)
-         "subtype.ss" ;; has tests
-         "parse-type.ss" ;; has tests
-         "tc-utils.ss" ;; doesn't need tests
-         "lexical-env.ss" ;; maybe needs tests
-         "type-annotation.ss" ;; has tests
-         "effect-rep.ss"
-         (only-in "type-environments.ss" lookup current-tvars extend-env)
          scheme/private/class-internal
          (only-in srfi/1 split-at))
 
@@ -41,7 +35,7 @@
     [(null? v) (-val null)]
     [(symbol? v) (-val v)]
     [(string? v) -String]
-    [(keyword? v) -Keyword]
+    [(keyword? v) (-val v)]
     [(bytes? v) -Bytes]
     [(list? v) (-Tuple (map tc-literal v))]
     [(vector? v) (make-Vector (types-of-literals (vector->list v)))]
@@ -101,7 +95,8 @@
 ;; typecheck an expression, but throw away the effect
 ;; tc-expr/t : Expr -> Type
 (define (tc-expr/t e) (match (tc-expr e)
-                        [(tc-result: t) t]))
+                        [(tc-result: t) t]
+			[t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))]))
 
 (define (tc-expr/check/t e t)
   (match (tc-expr/check e t)

collects/typed-scheme/typecheck/tc-if-unit.ss

@@ -1,20 +1,15 @@
 #lang scheme/unit
 
-(require "planet-requires.ss"
+(require (rename-in "../utils/utils.ss" [infer r:infer]))
+(require (utils planet-requires)
          "signatures.ss"
-         "type-rep.ss" ;; doesn't need tests
+         (rep type-rep effect-rep)
-         "type-effect-convenience.ss" ;; maybe needs tests
+         (private type-effect-convenience subtype union type-utils type-comparison mutated-vars)
-         "lexical-env.ss" ;; maybe needs tests
+         (env lexical-env)
-         "effect-rep.ss"
+         (only-in (private remove-intersect)
-         "mutated-vars.ss"
-         "subtype.ss"
-         (only-in "remove-intersect.ss" 
                   [remove *remove])
-         "infer.ss"
+         (r:infer infer)
-         "union.ss"
+	 (utils tc-utils)
-         "type-utils.ss"
-         "tc-utils.ss"
-         "type-comparison.ss"
          syntax/kerncase
          mzlib/trace
          mzlib/plt-match)

collects/typed-scheme/typecheck/tc-lambda-unit.ss

@@ -1,20 +1,15 @@
 #lang scheme/unit
 
+(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]))
 (require "signatures.ss"
          mzlib/trace
          scheme/list
-         (except-in "type-rep.ss" make-arr) ;; doesn't need tests
+         (except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests
-         "type-effect-convenience.ss" ;; maybe needs tests
+         (private type-effect-convenience type-annotation union type-utils)
-         "type-environments.ss" ;; doesn't need tests
+	 (env type-environments lexical-env)
-         "lexical-env.ss" ;; maybe needs tests
+	 (utils tc-utils)
-         "type-annotation.ss" ;; has tests
-         (except-in "utils.ss" extend)
-         "type-utils.ss"
-         "effect-rep.ss"
-         "tc-utils.ss"
-         "union.ss"
          mzlib/plt-match
-         (only-in "type-effect-convenience.ss" [make-arr* make-arr]))
+         (only-in (private type-effect-convenience) [make-arr* make-arr]))
 (require (for-template scheme/base "internal-forms.ss"))
 
 (import tc-expr^)
@@ -180,7 +175,7 @@
       (let loop ([expected expected])        
         (match expected          
           [(Mu: _ _) (loop (unfold expected))]
-          [(Function: (list (arr: argss rets rests drests _ _) ...)) 
+          [(Function: (list (arr: argss rets rests drests '() _ _) ...)) 
            (for ([args argss] [ret rets] [rest rests] [drest drests])
              (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))
            expected]

collects/typed-scheme/typecheck/tc-let-unit.ss

@@ -1,14 +1,9 @@
 #lang scheme/unit
 
+(require (rename-in "../utils/utils.ss" [infer r:infer]))
 (require "signatures.ss"
-         "type-effect-convenience.ss"
+         (private type-effect-convenience type-annotation parse-type type-utils)
-         "lexical-env.ss"
+	 (env lexical-env type-alias-env type-env)
-         "type-annotation.ss"
-         "type-alias-env.ss"
-         "type-env.ss"
-         "parse-type.ss"
-         "utils.ss"
-         "type-utils.ss"
          syntax/free-vars
          mzlib/trace
          scheme/match

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

@@ -1,15 +1,12 @@
 #lang scheme/base
 
-(require "type-rep.ss" ;; doesn't need tests
+(require (except-in "../utils/utils.ss" extend))
-         "type-effect-convenience.ss" ;; maybe needs tests
+(require (rep type-rep)
-         "type-env.ss" ;; maybe needs tests
+	 (private type-effect-convenience
-         "type-utils.ss"
+		  type-utils parse-type
-         "parse-type.ss" ;; has tests
+		  union resolve-type)
-         "type-environments.ss" ;; doesn't need tests
+	 (env type-env type-environments type-name-env)
-         "type-name-env.ss" ;; maybe needs tests
+	 (utils tc-utils)
-         "union.ss"
-         "tc-utils.ss"
-         "resolve-type.ss"
          "def-binding.ss"
          syntax/kerncase
          syntax/struct

collects/typed-scheme/typecheck/tc-toplevel.ss

@@ -1,26 +1,17 @@
 #lang scheme/unit
 
 
+(require (rename-in "../utils/utils.ss" [infer r:infer]))
 (require syntax/kerncase
          mzlib/etc
          scheme/match
          "signatures.ss"
          "tc-structs.ss"
-         "type-utils.ss"
+         (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract)
-         "utils.ss" ;; doesn't need tests
+	 (env type-env init-envs type-name-env type-alias-env)
-         "type-effect-convenience.ss" ;; maybe needs tests
+	 (utils tc-utils)
-         "internal-forms.ss" ;; doesn't need tests
-         "type-env.ss" ;; maybe needs tests
-         "parse-type.ss" ;; has tests
-         "tc-utils.ss" ;; doesn't need tests
-         "type-annotation.ss" ;; has tests
-         "type-name-env.ss" ;; maybe needs tests
-         "init-envs.ss"
-         "mutated-vars.ss"
-         "def-binding.ss"
 	 "provide-handling.ss"
-         "type-alias-env.ss"
+         "def-binding.ss"
-         "type-contract.ss"
          (for-template
           "internal-forms.ss"
           mzlib/contract

collects/typed-scheme/typecheck/typechecker.ss

@@ -1,6 +1,7 @@
 #lang scheme/base
 
-(require "unit-utils.ss"
+(require "../utils/utils.ss")
+(require (utils unit-utils)
          mzlib/trace
          (only-in scheme/unit provide-signature-elements)
          "signatures.ss" "tc-toplevel.ss"         

collects/typed-scheme/typed-scheme.ss

@@ -1,22 +1,18 @@
 #lang scheme/base
 
-(require "private/base-env.ss"
+(require (rename-in "utils/utils.ss" [infer r:infer]))
-         "private/base-types.ss"
+
+(require (private base-env base-types)
          (for-syntax 
           scheme/base
-          "private/type-utils.ss"
+	  (private type-utils type-contract type-effect-convenience)
-          "private/typechecker.ss"
+	  (typecheck typechecker provide-handling)
-          "private/type-rep.ss"
+	  (env type-environments type-name-env type-alias-env)
-          "private/provide-handling.ss"
+	  (r:infer infer)
-          "private/type-environments.ss" 
+	  (utils tc-utils)
-          "private/tc-utils.ss"
+	  (rep type-rep)
-          "private/type-name-env.ss"
+	  (except-in (utils utils) infer extend)
-          "private/type-alias-env.ss"
+          (only-in (r:infer infer-dummy) infer-param)
-          (except-in "private/utils.ss" extend)
-          (only-in "private/infer-dummy.ss" infer-param)
-          "private/infer.ss"
-          "private/type-effect-convenience.ss"
-          "private/type-contract.ss"
           scheme/nest
           syntax/kerncase
           scheme/match))
@@ -31,7 +27,7 @@
 (provide (rename-out [module-begin #%module-begin]
                      [top-interaction #%top-interaction]
                      [#%plain-lambda lambda]
-                     [#%plain-app #%app]
+                     [#%app #%app]
                      [require require]))
 
 (define-for-syntax catch-errors? #f)

collects/typed-scheme/utils/tc-utils.ss

@@ -70,12 +70,12 @@
        (unless (null? stxs)
          (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))]))
 
-(define delay-errors? (make-parameter #t))
+(define delay-errors? (make-parameter #f))
 
 (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest)
   (let ([stx (locate-stx stx*)])
     (unless (syntax? stx)
-      (error "syntax was not syntax" stx (syntax->datum stx*)))
+      (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*)))
     (if (delay-errors?)
         (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors))
         (raise-typecheck-error (apply format msg rest) (list stx)))))

collects/typed-scheme/utils/utils.ss

@@ -2,6 +2,7 @@
 
 (require (for-syntax scheme/base)
          mzlib/plt-match
+	 scheme/require-syntax
          mzlib/struct)
 
 (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
@@ -16,7 +17,40 @@
          in-list-forever
          extend
          debug
-         in-syntax)
+         in-syntax
+	 ;; require macros
+	 rep utils typecheck infer env private)
+
+(define-syntax (define-requirer stx)
+  (syntax-case stx ()
+    [(_ nm)
+     #`(...
+	(define-require-syntax nm
+	  (lambda (stx)
+	    (syntax-case stx ()
+	      [(_ id ...)
+	       (andmap identifier? (syntax->list #'(id ...)))
+	       (with-syntax ([(id* ...) 
+                              (map (lambda (id) 
+                                     (datum->syntax 
+                                      id 
+                                      (string->symbol
+                                       (string-append 
+                                        "typed-scheme/"
+                                        #,(symbol->string (syntax-e #'nm))
+                                        "/" 
+                                        (symbol->string (syntax-e id))))
+                                      id id))
+                                   (syntax->list #'(id ...)))])
+			    (syntax/loc stx (combine-in id* ...)))]))))]))
+
+
+(define-requirer rep)
+(define-requirer infer)
+(define-requirer typecheck)
+(define-requirer utils)
+(define-requirer env)
+(define-requirer private)
 
 (define-sequence-syntax in-syntax 
   (lambda () #'syntax->list)

src/worksp/mred/mred.manifest

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.1.0.2" 
+version="4.1.0.3" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.MrEd" 
 type="win32" 

src/worksp/mred/mred.rc

@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "mred.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,0,2
+ FILEVERSION 4,1,0,3
- PRODUCTVERSION 4,1,0,2
+ PRODUCTVERSION 4,1,0,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme GUI application\0"
             VALUE "InternalName", "MrEd\0"
-            VALUE "FileVersion", "4, 1, 0, 2\0"
+            VALUE "FileVersion", "4, 1, 0, 3\0"
             VALUE "LegalCopyright", "Copyright © 1995-2008\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 0, 2\0"
+            VALUE "ProductVersion", "4, 1, 0, 3\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzcom.rc

@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,0,2
+ FILEVERSION 4,1,0,3
- PRODUCTVERSION 4,1,0,2
+ PRODUCTVERSION 4,1,0,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 1, 0, 2"
+            VALUE "FileVersion", "4, 1, 0, 3"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 1, 0, 2"
+            VALUE "ProductVersion", "4, 1, 0, 3"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzobj.rgs

@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.1.0.2 = s 'MzObj Class'
+	MzCOM.MzObj.4.1.0.3 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.1.0.2'
+		CurVer = s 'MzCOM.MzObj.4.1.0.3'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.1.0.2'
+			ProgID = s 'MzCOM.MzObj.4.1.0.3'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'

src/worksp/mzscheme/mzscheme.rc

@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "mzscheme.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,0,2
+ FILEVERSION 4,1,0,3
- PRODUCTVERSION 4,1,0,2
+ PRODUCTVERSION 4,1,0,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme application\0"
             VALUE "InternalName", "MzScheme\0"
-            VALUE "FileVersion", "4, 1, 0, 2\0"
+            VALUE "FileVersion", "4, 1, 0, 3\0"
             VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 0, 2\0"
+            VALUE "ProductVersion", "4, 1, 0, 3\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/starters/start.rc

@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,0,2
+ FILEVERSION 4,1,0,3
- PRODUCTVERSION 4,1,0,2
+ PRODUCTVERSION 4,1,0,3
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "PLT Scheme Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 1, 0, 2\0"
+            VALUE "FileVersion", "4, 1, 0, 3\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 0, 2\0"
+            VALUE "ProductVersion", "4, 1, 0, 3\0"
         END
     END
     BLOCK "VarFileInfo"