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

Require that `require/typed' uses the contracted version of typed identifiers.

Browse Source 
svn: r14415
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-03 18:42:38 +00:00
parent e9cf5787c1
commit 6d302a9304
4 changed files with 86 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/tests/typed-scheme/fail/require-typed-wrong.ss Normal file
View File

@ -0,0 +1,15 @@
#;
(exn-pred ".*contract.*")
#lang scheme/load
(module m typed-scheme
(: x (Number -> Number))
(define (x n) (add1 n))
(provide x))
(module n typed-scheme
(require (only-in 'm))
(require/typed 'm [x (String -> Number)])
(x "foo"))
(require 'n)

31
collects/typed-scheme/private/require-contract.ss
View File

@ -1,6 +1,9 @@
#lang scheme/base
(require scheme/contract (for-syntax scheme/base syntax/kerncase))
(require scheme/contract (for-syntax scheme/base syntax/kerncase
"../utils/tc-utils.ss"
(prefix-in tr: "typed-renaming.ss")))
(provide require/contract define-ignored)
(define-syntax (define-ignored stx)
@ -20,12 +23,30 @@
'inferred-name
(syntax-e #'name)))])]))
(define-syntax (get-alternate stx)
(syntax-case stx ()
[(_ id)
(tr:get-alternate #'id)]))
(define-syntax (require/contract stx)
(syntax-case stx ()
[(require/contract nm cnt lib)
(identifier? #'nm)
#`(begin (require (only-in lib [nm tmp]))
(define-ignored nm (contract cnt tmp '(interface for #,(syntax->datum #'nm)) 'never-happen (quote-syntax nm))))]
(begin
#`(begin (require (only-in lib [nm tmp]))
(define-ignored nm
(contract cnt
(get-alternate tmp)
'(interface for #,(syntax->datum #'nm))
'never-happen
(quote-syntax nm)))))]
[(require/contract (orig-nm nm) cnt lib)
#`(begin (require (only-in lib [orig-nm tmp]))
(define-ignored nm (contract cnt tmp '#,(syntax->datum #'nm) 'never-happen (quote-syntax nm))))]))
(begin
#`(begin (require (only-in lib [orig-nm tmp]))
(define-ignored nm
(contract cnt
(get-alternate tmp)
'#,(syntax->datum #'nm)
'never-happen
(quote-syntax nm)))))]))

20
collects/typed-scheme/private/typed-renaming.ss Normal file
View File

@ -0,0 +1,20 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide make-typed-renaming get-alternate)
;; target : identifier
;; alternate : identifier
(define-struct typed-renaming (target alternate)
#:property prop:rename-transformer 0)
;; identifier -> identifier
;; get the alternate field of the renaming, if it exists
(define (get-alternate id)
(define-values (v new-id) (syntax-local-value/immediate id (lambda _ (values #f #f))))
(cond [(typed-renaming? v)
(typed-renaming-alternate v)]
[(rename-transformer? v)
(get-alternate (rename-transformer-target v))]
[else id]))

43
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -5,7 +5,7 @@
syntax/kerncase syntax/boundmap
(env type-name-env type-alias-env)
mzlib/trace
(private type-contract)
(private type-contract typed-renaming)
(rep type-rep)
(utils tc-utils)
"def-binding.ss")
@ -13,7 +13,8 @@
(require (for-template scheme/base
scheme/contract))
(provide remove-provides provide? generate-prov)
(provide remove-provides provide? generate-prov
get-alternate)
(define (provide? form)
(kernel-syntax-case form #f
@ -24,6 +25,12 @@
(define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list forms)))
(define (renamer id #:alt [alt #f])
(if alt
(make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
(make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
(define (generate-prov stx-defs val-defs)
(define mapping (make-free-identifier-mapping))
(lambda (form)
@ -54,35 +61,35 @@
(define/contract cnt-id #,cnt id)
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer (syntax-property #'id
'not-free-identifier=? #t))
(make-rename-transformer (syntax-property #'cnt-id
'not-free-identifier=? #t))))
(renamer #'id #:alt #'cnt-id)
(renamer #'cnt-id)))
(#%provide (rename export-id out-id)))))]
[else
(with-syntax ([(export-id) (generate-temporaries #'(id))])
#`(begin
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax error-id
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer (syntax-property #'id
'not-free-identifier=? #t))
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))))
(renamer #'id #:alt #'error-id)
(renamer #'error-id)))
(provide (rename-out [export-id out-id]))))])))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])
#`(begin
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax error-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))
(define-syntax export-id
(if (unbox typed-context?)
(begin
(begin
(add-alias #'export-id #'id)
(make-rename-transformer (syntax-property #'id
'not-free-identifier=? #t)))
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))))
(renamer #'id #:alt #'error-id))
(renamer #'error-id)))
(provide (rename-out [export-id out-id]))))))]
[(eq? (syntax-e internal-id) (syntax-e external-id))
#`(provide #,internal-id)]