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

Cleanup Poly cases in tc-apply

Browse Source
This commit is contained in:
Eric Dobson 2014-04-26 14:15:31 -07:00
parent 33a31d2868
commit ab2877ed7f
1 changed files with 56 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -79,61 +79,62 @@
[(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)]
[(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tail-ty tail-bound) (match (tc-expr/t tail) [(full-tail-ty) (tc-expr/t tail)]
[(ListDots: tail-ty tail-bound) [(tail-ty tail-bound)
(values tail-ty tail-bound)] (match full-tail-ty
[t (values t #f)])]) [(ListDots: tail-ty tail-bound)
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (values tail-ty tail-bound)]
(cond [(null? doms*) [t (values #f #f)])])
(match f-ty (or
[(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) (for/or ([domain (in-list doms)]
(domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound [range (in-list rngs)]
#:msg-thunk (lambda (dom) [rest (in-list rests)]
(string-append [drest (in-list drests)])
"Bad arguments to polymorphic function in apply:\n" (define (finish substitution) (do-ret (subst-all substitution range)))
dom)))])] (cond
;; the actual work, when we have a * function and a list final argument ;; the actual work, when we have a * function and a list final argument
[(and (car rests*) [(and rest
(not tail-bound) (not tail-bound)
(<= (length (car doms*)) (<= (length domain) (length arg-tys))
(length arg-tys)) (infer/vararg vars null
(infer/vararg vars null (cons full-tail-ty arg-tys)
(cons tail-ty arg-tys) (cons (make-Listof rest) domain)
(cons (make-Listof (car rests*)) rest
(car doms*)) range))
(car rests*) => finish]
(car rngs*))) ;; the function has no rest argument, but provides all the necessary fixed arguments
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] [(and (not rest) (not drest) (not tail-bound)
;; the function has no rest argument, but provides all the necessary fixed arguments (infer vars null
[(and (not (car rests*)) (not (car drests*)) (not tail-bound) (list (apply -lst* arg-tys #:tail full-tail-ty))
(infer vars null (list (apply -lst* domain))
(list (apply -lst* arg-tys #:tail tail-ty)) range))
(list (apply -lst* (car doms*))) => finish]
(car rngs*))) ;; actual work, when we have a * function and ... final arg
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] [(and rest
;; actual work, when we have a * function and ... final arg tail-bound
[(and (car rests*) (<= (length domain) (length arg-tys))
tail-bound (infer/vararg vars null
(<= (length (car doms*)) (cons (make-Listof tail-ty) arg-tys)
(length arg-tys)) (cons (make-Listof rest) domain)
(infer/vararg vars null rest
(cons (make-Listof tail-ty) arg-tys) range))
(cons (make-Listof (car rests*)) => finish]
(car doms*)) ;; ... function, ... arg
(car rests*) [(and drest
(car rngs*))) tail-bound
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] (eq? tail-bound (cdr drest))
;; ... function, ... arg (= (length domain) (length arg-tys))
[(and (car drests*) (infer vars null (cons tail-ty arg-tys) (cons (car drest) domain)
tail-bound range))
(eq? tail-bound (cdr (car drests*))) => finish]
(= (length (car doms*)) [else #f]))
(length arg-tys)) (match f-ty
(infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))))
(car rngs*))) (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] #:msg-thunk (lambda (dom)
;; if nothing matches, around the loop again (string-append
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] "Bad arguments to polymorphic function in apply:\n"
dom)))])))]
[(tc-result1: (Poly: vars (Function: '()))) [(tc-result1: (Poly: vars (Function: '())))
(tc-error/expr "Function has no cases")] (tc-error/expr "Function has no cases")]
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))