Simplify failure case in tc-apply.
This commit is contained in:
parent
fafe7365ae
commit
345673c953
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user