Merge in changes from 660.

svn: r9567

original commit: 5af7d626beeb76e42488af49d0c596595680ffba

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

@@ -52,7 +52,7 @@
         [make-lst/elements -pair])
     (make-env
      
-     [string->sexpr (-> -String (-mu x (Un Sym -String N B (-lst x))))]
+     [raise (Univ . -> . (Un))]
      
      (car (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
                                         [((make-lst (-v a))) (-v a)])))
@@ -95,8 +95,12 @@
      (number? (make-pred-ty N))
      (integer? (make-pred-ty -Integer))
      (boolean? (make-pred-ty B))
-     (add1 (-> N N))
-     (sub1 (-> N N))
+     (add1 (cl->*
+            #;(-> -Integer -Integer)
+            (-> N N)))
+     (sub1 (cl->*
+            #;(-> -Integer -Integer)
+            (-> N N)))
      (eq? (-> Univ Univ B))
      (eqv? (-> Univ Univ B))
      (equal? (-> Univ Univ B))
@@ -179,10 +183,10 @@
      (<= (->* (list N N) N B))
      [> (->* (list N) N B)]
      (zero? (N . -> . B))
-     (* (->* '() N N))
-     (/ (->* (list N) N N))
-     (+ (->* '() N N))
-     (- (->* (list N) N N))
+     (* (cl->* (->* '() -Integer -Integer) (->* '() N N)))
+     (/ (cl->* (->* (list N) N N)))
+     (+ (cl->* (->* '() -Integer -Integer) (->* '() N N)))
+     (- (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)))]
@@ -463,8 +467,8 @@
      
      [make-directory (-> -Path -Void)]
      
-     [hash-table-for-each (-poly (a b c)
-                                 (-> (-HT a b) (-> a b c) -Void))]
+     [hash-for-each (-poly (a b c)
+                           (-> (-HT a b) (-> a b c) -Void))]
      
      [delete-file (-> -Pathlike -Void)]
      [make-namespace (cl->* (-> -Namespace)

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

@@ -95,7 +95,7 @@
   [HashTable (-poly (a b) (-HT a b))]
   [Promise (-poly (a) (-Promise a))]
   [Pair (-poly (a b) (-pair a b))]
-  [Box (-poly (a) (make-Box a))]
+  [Boxof (-poly (a) (make-Box a))]
   [Syntax Any-Syntax]
   [Identifier Ident]
   )

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

@@ -114,7 +114,10 @@
               [tvar (make-F var)])
          (add-type-name-reference #'mu)           
          (parameterize ([current-tvars (extend-env (list var) (list tvar) (current-tvars))])
-           (make-Mu var (parse-type #'t))))]
+           (let ([t (parse-type #'t)])
+             (if (memq var (fv t))
+                 (make-Mu var t)
+                 t))))]
       [(U ts ...)
        (eq? (syntax-e #'U) 'U)
        (begin

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

@@ -2,7 +2,8 @@
 
 (require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss" "union.ss" "resolve-type.ss"
          "type-env.ss")
-(require (lib "plt-match.ss"))
+(require (lib "plt-match.ss")
+         mzlib/trace)
 (provide type-annotation
          get-type
          get-type/infer
@@ -67,7 +68,7 @@
       [(type-annotation stx) => (lambda (x) 
                                   (log/ann stx x)
                                   x)]
-      [(not (syntax-original? stx)) 
+      [(not (syntax-original? stx))
        (tc-error "untyped var: ~a" (syntax-e stx))]
       [else
        (tc-error "no type information on variable ~a" (syntax-e stx))])))

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

@@ -217,6 +217,7 @@
   (let/ec exit
     (let loop ([t* t])
       (match t*
+        [(Value: '()) (-lst Univ)]
         [(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*]
         [(Pair: t1 t2)
          (let ([t-new (loop t2)])