From 1f05ee70e23ad7b8931f21f01da243c0e72bfcc3 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 2 Aug 2010 13:26:54 -0400
Subject: [PATCH] Don't treat Error types as potentially non-regular. (Reported
 by SK)

original commit: 431ff8d794425e12577c662be7827a38531ad39f
---
 collects/tests/typed-scheme/fail/unbound-non-reg.rkt | 7 +++++++
 collects/typed-scheme/private/parse-type.rkt         | 3 ++-
 collects/typed-scheme/types/resolve.rkt              | 3 ++-
 3 files changed, 11 insertions(+), 2 deletions(-)
 create mode 100644 collects/tests/typed-scheme/fail/unbound-non-reg.rkt

diff --git a/collects/tests/typed-scheme/fail/unbound-non-reg.rkt b/collects/tests/typed-scheme/fail/unbound-non-reg.rkt
new file mode 100644
index 00000000..5b286373
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/unbound-non-reg.rkt
@@ -0,0 +1,7 @@
+#;
+(exn-pred 2)
+#lang typed/racket
+
+
+(define-struct: (T) Node ([v : T] [l : (BinTreeof t)] [r : (BinTreeof t)]))
+(define-type (BinTreeof t) (U 'empty [Node t]))
diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt
index 23285bcd..bff49836 100644
--- a/collects/typed-scheme/private/parse-type.rkt
+++ b/collects/typed-scheme/private/parse-type.rkt
@@ -311,7 +311,8 @@
            [(Name: n)
             (when (and (current-poly-struct) 
                        (free-identifier=? n (poly-name (current-poly-struct)))
-                       (not (andmap type-equal? args (poly-vars (current-poly-struct)))))
+                       (not (or (ormap Error? args)
+                                (andmap type-equal? args (poly-vars (current-poly-struct))))))
               (tc-error "Structure type constructor ~a applied to non-regular arguments ~a" rator args))
             (make-App rator args stx)]
            [(Poly: ns _)
diff --git a/collects/typed-scheme/types/resolve.rkt b/collects/typed-scheme/types/resolve.rkt
index 4a30c813..b0bbc1c9 100644
--- a/collects/typed-scheme/types/resolve.rkt
+++ b/collects/typed-scheme/types/resolve.rkt
@@ -34,7 +34,8 @@
       [(Name: n) 
        (when (and (current-poly-struct) 
                   (free-identifier=? n (poly-name (current-poly-struct)))
-                  (not (andmap type-equal? rands (poly-vars (current-poly-struct)))))
+                  (not (or (ormap Error? rands)
+                           (andmap type-equal? rands (poly-vars (current-poly-struct))))))
          (tc-error "Structure type constructor ~a applied to non-regular arguments ~a" rator rands))
        (let ([r (resolve-name rator)])
          (and r  (resolve-app r rands stx)))]