From ac1acc7bf6534c88d8eeb889c75706b3f99f8910 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 2 May 2008 22:19:18 +0000
Subject: [PATCH] Fix error handling when non-poly Name is applied.

svn: r9607
---
 collects/typed-scheme/private/parse-type.ss     | 2 ++
 collects/typed-scheme/private/subtype.ss        | 4 +++-
 collects/typed-scheme/private/type-alias-env.ss | 4 +++-
 3 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss
index cbc5632bd0..b262f0b359 100644
--- a/collects/typed-scheme/private/parse-type.ss
+++ b/collects/typed-scheme/private/parse-type.ss
@@ -162,11 +162,13 @@
          [(lookup-type-alias #'id parse-type (lambda () #f))
           =>
           (lambda (t)
+            ;(printf "found a type alias ~a~n" #'id)
             (add-type-name-reference #'id)
             t)]
          ;; if it's a type name, we just use the name
          [(lookup-type-name #'id (lambda () #f))
           (add-type-name-reference #'id)
+          ;(printf "found a type name ~a~n" #'id)
           (make-Name #'id)]
          [else
           (tc-error/delayed "unbound type ~a" (syntax-e #'id))
diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss
index 71e515e2a0..999d8936bb 100644
--- a/collects/typed-scheme/private/subtype.ss
+++ b/collects/typed-scheme/private/subtype.ss
@@ -223,12 +223,14 @@
                ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
                (subtype* A0 parent other)]
               ;; applications and names are structs too
-              [(list (App: (Name: n) args _) other)
+              [(list (App: (Name: n) args stx) other)
                (let ([t (lookup-type-name n)])
                  (unless (Type? t)                     
                    (fail! s t))
                  #;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other 
                            (instantiate-poly t args))
+                 (unless (Poly? t)
+                   (tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
                  (let ([v (subtype* A0 (instantiate-poly t args) other)])                    
                    #;(printf "val: ~a~n"  v)
                    v))]
diff --git a/collects/typed-scheme/private/type-alias-env.ss b/collects/typed-scheme/private/type-alias-env.ss
index 33d6d82ef1..79db3386a4 100644
--- a/collects/typed-scheme/private/type-alias-env.ss
+++ b/collects/typed-scheme/private/type-alias-env.ss
@@ -3,7 +3,7 @@
 (require syntax/boundmap
          "tc-utils.ss"
          mzlib/trace
-         mzlib/plt-match)
+         scheme/match)
 
 (provide register-type-alias
          lookup-type-alias
@@ -30,6 +30,8 @@
   (mapping-put! id (make-unresolved stx #f)))
 
 (define (register-resolved-type-alias id ty)
+  #;(when (eq? 'Number (syntax-e id))
+      (printf "registering type ~a ~a~n~a~n" id (syntax-e id) ty))
   (mapping-put! id (make-resolved ty)))
 
 (define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])