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

Fix error handling when non-poly Name is applied.

Browse Source 
svn: r9607
This commit is contained in:
Sam Tobin-Hochstadt 2008-05-02 22:19:18 +00:00
parent a521d279e3
commit ac1acc7bf6
3 changed files with 8 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/parse-type.ss
View File

@ -162,11 +162,13 @@
[(lookup-type-alias #'id parse-type (lambda () #f)) [(lookup-type-alias #'id parse-type (lambda () #f))
=> =>
(lambda (t) (lambda (t)
;(printf "found a type alias ~a~n" #'id)
(add-type-name-reference #'id) (add-type-name-reference #'id)
t)] t)]
;; if it's a type name, we just use the name ;; if it's a type name, we just use the name
[(lookup-type-name #'id (lambda () #f)) [(lookup-type-name #'id (lambda () #f))
(add-type-name-reference #'id) (add-type-name-reference #'id)
;(printf "found a type name ~a~n" #'id)
(make-Name #'id)] (make-Name #'id)]
[else [else
(tc-error/delayed "unbound type ~a" (syntax-e #'id)) (tc-error/delayed "unbound type ~a" (syntax-e #'id))

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

@ -223,12 +223,14 @@
;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
(subtype* A0 parent other)] (subtype* A0 parent other)]
;; applications and names are structs too ;; applications and names are structs too
[(list (App: (Name: n) args _) other) [(list (App: (Name: n) args stx) other)
(let ([t (lookup-type-name n)]) (let ([t (lookup-type-name n)])
(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)
(tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
(let ([v (subtype* A0 (instantiate-poly t args) other)]) (let ([v (subtype* A0 (instantiate-poly t args) other)])
#;(printf "val: ~a~n" v) #;(printf "val: ~a~n" v)
v))] v))]

4
collects/typed-scheme/private/type-alias-env.ss
View File

@ -3,7 +3,7 @@
(require syntax/boundmap (require syntax/boundmap
"tc-utils.ss" "tc-utils.ss"
mzlib/trace mzlib/trace
mzlib/plt-match) scheme/match)
(provide register-type-alias (provide register-type-alias
lookup-type-alias lookup-type-alias
@ -30,6 +30,8 @@
(mapping-put! id (make-unresolved stx #f))) (mapping-put! id (make-unresolved stx #f)))
(define (register-resolved-type-alias id ty) (define (register-resolved-type-alias id ty)
#;(when (eq? 'Number (syntax-e id))
(printf "registering type ~a ~a~n~a~n" id (syntax-e id) ty))
(mapping-put! id (make-resolved ty))) (mapping-put! id (make-resolved ty)))
(define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))]) (define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])