suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Handle return of Bottom to context which expectes multiple values.

Browse Source 
Check values length before using for/and.
Add back ormap/andmap special case for ... args.

svn: r14930
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-22 19:09:19 +00:00
parent e772687a58
commit 7e6c1be6b0
2 changed files with 19 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -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

6
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -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))