From 50545830f2bc3176fb0e34d828d8fdbd4c6eb7fc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 11 Aug 2009 21:00:57 +0000 Subject: [PATCH] Allow filters/objects to be provided to untyped code. svn: r15706 --- collects/typed-scheme/private/type-contract.ss | 6 +++++- collects/typed-scheme/typecheck/provide-handling.ss | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index a1a2f784e6..2c30583615 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -48,7 +48,7 @@ (= (length l) (length (remove-duplicates l)))) -(define (type->contract ty fail) +(define (type->contract ty fail #:out [out? #f]) (define vars (make-parameter '())) (let/ec exit (let loop ([ty ty] [pos? #t]) @@ -78,6 +78,10 @@ (match a [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '()) (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] + [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) + (if (and out? pos?) + (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst))) + (exit (fail)))] [_ (exit (fail))])) (trace f) (with-syntax diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index c214937592..72329df85a 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -53,7 +53,7 @@ (lambda (b) (with-syntax ([id internal-id] [out-id external-id]) - (cond [(type->contract (def-binding-ty b) (lambda () #f)) + (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) => (lambda (cnt) (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])