From 1d21ec5ddab6264cf5df4a9f9793f4b40e77d120 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 29 Apr 2008 01:42:07 +0000
Subject: [PATCH] Control multiple errors with a parameter.

Don't use same code for handling type ascription and annotation.

svn: r9529
---
 collects/typed-scheme/private/tc-expr-unit.ss | 10 +++-----
 collects/typed-scheme/private/tc-utils.ss     |  6 ++++-
 .../typed-scheme/private/type-annotation.ss   | 25 ++++++++++++++-----
 3 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss
index 0a61bfad49..c68b0e2f02 100644
--- a/collects/typed-scheme/private/tc-expr-unit.ss
+++ b/collects/typed-scheme/private/tc-expr-unit.ss
@@ -78,9 +78,7 @@
                           ty (Poly-n ty) (length (syntax->list inst)))]
           [else
            (let ([ty* (if inst
-                          (begin
-                            (printf/log "Type Instantiation: ~a~n" (syntax-e id))
-                            (instantiate-poly ty (map parse-type (syntax->list inst))))
+                          (instantiate-poly ty (map parse-type (syntax->list inst)))
                           ty)])
              (ret ty* (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id))))])))
 
@@ -142,7 +140,8 @@
         [(#%variable-reference . _)
          (tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Scheme")]
         ;; identifiers
-        [x (identifier? #'x) (check-below (tc-id #'x) expected)]
+        [x (identifier? #'x) 
+           (check-below (tc-id #'x) expected)]
         ;; w-c-m
         [(with-continuation-mark e1 e2 e3)
          (begin (tc-expr/check #'e1 Univ)
@@ -277,8 +276,7 @@
     (unless (syntax? form) 
       (int-err "bad form input to tc-expr: ~a" form))
     ;; typecheck form
-    (cond [(type-annotation form) => (lambda (ann) 
-                                       ;(printf "annotated~n")
+    (cond [(type-ascription form) => (lambda (ann)
                                        (tc-expr/check form ann))]
           [else (internal-tc-expr form)])))
 
diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss
index a2a412f7ed..5a01f647ac 100644
--- a/collects/typed-scheme/private/tc-utils.ss
+++ b/collects/typed-scheme/private/tc-utils.ss
@@ -55,8 +55,12 @@
        (unless (null? stxs)
          (raise-typecheck-error "Errors encountered" (apply append stxs))))]))
 
+(define delay-errors? (make-parameter #t))
+
 (define (tc-error/delayed msg #:stx [stx (current-orig-stx)] . rest)
-  (set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors)))
+  (if (delay-errors?)
+      (set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors))
+      (raise-typecheck-error (apply format msg rest) (list (locate-stx stx)))))
 
 ;; produce a type error, using the current syntax
 (define (tc-error msg . rest)  
diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss
index 3b61281ab7..2886db757b 100644
--- a/collects/typed-scheme/private/type-annotation.ss
+++ b/collects/typed-scheme/private/type-annotation.ss
@@ -8,6 +8,7 @@
          get-type/infer
          type-label-symbol
          type-ascrip-symbol
+         type-ascription
          check-type)
 
 (define type-label-symbol 'type-label)
@@ -23,7 +24,7 @@
 
 ;; get the type annotation of this syntax
 ;; syntax -> Maybe[Type]
-(define (type-annotation stx)
+(define (type-annotation stx #:infer [let-binding #f])
   (define (pt prop)
     (print-size prop)
     (if (syntax? prop)
@@ -32,13 +33,24 @@
   (cond       
     [(syntax-property stx type-label-symbol) => pt]
     [(syntax-property stx type-ascrip-symbol) => pt]
-    [(and (identifier? stx) (lookup-type stx (lambda () #f)))
+    ;; this is so that : annotation works in internal def ctxts
+    [(and let-binding (identifier? stx) (lookup-type stx (lambda () #f)))
      =>
      (lambda (t)
        (maybe-finish-register-type stx)
        t)]
     [else #f]))
 
+(define (type-ascription stx)
+  (define (pt prop)
+    (print-size prop)
+    (if (syntax? prop)
+        (parse-type prop)
+        (parse-type/id stx prop)))
+  (cond
+    [(syntax-property stx type-ascrip-symbol) => pt]
+    [else #f]))
+
 (define (log/ann stx ty)
   (printf/log "Required Annotated Variable: ~a ~a~n" (syntax-e stx) ty))
 (define (log/extra stx ty ty2)
@@ -72,10 +84,11 @@
                   [else (log/noann stx ty) ty]))
           stx ty)]      
     [(list (list stx) ty)
-     (cond [(type-annotation stx) => (lambda (ann)
-                                       (check-type stx ty ann) 
-                                       (log/extra stx ty ann)
-                                       (list ann))]
+     (cond [(type-annotation stx #:infer #t)
+            => (lambda (ann)
+                 (check-type stx ty ann) 
+                 (log/extra stx ty ann)
+                 (list ann))]
            [else (log/noann stx ty) (list ty)])]
     [else (int-err "wrong type arity - get-type/infer ~a ~a" stxs e-type)]))