From b173d1f7ccd4dc539fc6facda2dd6e653d19c99e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 3 May 2012 18:01:13 -0400 Subject: [PATCH] Add special typechecking rule for expansion of (quote-module-name). original commit: b2bfbad240cdd3cb17b84733f7d6467ee225f48c --- collects/typed-racket/typecheck/tc-app.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index ba376698..2f5f7c62 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -10,6 +10,7 @@ scheme/bool racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) + (only-in syntax/location module-name-fixup) (only-in '#%kernel [apply k:apply] [reverse k:reverse]) ;; end fixme (for-syntax syntax/parse scheme/base (utils tc-utils)) @@ -25,7 +26,8 @@ racket/unsafe/ops racket/fixnum racket/flonum (only-in '#%kernel [apply k:apply] [reverse k:reverse]) "internal-forms.rkt" scheme/base scheme/bool '#%paramz - (only-in racket/private/class-internal make-object do-make-object))) + (only-in racket/private/class-internal make-object do-make-object) + (only-in syntax/location module-name-fixup))) (import tc-expr^ tc-lambda^ tc-let^ tc-apply^) (export tc-app^) @@ -262,7 +264,7 @@ (define (tc/app/internal form expected) (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote - values apply k:apply not false? list list* call-with-values do-make-object make-object cons + values apply k:apply not false? list list* call-with-values do-make-object make-object module-name-fixup cons map andmap ormap reverse k:reverse extend-parameterization vector-ref unsafe-vector-ref unsafe-vector*-ref vector-set! unsafe-vector-set! unsafe-vector*-set! @@ -589,6 +591,12 @@ #:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f #:fail-unless (free-identifier=? #'lp #'lp*) #f (let-loop-check form #'lam #'lp #'actuals #'args #'body expected)] + ;; special case for (current-contract-region)'s default expansion + ;; just let it through without any typechecking, since module-name-fixup + ;; is a private function from syntax/location, so this must have been + ;; (quote-module-name) originally. + [(#%plain-app module-name-fixup src path) + (ret Univ)] ;; special cases for classes [(#%plain-app make-object cl . args) (check-do-make-object #'cl #'args #'() #'())]