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

Cleanup non poly case in apply.

Browse Source
This commit is contained in:
Eric Dobson 2014-04-27 09:29:25 -07:00
parent ab2877ed7f
commit c91a912129
1 changed files with 36 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt
View File

@ -41,40 +41,42 @@
(tc-error/expr "empty case-lambda given as argument to apply")) (tc-error/expr "empty case-lambda given as argument to apply"))
(match-let* ([arg-tres (map tc-expr fixed-args)] (match-let* ([arg-tres (map tc-expr fixed-args)]
[arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tc-result1: tail-ty) (single-value tail)]) [tail-ty (tc-expr/t tail)])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (or
(for/or ([domain (in-list doms)]
[range (in-list rngs)]
[rest (in-list rests)]
[drest (in-list drests)])
(cond (cond
;; we've run out of cases to try, so error out ;; this case of the function type has a rest argument
[(null? doms*) [rest
;; check that the tail expression is a subtype of the rest argument
(and
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* domain #:tail (make-Listof rest)))
(do-ret range))]
;; the function expects a dotted rest arg, so make sure we have a ListDots
[drest
(match tail-ty
[(ListDots: tail-ty tail-bound)
;; the check that it's the same bound
(and (eq? (cdr drest) tail-bound)
;; and that the types are correct
(subtypes arg-tys domain)
(subtype tail-ty (car drest))
(do-ret range))]
[_ #f])]
;; the function has no rest argument, but provides all the necessary fixed arguments
[(and (not rest) (not drest))
(and
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* domain))
(do-ret range))]))
(domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f
#:msg-thunk (lambda (dom) #:msg-thunk (lambda (dom)
(string-append (string-append
"Bad arguments to function in apply:\n" "Bad arguments to function in apply:\n"
dom)))] dom)))))]
;; this case of the function type has a rest argument
[(and (car rests*)
;; check that the tail expression is a subtype of the rest argument
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))
(do-ret (car rngs*))]
;; the function expects a dotted rest arg, so make sure we have a ListDots
[(and (car drests*)
(match tail-ty
[(ListDots: tail-ty tail-bound)
;; the check that it's the same bound
(and (eq? (cdr (car drests*)) tail-bound)
;; and that the types are correct
(subtypes arg-tys (car doms*))
(subtype tail-ty (car (car drests*))))]
[_ #f]))
(do-ret (car rngs*))]
;; the function has no rest argument, but provides all the necessary fixed arguments
[(and (not (car rests*)) (not (car drests*))
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*))))
(do-ret (car rngs*))]
;; otherwise, nothing worked, move on to the next case
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
;; apply of simple polymorphic function ;; apply of simple polymorphic function
[(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(let*-values ([(arg-tres) (map tc-expr fixed-args)] (let*-values ([(arg-tres) (map tc-expr fixed-args)]