From 58d74734908d97a150e5f130c608f5159ff8bbdd Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 27 Apr 2014 19:15:48 -0700 Subject: [PATCH] Pull out typechecking subexpressions in tc-apply. original commit: fafe7365ae2789fec3e18f2fa9e6e66349a29ae0 --- .../typed-racket/typecheck/tc-apply.rkt | 262 +++++++++--------- 1 file changed, 126 insertions(+), 136 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt index 35563f20..aceb8b7b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt @@ -33,149 +33,139 @@ (tc-error "apply requires a final list argument, given only a function argument of type ~a" (match f-ty [(tc-result1: t) t])) (split args*)))) + (define arg-tres (map tc-expr fixed-args)) + (define arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)) + (define full-tail-ty (tc-expr/t tail)) + (define-values (tail-ty tail-bound) + (match full-tail-ty + [(ListDots: tail-ty tail-bound) + (values tail-ty tail-bound)] + [t (values #f #f)])) + (match f-ty ;; apply of simple function [(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (match-let* ([arg-tres (map tc-expr fixed-args)] - [arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] - [tail-ty (tc-expr/t tail)]) - (or - (for/or ([domain (in-list doms)] - [range (in-list rngs)] - [rest (in-list rests)] - [drest (in-list drests)]) - (and - (subtype - (-Tuple* arg-tys 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))) - (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f - #:msg-thunk (lambda (dom) - (string-append - "Bad arguments to function in `apply':\n" - dom)))))] + (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))) + (domain-mismatches f args t doms rests drests rngs arg-tres full-tail-ty #f + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to function in `apply':\n" + dom))))] ;; apply of simple polymorphic function [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (let*-values ([(arg-tres) (map tc-expr fixed-args)] - [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] - [(full-tail-ty) (tc-expr/t tail)] - [(tail-ty tail-bound) - (match full-tail-ty - [(ListDots: tail-ty tail-bound) - (values tail-ty tail-bound)] - [t (values #f #f)])]) - (or - (for/or ([domain (in-list doms)] - [range (in-list rngs)] - [rest (in-list rests)] - [drest (in-list drests)]) - (define (finish substitution) (do-ret (subst-all substitution range))) - (cond - ;; the actual work, when we have a * function - [(and rest - (infer vars null - (list (-Tuple* arg-tys full-tail-ty)) - (list (-Tuple* domain (make-Listof rest))) - range)) - => finish] - ;; the function has no rest argument, but provides all the necessary fixed arguments - [(and (not rest) (not drest) (not tail-bound) - (infer vars null - (list (-Tuple* arg-tys full-tail-ty)) - (list (-Tuple domain)) - range)) - => finish] - ;; ... function, ... arg - [(and drest - tail-bound - (eq? tail-bound (cdr drest)) - (= (length domain) (length arg-tys)) - (infer vars null (cons tail-ty arg-tys) (cons (car drest) domain) - range)) - => finish] - [else #f])) - (match f-ty - [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) - (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound - #:msg-thunk (lambda (dom) - (string-append - "Bad arguments to polymorphic function in `apply':\n" - dom)))])))] + (or + (for/or ([domain (in-list doms)] + [range (in-list rngs)] + [rest (in-list rests)] + [drest (in-list drests)]) + (define (finish substitution) (do-ret (subst-all substitution range))) + (cond + ;; the actual work, when we have a * function + [(and rest + (infer vars null + (list (-Tuple* arg-tys full-tail-ty)) + (list (-Tuple* domain (make-Listof rest))) + range)) + => finish] + ;; the function has no rest argument, but provides all the necessary fixed arguments + [(and (not rest) (not drest) (not tail-bound) + (infer vars null + (list (-Tuple* arg-tys full-tail-ty)) + (list (-Tuple domain)) + range)) + => finish] + ;; ... function, ... arg + [(and drest + tail-bound + (eq? tail-bound (cdr drest)) + (= (length domain) (length arg-tys)) + (infer vars null (cons tail-ty arg-tys) (cons (car drest) domain) + range)) + => finish] + [else #f])) + (match f-ty + [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) + (domain-mismatches f args t doms rests drests rngs arg-tres (or tail-ty full-tail-ty) tail-bound + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to polymorphic function in `apply':\n" + dom)))]))] [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (let*-values ([(arg-tres) (map tc-expr fixed-args)] - [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] - [(full-tail-ty) (tc-expr/t tail)] - [(tail-ty tail-bound) - (match full-tail-ty - [(ListDots: tail-ty tail-bound) - (values tail-ty tail-bound)] - [t (values #f #f)])]) - (or - (for/or ([domain (in-list doms)] - [range (in-list rngs)] - [rest (in-list rests)] - [drest (in-list drests)]) - (define (finish substitution) (do-ret (subst-all substitution range))) - (cond - ;; the actual work, when we have a * function - [(and rest - (infer fixed-vars (list dotted-var) - (list (-Tuple* arg-tys full-tail-ty)) - (list (-Tuple* domain (make-Listof rest))) - range)) - => finish] - ;; ... function, ... arg - [(and drest tail-bound - (= (length domain) (length arg-tys)) - (if (eq? tail-bound (cdr drest)) - ;; same bound on the ...s - (infer fixed-vars (list dotted-var) - (cons (make-ListDots tail-ty tail-bound) arg-tys) - (cons (make-ListDots (car drest) (cdr drest)) domain) - range) - ;; different bounds on the ...s - (extend-tvars (list tail-bound (cdr drest)) - (extend-indexes (cdr drest) - ;; don't need to add tail-bound - it must already be an index - (infer fixed-vars (list dotted-var) - (cons (make-ListDots tail-ty tail-bound) arg-tys) - (cons (make-ListDots (car drest) (cdr drest)) domain) - range))))) - => finish] - ;; ... function, (Listof A) or (List A B C etc) arg - [(and drest (not tail-bound) - (eq? (cdr drest) dotted-var) - (<= (length domain) (length arg-tys)) - (match full-tail-ty - [(List: tail-arg-tys #:tail (Listof: tail-arg-ty)) - (infer/vararg - fixed-vars (list dotted-var) - (cons tail-arg-ty (append arg-tys tail-arg-tys)) - (cons (car drest) domain) - (car drest) - range)] - [(List: tail-arg-tys) - (infer/dots fixed-vars dotted-var (append arg-tys tail-arg-tys) domain - (car drest) range (fv range))] - [_ #f])) - => finish] - [else #f])) - ;; Nothing matched - (match f-ty - [(tc-result1: (and t (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) - (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound - #:msg-thunk (lambda (dom) - (string-append - "Bad arguments to polymorphic function in `apply':\n" - dom)))])))] + (or + (for/or ([domain (in-list doms)] + [range (in-list rngs)] + [rest (in-list rests)] + [drest (in-list drests)]) + (define (finish substitution) (do-ret (subst-all substitution range))) + (cond + ;; the actual work, when we have a * function + [(and rest + (infer fixed-vars (list dotted-var) + (list (-Tuple* arg-tys full-tail-ty)) + (list (-Tuple* domain (make-Listof rest))) + range)) + => finish] + ;; ... function, ... arg + [(and drest tail-bound + (= (length domain) (length arg-tys)) + (if (eq? tail-bound (cdr drest)) + ;; same bound on the ...s + (infer fixed-vars (list dotted-var) + (cons (make-ListDots tail-ty tail-bound) arg-tys) + (cons (make-ListDots (car drest) (cdr drest)) domain) + range) + ;; different bounds on the ...s + (extend-tvars (list tail-bound (cdr drest)) + (extend-indexes (cdr drest) + ;; don't need to add tail-bound - it must already be an index + (infer fixed-vars (list dotted-var) + (cons (make-ListDots tail-ty tail-bound) arg-tys) + (cons (make-ListDots (car drest) (cdr drest)) domain) + range))))) + => finish] + ;; ... function, (Listof A) or (List A B C etc) arg + [(and drest (not tail-bound) + (eq? (cdr drest) dotted-var) + (<= (length domain) (length arg-tys)) + (match full-tail-ty + [(List: tail-arg-tys #:tail (Listof: tail-arg-ty)) + (infer/vararg + fixed-vars (list dotted-var) + (cons tail-arg-ty (append arg-tys tail-arg-tys)) + (cons (car drest) domain) + (car drest) + range)] + [(List: tail-arg-tys) + (infer/dots fixed-vars dotted-var (append arg-tys tail-arg-tys) domain + (car drest) range (fv range))] + [_ #f])) + => finish] + [else #f])) + ;; Nothing matched + (match f-ty + [(tc-result1: (and t (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) + (domain-mismatches f args t doms rests drests rngs arg-tres (or tail-ty full-tail-ty) tail-bound + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to polymorphic function in `apply':\n" + dom)))]))] [(tc-result1: (or (Function: '()) (Poly: _ (Function: '())) (PolyDots: _ (Function: '())))) (tc-error/expr "Function has no cases")] [(tc-result1: f-ty)