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

Cleanup duplication in check-subforms-unit.

Browse Source
This commit is contained in:
Eric Dobson 2013-11-14 22:55:15 -08:00
parent ee47fe5f25
commit 1d0164f51b
1 changed files with 45 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
View File

@ -8,6 +8,7 @@
(types utils abbrev union resolve) (types utils abbrev union resolve)
(private syntax-properties) (private syntax-properties)
(utils tc-utils) (utils tc-utils)
(for-syntax racket/base syntax/parse)
(rep type-rep)) (rep type-rep))
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^) (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
@ -32,6 +33,20 @@
(ret (map (lambda (ts) (apply Un ts)) ts*)))] (ret (map (lambda (ts) (apply Un ts)) ts*)))]
[_ (int-err "Internal error: unsupported exception result type in: ~a" args)])) [_ (int-err "Internal error: unsupported exception result type in: ~a" args)]))
;; Does a depth first search of the syntax object. For each sub object it attempts to match it
;; against the provide syntax-parse patterns.
(define-syntax find-syntax
(syntax-parser
[(_ init-form [clause bodies ...+] ...)
#'(let loop ([form init-form])
(parameterize ([current-orig-stx form])
(syntax-parse form
[clause bodies ...] ...
[(a . b)
(loop #'a)
(loop #'b) ]
[_ (void)])))]))
;; find the subexpressions that need to be typechecked in an ignored form ;; find the subexpressions that need to be typechecked in an ignored form
;; syntax -> any ;; syntax -> any
(define (check-subforms/with-handlers form [expected #f]) (define (check-subforms/with-handlers form [expected #f])
@ -51,61 +66,42 @@
[(or (Poly: ns _) (PolyDots: (list ns ... _) _)) [(or (Poly: ns _) (PolyDots: (list ns ... _) _))
(loop (instantiate-poly t (map (λ (n) Univ) ns)))] (loop (instantiate-poly t (map (λ (n) Univ) ns)))]
[_ (int-err "Unsupported function type in get-result-ty: \n~a" t)]))) [_ (int-err "Unsupported function type in get-result-ty: \n~a" t)])))
(let loop ([form form]) (find-syntax form
(parameterize ([current-orig-stx form]) ;; if this needs to be checked
(syntax-parse form [stx:with-type^
;; if this needs to be checked ;; the form should be already ascribed the relevant type
[stx:with-type^ (tc-expr #'stx)]
;; the form should be already ascribed the relevant type ;; this is a handler function
(tc-expr form)] [stx:exn-handler^
;; this is a handler function (match (single-value #'stx)
[stx:exn-handler^ [(tc-result1: t)
(let ([t (single-value form)]) (set! handler-tys (cons (get-result-ty t) handler-tys))])]
(match t ;; this is the body of the with-handlers
[(tc-result1: t) [stx:exn-body^
(set! handler-tys (cons (get-result-ty t) handler-tys))]))] (set! body-stx #'stx)
;; this is the body of the with-handlers (set! body-ty (tc-expr #'stx))])
[stx:exn-body^
(set! body-stx form)
(set! body-ty (tc-expr form))]
[(a . b)
(loop #'a)
(loop #'b)]
[_ (void)])))
(apply combine-types body-ty handler-tys)) (apply combine-types body-ty handler-tys))
;; syntax tc-results -> tc-results ;; syntax tc-results -> tc-results
(define (check-subforms/with-handlers/check form expected) (define (check-subforms/with-handlers/check form expected)
(let loop ([form form]) (find-syntax form
(parameterize ([current-orig-stx form]) ;; if this needs to be checked
(syntax-parse form [stx:with-type^
;; if this needs to be checked ;; the form should be already ascribed the relevant type
[stx:with-type^ (tc-expr #'stx)]
;; the form should be already ascribed the relevant type ;; this is a handler function
(tc-expr form)] [stx:exn-handler^
;; this is a handler function (tc-expr/check #'stx (ret (-> (Un) (tc-results->values expected))))]
[stx:exn-handler^ ;; this is the body of the with-handlers
(tc-expr/check form (ret (-> (Un) (tc-results->values expected))))] [stx:exn-body^
;; this is the body of the with-handlers (tc-expr/check #'stx expected)])
[stx:exn-body^
(tc-expr/check form expected)]
[(a . b)
(begin
(loop #'a)
(loop #'b))]
[_ (void)])))
expected) expected)
;; typecheck the expansion of a with-handlers form ;; typecheck the expansion of a with-handlers form
;; syntax -> void ;; syntax -> void
(define (check-subforms/ignore form) (define (check-subforms/ignore form)
(let loop ([form form]) (find-syntax form
(syntax-parse form ;; if this needs to be checked
;; if this needs to be checked [stx:with-type^
[stx:with-type^ ;; the form should be already ascribed the relevant type
;; the form should be already ascribed the relevant type (void (tc-expr #'stx))]))
(void (tc-expr form))]
[(a . b)
(loop #'a)
(loop #'b)]
[_ (void)])))