From 37d71ded6fbe08b7e589c2ca91eb645218d59c31 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 14:45:24 +0000 Subject: [PATCH] Fix type->contract of function types. svn: r14810 original commit: d8c613494e838711d2b85cc61607238d4c36baad --- collects/typed-scheme/private/type-contract.ss | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 87377316..a4f22f20 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -70,18 +70,13 @@ #;(printf "~a~n" (syntax-object->datum #'cnts)) #'(or/c . cnts))] [(Function: arrs) - (let () + (let () (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f '()) - (values (map t->c/neg dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f '()) - (values (map t->c/neg dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f '() ) - (values (map t->c/neg dom) (map t->c rngs) (t->c/neg rst))] - [(arr: dom rng rst #f '()) - (values (map t->c/neg dom) (list (t->c rng)) (t->c/neg rst))])) + [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) + (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] + [_ (exit (fail))])) (with-syntax ([(dom* ...) dom*] [rng* (match rngs*