From e7bc490d7f257608a9f040da963e62f5d00d5c12 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 25 Sep 2008 19:35:00 +0000
Subject: [PATCH] Fix error in use of tc-error/delayed. Fix expansion of
 with-handlers: add test

svn: r11875

original commit: cd6a37ff4c83505ceef5fbc747235160d03d2aee
---
 collects/tests/typed-scheme/succeed/with-handlers.ss | 10 ++++++++++
 collects/typed-scheme/private/prims.ss               |  2 +-
 collects/typed-scheme/private/type-annotation.ss     | 11 +++++++----
 3 files changed, 18 insertions(+), 5 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/with-handlers.ss

diff --git a/collects/tests/typed-scheme/succeed/with-handlers.ss b/collects/tests/typed-scheme/succeed/with-handlers.ss
new file mode 100644
index 00000000..cfdb88ae
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/with-handlers.ss
@@ -0,0 +1,10 @@
+
+#lang typed-scheme
+
+(define: (f [i : Integer]) : (Pair String Char)
+ (cons "foo" #\space))
+
+(define: (is-happiness-a-warm-gun?) : Boolean
+ (with-handlers ([integer? (lambda: ([x : Any]) #t)])
+   (f 42)
+   #t))
\ No newline at end of file
diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss
index 9068659c..dd72df9f 100644
--- a/collects/typed-scheme/private/prims.ss
+++ b/collects/typed-scheme/private/prims.ss
@@ -301,7 +301,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                       (syntax->list #'(pred? ...)))]
                    [(action* ...)
                     (map (lambda (s) (syntax-property s 'typechecker:exn-handler #t)) (syntax->list #'(action ...)))]
-                   [body* (syntax-property #'(begin . body) 'typechecker:exn-body #t)])
+                   [body* (syntax-property #'(let-values () . body) 'typechecker:exn-body #t)])
        (syntax-property #'(with-handlers ([pred?* action*] ...) body*)
                         'typechecker:with-handlers
                         #t))]))
diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss
index bbb83034..9ff2f8d0 100644
--- a/collects/typed-scheme/private/type-annotation.ss
+++ b/collects/typed-scheme/private/type-annotation.ss
@@ -103,16 +103,19 @@
              (match ty
                [(Values: tys) 
                 (if (not (= (length stxs) (length tys)))
-                    (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) 
+                    (begin
+                      (tc-error/delayed 
                                       "Expression should produce ~a values, but produces ~a values of types ~a"
                                       (length stxs) (length tys) (stringify tys))
+                      (map (lambda _ (Un)) stxs))
                     (map (lambda (stx ty a)
                            (cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)]
                                  [else #;(log/noann stx ty) ty]))
                          stxs tys anns))]
-               [ty (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) 
-                                     "Expression should produce ~a values, but produces one values of type "
-                                     (length stxs) ty)]))))]))
+               [ty (tc-error/delayed 
+                    "Expression should produce ~a values, but produces one values of type ~a"
+                    (length stxs) ty)
+                   (map (lambda _ (Un)) stxs)]))))]))
 
 
 ;; check that e-type is compatible with ty in context of stx