diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 509aa3a439..d0752ee6c7 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -566,7 +566,11 @@ (-values (list (parse-type #'t)))]))) (define (parse-tc-results stx) - (values->tc-results (parse-values-type stx))) + (syntax-parse stx + [(values t ...) + #:when (eq? 'values (syntax-e #'values)) + (ret (map parse-type (syntax->list #'(t ...))))] + [t (parse-type #'t)])) (define parse-tc-results/id (parse/id parse-tc-results)) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 33f552eb98..4352321758 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -4,6 +4,7 @@ (define (f x z) (f x z)) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) (lambda: ([x : Any] [y : Any]) (values (number? x) (number? y))) +(lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y))) (lambda: ([x : Any]) (values (number? x) (number? x))) (: g (Any -> Boolean : Number)) (define g (lambda: ([x : Any]) (number? x))) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index f3a4ebc319..1e255f0f44 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -199,7 +199,8 @@ [(tc-result1: (Mu: _ _)) (loop (unfold expected))] [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) - (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args (values->tc-results ret) rest drest))] + (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) + args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))] [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))] ;; otherwise [else (go (syntax->list formals) (syntax->list bodies) null null null)])) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index f1e3c85418..d0dfda98b6 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -134,26 +134,40 @@ ;; or [((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (combine null (append f1- f3-))] ;; and - [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) (combine (append f1+ f2+) null)] + [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) + (combine (append f1+ f2+) null)] [(f f* f*) f*] [(_ _ _) ;; could intersect f2 and f3 here (make-FilterSet null null)])) - -;; FIXME - this should really be a new metafunction like abstract-filter ;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results? (define (values->tc-results tc formals) (match tc - [(ValuesDots: (list (Result: ts fs os)) dty dbound) - (int-err "values->tc-results NYI for Dots")] + [(ValuesDots: (list (Result: ts lfs los)) dty dbound) + (ret ts + (for/list ([lf lfs]) + (merge-filter-sets + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x))))) + (for/list ([lo los]) + (or + (for/or ([x formals] [i (in-naturals)]) + (match lo + [(LEmpty:) #f] + [(LPath: p (== i)) (make-Path p x)])) + (make-Empty))) + dty dbound)] [(Values: (list (Result: ts lfs los) ...)) (ret ts (for/list ([lf lfs]) - (for/list ([x formals] [i (in-naturals)]) - (apply-filter (split-lfilters lf i) Univ (make-Path null x)))) + (merge-filter-sets + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x))))) (for/list ([lo los]) - (for/list ([x formals] [i (in-naturals)]) - (match lo - [(LEmpty:) (make-Empty)] - [(LPath: p (== i)) (make-Path p x)]))))])) \ No newline at end of file + (or + (for/or ([x formals] [i (in-naturals)]) + (match lo + [(LEmpty:) #f] + [(LPath: p (== i)) (make-Path p x)])) + (make-Empty))))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss index dcd423df98..6970804c43 100644 --- a/collects/typed-scheme/typecheck/tc-new-if.ss +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -28,7 +28,7 @@ (cond [(= (length ts) (length us)) (ret (for/list ([t ts] [u us]) (Un t u)) (for/list ([f2 fs2] [f3 fs3]) - (combine-filter f1 f2 f2)))] + (combine-filter f1 f2 f3)))] [else (tc-error/expr #:return (ret Err) "Expected the same number of values from both branches of if expression, but got ~a and ~a" diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 6c0e49b18d..b7ad8b71de 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -30,9 +30,7 @@ just-Dotted? tc-error/expr lookup-fail - lookup-type-fail - values->tc-results - tc-results->values) + lookup-type-fail) ;; substitute : Type Name Type -> Type @@ -197,7 +195,8 @@ (cond [(Type? t) (list (make-tc-result t (make-FilterSet null null) (make-Empty)))] [(or (Values? t) (ValuesDots? t)) - (values->tc-results t)] + (int-err "Values in ret: ~a" t) + #;(values->tc-results t)] [else (for/list ([i t]) (make-tc-result i (make-FilterSet null null) (make-Empty)))]) @@ -283,10 +282,3 @@ (define (lookup-type-fail i) (tc-error/expr "~a is not bound as a type" (syntax-e i))) - -(define (tc-results->values tc) - (match tc - [(tc-results: ts fs os dty dbound) - (make-ValuesDots (map make-Result ts fs os) dty dbound)] - [(tc-results: ts fs os) - (make-Values (map make-Result ts fs os))]))