From a525d82a8d4ebb40de6bd7e512103cb1ab90b6cb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 20 May 2008 20:47:18 +0000 Subject: [PATCH] Handle errors in type application. svn: r9915 original commit: ac1027af8b38669bddf388951cee98e08892cb44 --- collects/typed-scheme/private/subtype.ss | 28 ++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 999d8936..e2e59623 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -228,12 +228,32 @@ (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)) + (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)]) + (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) + (match t [(Poly-unsafe: n _) + (unless (= n (length args)) + (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" + n (length args)))]) + (let ([v (subtype* A0 (instantiate-poly t args) other)]) #;(printf "val: ~a~n" v) v))] + [(list other (App: (Name: n) args stx)) + (let ([t (lookup-type-name n)]) + (unless (Type? t) + (fail! s t)) + #;(printf "subtype: 2 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)) + (match t [(Poly-unsafe: n _) + (unless (= n (length args)) + (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" + n (length args)))]) + ;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args)) + (let ([v (subtype* A0 other (instantiate-poly t args))]) + #;(printf "2 val: ~a~n" v) + v))] [(list (Name: n) other) (let ([t (lookup-type-name n)]) ;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other) @@ -253,7 +273,7 @@ [(list (Instance: t) (Instance: t*)) (subtype* A0 t t*)] ;; otherwise, not a subtype - [_ (fail! s t) (printf "failed")])))))) + [_ (fail! s t) #;(printf "failed")])))))) (define (type-compare? a b) (and (subtype a b) (subtype b a)))