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

Add special typechecking rule for expansion of (quote-module-name).

Browse Source
This commit is contained in:
Stevie Strickland 2012-05-03 18:01:13 -04:00
parent 4651ccc0ad
commit b2bfbad240
2 changed files with 12 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/syntax/location.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(require syntax/srcloc (require syntax/srcloc
(for-syntax racket/base syntax/srcloc setup/path-to-relative)) (for-syntax racket/base syntax/srcloc setup/path-to-relative))
(provide quote-srcloc (provide (protect-out module-name-fixup)
quote-srcloc
quote-source-file quote-source-file
quote-line-number quote-line-number
quote-column-number quote-column-number

12
collects/typed-racket/typecheck/tc-app.rkt
View File

@ -10,6 +10,7 @@
scheme/bool scheme/bool
racket/unsafe/ops racket/unsafe/ops
(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)
(only-in '#%kernel [apply k:apply] [reverse k:reverse]) (only-in '#%kernel [apply k:apply] [reverse k:reverse])
;; end fixme ;; end fixme
(for-syntax syntax/parse scheme/base (utils tc-utils)) (for-syntax syntax/parse scheme/base (utils tc-utils))
@ -25,7 +26,8 @@
racket/unsafe/ops racket/fixnum racket/flonum racket/unsafe/ops racket/fixnum racket/flonum
(only-in '#%kernel [apply k:apply] [reverse k:reverse]) (only-in '#%kernel [apply k:apply] [reverse k:reverse])
"internal-forms.rkt" scheme/base scheme/bool '#%paramz "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^) (import tc-expr^ tc-lambda^ tc-let^ tc-apply^)
(export tc-app^) (export tc-app^)
@ -262,7 +264,7 @@
(define (tc/app/internal form expected) (define (tc/app/internal form expected)
(syntax-parse form (syntax-parse form
#:literals (#%plain-app #%plain-lambda letrec-values quote #: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 map andmap ormap reverse k:reverse extend-parameterization
vector-ref unsafe-vector-ref unsafe-vector*-ref vector-ref unsafe-vector-ref unsafe-vector*-ref
vector-set! unsafe-vector-set! unsafe-vector*-set! 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 (not (andmap type-annotation (syntax->list #'(lp . args)))) #f
#:fail-unless (free-identifier=? #'lp #'lp*) #f #:fail-unless (free-identifier=? #'lp #'lp*) #f
(let-loop-check form #'lam #'lp #'actuals #'args #'body expected)] (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 ;; special cases for classes
[(#%plain-app make-object cl . args) [(#%plain-app make-object cl . args)
(check-do-make-object #'cl #'args #'() #'())] (check-do-make-object #'cl #'args #'() #'())]