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

Fix error in use of tc-error/delayed.

Browse Source 
Fix expansion of with-handlers:
add test

svn: r11875
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-25 19:35:00 +00:00
parent 9373be4b3d
commit cd6a37ff4c
3 changed files with 18 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/tests/typed-scheme/succeed/with-handlers.ss Normal file
View File

@ -0,0 +1,10 @@
#lang typed-scheme
(define: (f [i : Integer]) : (Pair String Char)
(cons "foo" #\space))
(define: (is-happiness-a-warm-gun?) : Boolean
(with-handlers ([integer? (lambda: ([x : Any]) #t)])
(f 42)
#t))

2
collects/typed-scheme/private/prims.ss
View File

@ -301,7 +301,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax->list #'(pred? ...)))] (syntax->list #'(pred? ...)))]
[(action* ...) [(action* ...)
(map (lambda (s) (syntax-property s 'typechecker:exn-handler #t)) (syntax->list #'(action ...)))] (map (lambda (s) (syntax-property s 'typechecker:exn-handler #t)) (syntax->list #'(action ...)))]
[body* (syntax-property #'(begin . body) 'typechecker:exn-body #t)]) [body* (syntax-property #'(let-values () . body) 'typechecker:exn-body #t)])
(syntax-property #'(with-handlers ([pred?* action*] ...) body*) (syntax-property #'(with-handlers ([pred?* action*] ...) body*)
'typechecker:with-handlers 'typechecker:with-handlers
#t))])) #t))]))

11
collects/typed-scheme/private/type-annotation.ss
View File

@ -103,16 +103,19 @@
(match ty (match ty
[(Values: tys) [(Values: tys)
(if (not (= (length stxs) (length tys))) (if (not (= (length stxs) (length tys)))
(tc-error/delayed #:ret (map (lambda _ (Un)) stxs) (begin
(tc-error/delayed
"Expression should produce ~a values, but produces ~a values of types ~a" "Expression should produce ~a values, but produces ~a values of types ~a"
(length stxs) (length tys) (stringify tys)) (length stxs) (length tys) (stringify tys))
(map (lambda _ (Un)) stxs))
(map (lambda (stx ty a) (map (lambda (stx ty a)
(cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)] (cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)]
[else #;(log/noann stx ty) ty])) [else #;(log/noann stx ty) ty]))
stxs tys anns))] stxs tys anns))]
[ty (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) [ty (tc-error/delayed
"Expression should produce ~a values, but produces one values of type " "Expression should produce ~a values, but produces one values of type ~a"
(length stxs) ty)]))))])) (length stxs) ty)
(map (lambda _ (Un)) stxs)]))))]))
;; check that e-type is compatible with ty in context of stx ;; check that e-type is compatible with ty in context of stx