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

Merge poly and simple function cases in tc-apply.

Browse Source
This commit is contained in:
Eric Dobson 2014-04-28 22:04:49 -07:00
parent d6ef3d774c
commit e56652bc18
1 changed files with 18 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -53,28 +53,8 @@
dom)))])) dom)))]))
(match f-ty (match f-ty
;; apply of simple function ;; apply of a simple function or polymorphic function
[(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (AnyPoly: vars '() (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(or
(for/or ([domain (in-list doms)]
[range (in-list rngs)]
[rest (in-list rests)]
[drest (in-list drests)])
(and
(subtype
(-Tuple* arg-tys full-tail-ty)
(-Tuple* domain
(cond
;; this case of the function type has a rest argument
[rest (make-Listof rest)]
;; the function expects a dotted rest arg, so make sure we have a ListDots
[drest (make-ListDots (car drest) (cdr drest))]
;; the function has no rest argument
[else (-val '())])))
(do-ret range)))
(failure))]
;; apply of simple polymorphic function
[(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(or (or
(for/or ([domain (in-list doms)] (for/or ([domain (in-list doms)]
[range (in-list rngs)] [range (in-list rngs)]
@ -82,19 +62,22 @@
[drest (in-list drests)]) [drest (in-list drests)])
(define (finish substitution) (define (finish substitution)
(and substitution (do-ret (subst-all substitution range)))) (and substitution (do-ret (subst-all substitution range))))
(finish (define (local-infer s t)
(infer vars null (if (empty? vars)
(list (-Tuple* arg-tys full-tail-ty)) (and (subtype s t) (do-ret range))
(list (-Tuple* domain (finish (infer vars null (list s) (list t) range))))
(cond
;; the actual work, when we have a * function (local-infer
[rest (make-Listof rest)] (-Tuple* arg-tys full-tail-ty)
;; ... function (-Tuple* domain
[drest (make-ListDots (car drest) (cdr drest))] (cond
;; the function has no rest argument, ;; the actual work, when we have a * function
;; but provides all the necessary fixed arguments [rest (make-Listof rest)]
[else (-val '())]))) ;; ... function
range))) [drest (make-ListDots (car drest) (cdr drest))]
;; the function has no rest argument,
;; but provides all the necessary fixed arguments
[else (-val '())]))))
(failure))] (failure))]
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))