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

70
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
(cond (for/or ([domain (in-list doms)]
;; we've run out of cases to try, so error out [range (in-list rngs)]
[(null? doms*) [rest (in-list rests)]
(domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f [drest (in-list drests)])
#:msg-thunk (lambda (dom) (cond
(string-append ;; this case of the function type has a rest argument
"Bad arguments to function in apply:\n" [rest
dom)))] ;; check that the tail expression is a subtype of the rest argument
;; this case of the function type has a rest argument (and
[(and (car rests*) (subtype (apply -lst* arg-tys #:tail tail-ty)
;; check that the tail expression is a subtype of the rest argument (apply -lst* domain #:tail (make-Listof rest)))
(subtype (apply -lst* arg-tys #:tail tail-ty) (do-ret range))]
(apply -lst* (car doms*) #:tail (make-Listof (car rests*))))) ;; the function expects a dotted rest arg, so make sure we have a ListDots
(do-ret (car rngs*))] [drest
;; the function expects a dotted rest arg, so make sure we have a ListDots (match tail-ty
[(and (car drests*) [(ListDots: tail-ty tail-bound)
(match tail-ty ;; the check that it's the same bound
[(ListDots: tail-ty tail-bound) (and (eq? (cdr drest) tail-bound)
;; the check that it's the same bound ;; and that the types are correct
(and (eq? (cdr (car drests*)) tail-bound) (subtypes arg-tys domain)
;; and that the types are correct (subtype tail-ty (car drest))
(subtypes arg-tys (car doms*)) (do-ret range))]
(subtype tail-ty (car (car drests*))))] [_ #f])]
[_ #f])) ;; the function has no rest argument, but provides all the necessary fixed arguments
(do-ret (car rngs*))] [(and (not rest) (not drest))
;; the function has no rest argument, but provides all the necessary fixed arguments (and
[(and (not (car rests*)) (not (car drests*)) (subtype (apply -lst* arg-tys #:tail tail-ty)
(subtype (apply -lst* arg-tys #:tail tail-ty) (apply -lst* domain))
(apply -lst* (car doms*)))) (do-ret range))]))
(do-ret (car rngs*))] (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f
;; otherwise, nothing worked, move on to the next case #:msg-thunk (lambda (dom)
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] (string-append
"Bad arguments to function in apply:\n"
dom)))))]
;; 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)]