diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 244c3848fe..459ff0b67d 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -436,6 +436,20 @@ (check-do-make-object #'cl #'args #'() #'())] [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...)) (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))] + ;; ormap/andmap of ... argument + [(#%plain-app or/andmap:id f arg) + #:when (or (free-identifier=? #'or/andmap #'ormap) + (free-identifier=? #'or/andmap #'andmap)) + #:when (with-handlers ([exn:fail? (lambda _ #f)]) + (tc/dots #'arg) + #t) + (let-values ([(ty bound) (tc/dots #'arg)]) + (parameterize ([current-tvars (extend-env (list bound) + (list (make-DottedBoth (make-F bound))) + (current-tvars))]) + (match-let* ([ft (tc-expr #'f)] + [(tc-result1: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) + (ret (Un (-val #f) t)))))] ;; special case for `delay' [(#%plain-app mp1 diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 7050b5e918..576f21cd0d 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -133,8 +133,12 @@ ;; (Type Type -> Type)) (define (check-below tr1 expected) (match* (tr1 expected) + [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _) + expected] [((tc-results: t1) (tc-results: t2)) - (unless (andmap subtype t1 t2) + (unless (= (length t1) (length t2)) + (tc-error/expr "0.5 Expected ~a values, but got ~a" (length t2) (length t1))) + (unless (for/and ([t t1] [s t2]) (subtype t s)) (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) expected] [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound))