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

checkpoint

Browse Source 
svn: r17045
This commit is contained in:
Sam Tobin-Hochstadt 2009-11-24 17:10:44 +00:00
parent 176920530f
commit 29c4a84183
4 changed files with 12 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/tests/typed-scheme/fail/back-and-forth.ss
View File

@ -1,18 +1,19 @@
#; #;
(exn-pred exn:fail:contract? #rx".*violator.*contract.*\\(-> Number Number\\).*") (exn-pred exn:fail:contract? #rx".*violator.*contract.*\\(-> Number Number\\).*f.*")
#lang scheme/load #lang scheme/load
(module m typed/scheme (module m typed/scheme
(: f (Number -> Number)) (: f (Number -> Number))
(define (f x) (add1 x)) (define (f x) (add1 x))
(provide f)) (define g 17)
(provide f g))
(module violator scheme (module violator scheme
(require 'm) (require 'm)
(f 'foo)) (f 'foo))
(module o typed-scheme (module o typed/scheme
(require 'violator)) (require 'violator))
(require 'o) (require 'o)

2
collects/typed-scheme/ts-reference.scrbl
View File

@ -228,7 +228,7 @@ This is legal only in expression contexts.}
appropriate number of type variables. This is legal only in expression appropriate number of type variables. This is legal only in expression
contexts.} contexts.}
@schemevarfont|{#{e @ t ...}}| This is identical to @scheme[(inst e t ...)]. @litchar|{#{e @ t ...}}| This is identical to @scheme[(inst e t ...)].
@subsection{Require} @subsection{Require}

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

@ -33,7 +33,7 @@
(make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
(make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) (make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
(define (generate-prov stx-defs val-defs) (define (generate-prov stx-defs val-defs pos-blame-id)
(define mapping (make-free-identifier-mapping)) (define mapping (make-free-identifier-mapping))
(lambda (form) (lambda (form)
(define (mem? i vd) (define (mem? i vd)
@ -59,19 +59,15 @@
=> =>
(lambda (cnt) (lambda (cnt)
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))] (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]
[module-source (generate-temporary 'module-source)] [module-source pos-blame-id]
;; don't actually need to verify - this is generated
[the-contract (generate-temporary 'generated-contract)]) [the-contract (generate-temporary 'generated-contract)])
#`(begin #`(begin
(define module-source (#%variable-reference))
(define the-contract #,cnt) (define the-contract #,cnt)
(define-syntax cnt-id (define-syntax cnt-id
(make-provide/contract-transformer (make-provide/contract-transformer
(quote-syntax the-contract) (quote-syntax the-contract)
(quote-syntax id) (quote-syntax id)
(quote-syntax module-source))) (quote-syntax module-source)))
#;
(define/contract cnt-id #,cnt id)
(define-syntax export-id (define-syntax export-id
(if (unbox typed-context?) (if (unbox typed-context?)
(renamer #'id #:alt #'cnt-id) (renamer #'id #:alt #'cnt-id)

8
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -3,7 +3,7 @@
(require (rename-in "../utils/utils.ss" [infer r:infer])) (require (rename-in "../utils/utils.ss" [infer r:infer]))
(require syntax/kerncase (require syntax/kerncase
unstable/list unstable/list unstable/syntax
mzlib/etc mzlib/etc
scheme/match scheme/match
"signatures.ss" "signatures.ss"
@ -253,9 +253,11 @@
;; report delayed errors ;; report delayed errors
(report-all-errors) (report-all-errors)
;; compute the new provides ;; compute the new provides
(with-syntax (with-syntax*
([((new-provs ...) ...) (map (generate-prov stx-defs val-defs) provs)]) ([the-variable-reference (generate-temporary #'blame)]
[((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)])
#`(begin #`(begin
(define the-variable-reference (#%variable-reference))
#,(env-init-code) #,(env-init-code)
#,(tname-env-init-code) #,(tname-env-init-code)
#,(talias-env-init-code) #,(talias-env-init-code)