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

Fix Typed Racket handling of exception handling with multiple return values.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2011-07-18 17:42:28 -04:00
parent 23c47728c5
commit 42b79dd489
2 changed files with 37 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
View File

@ -1354,6 +1354,10 @@
(tc-e (let: ((p : (Promise Symbol) (delay 's)))
(promise-running? p)) B)
|#
;; excetion handling
[tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" ""))
#:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))]
;Kernel Structs, check that their hidden identifiers type
(tc-e (void exn

50
collects/typed-scheme/typecheck/check-subforms-unit.rkt
View File

@ -5,6 +5,7 @@
syntax/parse
racket/match
"signatures.rkt" "tc-metafunctions.rkt"
"tc-funapp.rkt" "tc-subst.rkt"
(types utils convenience union subtype)
(utils tc-utils)
(rep type-rep))
@ -12,20 +13,39 @@
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
(export check-subforms^)
;; FIXME -- samth 7/15/11
;; This code is doing the wrong thing wrt the arguments of exception handlers.
;; In particular, it allows them to be anything at all, but they might
;; get called with the wrong kind of arguments by the exception
;; mechanism. The right thing is to use the exception predicate.
(define (transpose l) (apply map list l))
;; combine-types : Values * -> tc-results
(define (combine-types . args)
(match args
[(list (tc-results: tss) ...)
(unless (apply = (map length tss))
(tc-error "Exception handlers and body did not all have the same number of results: ~a" (map length tss)))
;; transpose and union
(let ([ts* (transpose tss)])
(ret (map (lambda (ts) (apply Un ts)) ts*)))]
[_ (int-err "Internal error: unsupported exception result type in: ~a" args)]))
;; find the subexpressions that need to be typechecked in an ignored form
;; syntax -> any
(define (check-subforms/with-handlers form [expected #f])
(define handler-tys '())
(define body-ty #f)
(define body-stx #f)
;; tc-result1 -> tc-results
;; The result of applying the function to a single argument of type (Un)
;; FIXME: (Un) is the wrong type, see above fixme
(define (get-result-ty t)
(match t
[(Function:
(list
(arr: _
(Values: (list (Result: rngs _ _) ...))
_ _ (list (Keyword: _ _ #t) ...))))
(apply Un rngs)]
[_ (int-err "Internal error in get-result-ty: not a function type: \n~a" t)]))
[(tc-result1: (Function: _))
(tc/funapp #'here #'(here) t (list (ret (Un))) #f)]
[_ (int-err "Unsupported function type in get-result-ty: \n~a" t)]))
(let loop ([form form])
(parameterize ([current-orig-stx form])
(syntax-parse form
@ -37,26 +57,22 @@
[stx
;; this is a handler function
#:when (syntax-property form 'typechecker:exn-handler)
(let ([t (tc-expr form)])
(let ([t (single-value form)])
(match t
[(tc-result1:
(and t
(Function: (list (arr: (list _) _ _ _ (list (Keyword: _ _ #f) ...)) ...))))
[(tc-result1: (Function: _))
(set! handler-tys (cons (get-result-ty t) handler-tys))]
[(tc-results: t)
(tc-error "Exception handler must be a single-argument function, got \n~a" t)]))]
(tc-error "Exception handler must be a function, got \n~a" t)]))]
[stx
;; this is the body of the with-handlers
#:when (syntax-property form 'typechecker:exn-body)
(match (tc-expr form)
[(tc-result1: t) (set! body-ty t)]
[(tc-results: ts) (tc-expr form)
(tc-error "Exception handler body must return a single value, got \n~a" (length ts))])]
(set! body-stx form)
(set! body-ty (tc-expr form))]
[(a . b)
(loop #'a)
(loop #'b)]
[_ (void)])))
(ret (apply Un body-ty handler-tys)))
(apply combine-types body-ty handler-tys))
;; syntax type -> any
(define (check-subforms/with-handlers/check form expected)