more fixes for lambda with expected

svn: r14639

collects/typed-scheme/test.ss

@@ -38,4 +38,9 @@
   (define: (z [x : Number]) : Any w)
   (define: (w) : Any z)
   z)
+(case-lambda: [() 1]
+              [([x : Number]) x])
+;; Error
+#;#{(case-lambda: [() 1]
+                [([x : Number]) x]) :: String}
 

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

@@ -130,6 +130,7 @@
 
 ;; check-below : (/\ (Results Type -> Result)
 ;;                   (Results Results -> Result)
+;;                   (Type Results -> Type)
 ;;                   (Type Type -> Type))
 (define (check-below tr1 expected)
   (match* (tr1 expected)
@@ -137,10 +138,19 @@
      (unless (andmap subtype t1 t2)
        (tc-error/expr "Expected ~a, but got ~a" t2 t1))
      expected]
-    [((tc-result1: t1) (? Type? t2))
+    [((tc-result1: t1 f o) (? Type? t2))
      (unless (subtype t1 t2)
        (tc-error/expr "Expected ~a, but got ~a" t2 t1))
-     (ret expected)]
+     (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 object ~a, got ~a" f 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))

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

@@ -202,7 +202,10 @@
       (go (syntax->list formals) (syntax->list bodies) null null null)))
 
 (define (tc/mono-lambda/type formals bodies expected)
-  (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))
+  (define t (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))
+  (if expected 
+      (check-below t expected)
+      t))
 
 ;; tc/plambda syntax syntax-list syntax-list type -> Poly
 ;; formals and bodies must by syntax-lists

collects/typed-scheme/types/printer.ss

@@ -150,7 +150,8 @@
     [(Union: elems) (fp "~a" (cons 'U elems))]
     [(Pair: l r) (fp "(Pair ~a ~a)" l r)]
     [(F: nm) (fp "~a" nm)]   
-    [(Values: (list v)) (fp "~a" v)]
+    ;; 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))))]
     [(Param: in out) 

collects/typed-scheme/utils/utils.ss

@@ -190,7 +190,7 @@ at least theoretically.
       [(_ val)
        #'(? (lambda (x) (equal? val x)))])))
 
-(define-for-syntax printing? #f)
+(define-for-syntax printing? #t)
 
 (define-syntax-rule (defprinter t ...)
   (begin