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

Simplify failure case in tc-apply.

Browse Source
This commit is contained in:
Eric Dobson 2014-04-28 21:08:53 -07:00
parent fafe7365ae
commit 345673c953
1 changed files with 15 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -42,6 +42,18 @@
(values tail-ty tail-bound)] (values tail-ty tail-bound)]
[t (values #f #f)])) [t (values #f #f)]))
(define (failure)
(match f-ty
[(tc-result1:
(and t (or (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))
(Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))
(PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))))
(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)))]))
(match f-ty (match f-ty
;; apply of simple function ;; apply of simple function
[(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
@ -62,11 +74,7 @@
;; the function has no rest argument ;; the function has no rest argument
[else (-val '())]))) [else (-val '())])))
(do-ret range))) (do-ret range)))
(domain-mismatches f args t doms rests drests rngs arg-tres full-tail-ty #f (failure))]
#:msg-thunk (lambda (dom)
(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))))
(or (or
@ -99,13 +107,7 @@
range)) range))
=> finish] => finish]
[else #f])) [else #f]))
(match f-ty (failure))]
[(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)) [(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))))
(or (or
@ -158,14 +160,7 @@
[_ #f])) [_ #f]))
=> finish] => finish]
[else #f])) [else #f]))
;; Nothing matched (failure))]
(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-result1: (or (Function: '()) (Poly: _ (Function: '())) (PolyDots: _ (Function: '()))))
(tc-error/expr "Function has no cases")] (tc-error/expr "Function has no cases")]
[(tc-result1: f-ty) [(tc-result1: f-ty)