Fix Typed Racket handling of exception handling with multiple return values.

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

@@ -1354,6 +1354,10 @@
         (tc-e (let: ((p : (Promise Symbol) (delay 's)))
                   (promise-running? p)) B)
         |#
+        
+        ;; excetion handling
+        [tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values  "" ""))
+              #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))]
 
         ;Kernel Structs, check that their hidden identifiers type
         (tc-e (void exn

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

@@ -5,6 +5,7 @@
 	 syntax/parse
          racket/match
          "signatures.rkt" "tc-metafunctions.rkt"
+         "tc-funapp.rkt" "tc-subst.rkt"
          (types utils convenience union subtype)
 	 (utils tc-utils)
 	 (rep type-rep))
@@ -12,20 +13,39 @@
 (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
 (export check-subforms^)
 
+;; FIXME -- samth 7/15/11
+;; This code is doing the wrong thing wrt the arguments of exception handlers.  
+;; In particular, it allows them to be anything at all, but they might
+;; get called with the wrong kind of arguments by the exception
+;; mechanism.  The right thing is to use the exception predicate.
+
+(define (transpose l) (apply map list l))
+
+;; combine-types : Values * -> tc-results
+(define (combine-types . args)
+  (match args
+    [(list (tc-results: tss) ...)
+     (unless (apply = (map length tss))
+       (tc-error "Exception handlers and body did not all have the same number of results: ~a" (map length tss)))
+     ;; transpose and union
+     (let ([ts* (transpose tss)])
+       (ret (map (lambda (ts) (apply Un ts)) ts*)))]
+    [_ (int-err "Internal error: unsupported exception result type in: ~a" args)]))
+
 ;; find the subexpressions that need to be typechecked in an ignored form
 ;; syntax -> any
 (define (check-subforms/with-handlers form [expected #f])
   (define handler-tys '())
   (define body-ty #f)
+  (define body-stx #f)
+  ;; tc-result1 -> tc-results
+  ;; The result of applying the function to a single argument of type (Un)
+  ;; FIXME: (Un) is the wrong type, see above fixme
   (define (get-result-ty t)
     (match t
-      [(Function:
+      [(tc-result1: (Function: _))
-	(list
+       (tc/funapp #'here #'(here) t (list (ret (Un))) #f)]
-	 (arr: _
+      [_ (int-err "Unsupported function type in get-result-ty: \n~a" t)]))
-	       (Values: (list (Result: rngs _ _) ...))
-	       _ _ (list (Keyword: _ _ #t) ...))))
-       (apply Un rngs)]
-      [_ (int-err "Internal error in get-result-ty: not a function type: \n~a" t)]))
   (let loop ([form form])
     (parameterize ([current-orig-stx form])
       (syntax-parse form
@@ -37,26 +57,22 @@
         [stx
          ;; this is a handler function
          #:when (syntax-property form 'typechecker:exn-handler)
-         (let ([t (tc-expr form)])
+         (let ([t (single-value form)])
            (match t
-             [(tc-result1:
+             [(tc-result1: (Function: _))
-               (and t
-                    (Function: (list (arr: (list _) _ _ _ (list (Keyword: _ _ #f) ...)) ...))))
               (set! handler-tys (cons (get-result-ty t) handler-tys))]
              [(tc-results: t)
-              (tc-error "Exception handler must be a single-argument function, got \n~a" t)]))]
+              (tc-error "Exception handler must be a function, got \n~a" t)]))]
         [stx
          ;; this is the body of the with-handlers
          #:when (syntax-property form 'typechecker:exn-body)
-         (match (tc-expr form)
+         (set! body-stx form)
-          [(tc-result1: t) (set! body-ty t)]
+         (set! body-ty (tc-expr form))]
-          [(tc-results: ts) (tc-expr form)
-           (tc-error "Exception handler body must return a single value, got \n~a" (length ts))])]
         [(a . b)
 	 (loop #'a)
 	 (loop #'b)]
         [_ (void)])))
-  (ret (apply Un body-ty handler-tys)))
+  (apply combine-types body-ty handler-tys))
 
 ;; syntax type -> any
 (define (check-subforms/with-handlers/check form expected)