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

Handle errors in type application.

Browse Source 
svn: r9915
This commit is contained in:
Sam Tobin-Hochstadt 2008-05-20 20:47:18 +00:00
parent 1e7cffdcdf
commit ac1027af8b
2 changed files with 27 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/typed-scheme/private/subtype.ss
View File

@ -228,12 +228,32 @@
(unless (Type? t) (unless (Type? t)
(fail! s t)) (fail! s t))
#;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other #;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other
(instantiate-poly t args)) (instantiate-poly t args))
(unless (Poly? t) (unless (Poly? t)
(tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) (tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
(let ([v (subtype* A0 (instantiate-poly t args) other)]) (match t [(Poly-unsafe: n _)
(unless (= n (length args))
(tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a"
n (length args)))])
(let ([v (subtype* A0 (instantiate-poly t args) other)])
#;(printf "val: ~a~n" v) #;(printf "val: ~a~n" v)
v))] v))]
[(list other (App: (Name: n) args stx))
(let ([t (lookup-type-name n)])
(unless (Type? t)
(fail! s t))
#;(printf "subtype: 2 app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other
(instantiate-poly t args))
(unless (Poly? t)
(tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
(match t [(Poly-unsafe: n _)
(unless (= n (length args))
(tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a"
n (length args)))])
;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args))
(let ([v (subtype* A0 other (instantiate-poly t args))])
#;(printf "2 val: ~a~n" v)
v))]
[(list (Name: n) other) [(list (Name: n) other)
(let ([t (lookup-type-name n)]) (let ([t (lookup-type-name n)])
;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other) ;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other)
@ -253,7 +273,7 @@
[(list (Instance: t) (Instance: t*)) [(list (Instance: t) (Instance: t*))
(subtype* A0 t t*)] (subtype* A0 t t*)]
;; otherwise, not a subtype ;; otherwise, not a subtype
[_ (fail! s t) (printf "failed")])))))) [_ (fail! s t) #;(printf "failed")]))))))
(define (type-compare? a b) (define (type-compare? a b)
(and (subtype a b) (subtype b a))) (and (subtype a b) (subtype b a)))

5
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -227,7 +227,7 @@
(if (= 1 (length doms)) (if (= 1 (length doms))
(let-values ([(thn-eff els-eff) (let-values ([(thn-eff els-eff)
(tc-args argtypes arg-thn-effs arg-els-effs (car doms) (car rests) (tc-args argtypes arg-thn-effs arg-els-effs (car doms) (car rests)
(car latent-thn-effs) (car latent-els-effs) (car latent-thn-effs) (car latent-els-effs)
(syntax->list args))]) (syntax->list args))])
(ret (car rngs) thn-eff els-eff) (ret (car rngs) thn-eff els-eff)
#;(if (false-effect? eff) #;(if (false-effect? eff)
@ -271,7 +271,8 @@
;; FIXME ;; FIXME
;; should be an error here, something went horribly wrong!!! ;; should be an error here, something went horribly wrong!!!
(begin (begin
(printf "substituion was bad~n") #;
(printf "substitution was bad~n args: ~a ~n new-doms: ~a~n~a~n" argtypes new-doms* substitution)
(loop (cdr doms*) (cdr rngs*)))))))] (loop (cdr doms*) (cdr rngs*)))))))]
#| #|
(printf "subst is:~a~nret is: ~a~nvars is: ~a~nresult is:~a~n" substitution (car rngs*) vars (printf "subst is:~a~nret is: ~a~nvars is: ~a~nresult is:~a~n" substitution (car rngs*) vars