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

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

@ -228,12 +228,32 @@
(unless (Type? t)
(fail! s t))
#;(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)
(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)))])
(let ([v (subtype* A0 (instantiate-poly t args) other)])
#;(printf "val: ~a~n" 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)
(let ([t (lookup-type-name n)])
;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other)
@ -253,7 +273,7 @@
[(list (Instance: t) (Instance: t*))
(subtype* A0 t t*)]
;; otherwise, not a subtype
[_ (fail! s t) (printf "failed")]))))))
[_ (fail! s t) #;(printf "failed")]))))))
(define (type-compare? a b)
(and (subtype a b) (subtype b a)))

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

@ -271,7 +271,8 @@
;; FIXME
;; should be an error here, something went horribly wrong!!!
(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*)))))))]
#|
(printf "subst is:~a~nret is: ~a~nvars is: ~a~nresult is:~a~n" substitution (car rngs*) vars