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

Special case for `call-with-values'

Browse Source 
handle subtyping with ... args

svn: r14788

original commit: a8a64cfa7c6f50b7f01ecfe4f06f02e4ed769708
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-12 20:56:32 +00:00
parent 8e3a80596c
commit 4b6d8992b8
2 changed files with 15 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -211,12 +211,12 @@
(do-ret (car rngs*))]
[(and (car drests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(with-handlers ([exn:fail? (lambda (e) (values #f #f))])
(tc/dots tail))])
(and tail-ty
(eq? (cdr (car drests*)) tail-bound)
(subtypes arg-tys (car doms*))
(subtype tail-ty (car (car drests*))))))
(subtype tail-ty (car (car drests*))))))
(printf/log "Non-poly apply, ... arg\n")
(do-ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
@ -365,6 +365,11 @@
#:literals (#%plain-app #%plain-lambda letrec-values quote
values apply k:apply not list list* call-with-values do-make-object make-object cons
andmap ormap)
;; call-with-values
[(#%plain-app call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)
[(tc-results: ts fs os)
(tc/funapp #'con #'prod (single-value #'con) (map ret ts fs os) expected)])]
;; in eq? cases, call tc/eq
[(#%plain-app eq?:comparator v1 v2)
;; make sure the whole expression is type correct

9
collects/typed-scheme/types/subtype.ss
View File

@ -150,7 +150,14 @@
(subtype* t-rest s-rest)
(kw-subtypes* t-kws s-kws)
(subtype* s-rng t-rng))]
;; FIXME - handle dotted varargs
;; handle ... varargs when the bounds are the same
[((arr: s-dom s-rng #f (cons s-drest dbound) s-kws)
(arr: t-dom t-rng #f (cons t-drest dbound) t-kws))
(subtype-seq A0
(subtype* t-drest s-drest)
(subtypes* t-dom s-dom)
(kw-subtypes* t-kws s-kws)
(subtype* s-rng t-rng))]
[(_ _)
(fail! s t)])))