diff --git a/collects/tests/typed-scheme/fail/pr11772.rkt b/collects/tests/typed-scheme/fail/pr11772.rkt new file mode 100644 index 00000000..0e96bf47 --- /dev/null +++ b/collects/tests/typed-scheme/fail/pr11772.rkt @@ -0,0 +1,20 @@ +#lang typed/racket + +(require racket/list) + +(define-type expression 'expression) + + +(: foo (expression -> expression)) +(define (foo expr) + (define-values (a b) + (for/fold: : (values (Listof Symbol) expression) + ((remaining-funs : (Listof Symbol) empty) + (body : expression 'expression)) + ((fun : Symbol empty)) + (if (empty? (filter even? '(1 2))) ;non-trival list + (values remaining-funs body) + (values (cons fun remaining-funs body))))) + + ;error is on line above. paren should be moved before body + (error 'dont-care)) diff --git a/collects/typed-scheme/typecheck/check-below.rkt b/collects/typed-scheme/typecheck/check-below.rkt index 0aa2c46a..c10185ca 100644 --- a/collects/typed-scheme/typecheck/check-below.rkt +++ b/collects/typed-scheme/typecheck/check-below.rkt @@ -93,6 +93,9 @@ (tc-error/expr "Expected result with filter ~a and ~a, got ~a" f (print-object o) t1) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) t1] + [((? Type? t1) (tc-results: ts2 fs os)) + (tc-error/expr "Expected one value, but got ~a" (length ts2)) + t1] [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index fe3f6de5..40500a57 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -528,7 +528,16 @@ ;; handle apply specially [(#%plain-app apply f . args) (tc/apply #'f #'args)] ;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value - [(#%plain-app values arg) (single-value #'arg expected)] + [(#%plain-app values arg) + (match expected + [#f (single-value #'arg)] + [(tc-result1: tp) + (single-value #'arg expected)] + [(tc-results: ts) + (single-value #'arg) ;Type check the argument, to find other errors + (tc-error/expr #:return expected + "wrong number of values: expected ~a but got one" + (length ts))])] ;; handle `values' specially [(#%plain-app values . args) (match expected diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 04bd53d3..5e39f203 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -452,7 +452,10 @@ (define t (if expected (tc-expr/check form expected) (tc-expr form))) (match t [(tc-result1: _ _ _) t] - [_ (tc-error/stx form "expected single value, got multiple (or zero) values")])) + [_ (tc-error/expr + #:stx form + #:return (or expected (ret (Un))) + "expected single value, got multiple (or zero) values")])) ;; type-check a list of exprs, producing the type of the last one. ;; if the list is empty, the type is Void.