Make TR's ignore-some property work even if there isn't an internal form.

This commit is contained in:
Eric Dobson 2012-07-26 21:15:42 -07:00 committed by Sam Tobin-Hochstadt
parent 9e5060ef5b
commit bb67e37c49
2 changed files with 7 additions and 10 deletions

View File

@ -100,7 +100,7 @@
expected) expected)
;; typecheck the expansion of a with-handlers form ;; typecheck the expansion of a with-handlers form
;; syntax -> any ;; syntax -> void
(define (check-subforms/ignore form) (define (check-subforms/ignore form)
(let loop ([form form]) (let loop ([form form])
(kernel-syntax-case* form #f () (kernel-syntax-case* form #f ()
@ -108,7 +108,7 @@
;; if this needs to be checked ;; if this needs to be checked
(syntax-property form 'typechecker:with-type) (syntax-property form 'typechecker:with-type)
;; the form should be already ascribed the relevant type ;; the form should be already ascribed the relevant type
(tc-expr form)] (void (tc-expr form))]
[(a . b) [(a . b)
(loop #'a) (loop #'a)
(loop #'b)] (loop #'b)]

View File

@ -286,10 +286,9 @@
(check-subforms/with-handlers/check form expected)] (check-subforms/with-handlers/check form expected)]
[stx [stx
#:when (syntax-property form 'typechecker:ignore-some) #:when (syntax-property form 'typechecker:ignore-some)
(let ([ty (check-subforms/ignore form)]) (check-subforms/ignore form)
(unless ty ;; We trust ignore to be only on syntax objects objects that are well typed
(int-err "internal error: ignore-some")) expected]
(check-below ty expected))]
;; explicit failure ;; explicit failure
[(quote-syntax ((~literal typecheck-fail-internal) stx msg:str var)) [(quote-syntax ((~literal typecheck-fail-internal) stx msg:str var))
(explicit-fail #'stx #'msg #'var)] (explicit-fail #'stx #'msg #'var)]
@ -397,10 +396,8 @@
ty)] ty)]
[stx [stx
#:when (syntax-property form 'typechecker:ignore-some) #:when (syntax-property form 'typechecker:ignore-some)
(let ([ty (check-subforms/ignore form)]) (check-subforms/ignore form)
(unless ty Univ]
(int-err "internal error: ignore-some"))
ty)]
;; explicit failure ;; explicit failure
[(quote-syntax ((~literal typecheck-fail-internal) stx msg var)) [(quote-syntax ((~literal typecheck-fail-internal) stx msg var))
(explicit-fail #'stx #'msg #'var)] (explicit-fail #'stx #'msg #'var)]