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

PR 10645

Browse Source 
svn: r18193
This commit is contained in:
Robby Findler 2010-02-19 19:43:14 +00:00
parent 9170687148
commit 7aa6ea4c76
2 changed files with 32 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/scheme/contract/private/provide.ss
View File

@ -17,7 +17,7 @@
[(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)])) [(_ name x) #'(coerce-contract name x)]))
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
(make-set!-transformer (make-set!-transformer
(let ([saved-id-table (make-hasheq)]) (let ([saved-id-table (make-hasheq)])
(λ (stx) (λ (stx)
@ -30,6 +30,7 @@
;; No: lift the contract creation: ;; No: lift the contract creation:
(with-syntax ([contract-id contract-id] (with-syntax ([contract-id contract-id]
[id id] [id id]
[external-id external-id]
[pos-module-source pos-module-source] [pos-module-source pos-module-source]
[id-ref (syntax-case stx (set!) [id-ref (syntax-case stx (set!)
[(set! whatever e) [(set! whatever e)
@ -45,7 +46,7 @@
id id
pos-module-source pos-module-source
(quote-module-path) (quote-module-path)
'id 'external-id
(quote-syntax id))))))]) (quote-syntax id))))))])
(when key (when key
(hash-set! saved-id-table key lifted-id)) (hash-set! saved-id-table key lifted-id))
@ -655,6 +656,7 @@
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax external-name)
(quote-syntax pos-module-source))) (quote-syntax pos-module-source)))
(provide (rename-out [id-rename external-name]))))]) (provide (rename-out [id-rename external-name]))))])

27
collects/tests/mzscheme/contract-test.ss
View File

@ -7080,6 +7080,7 @@ so that propagation occurs.
(eval 'provide/contract34-x)) (eval 'provide/contract34-x))
10) 10)
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce1-bug scheme/base (eval '(module pce1-bug scheme/base
@ -7181,6 +7182,32 @@ so that propagation occurs.
(and (exn? x) (and (exn? x)
(regexp-match #rx"pce8-bug" (exn-message x))))) (regexp-match #rx"pce8-bug" (exn-message x)))))
(contract-error-test
#'(begin
(eval '(module pce9-bug scheme
(define (f x) "wrong")
(provide/contract
[rename f g
(-> number? number?)])))
(eval '(require 'pce9-bug))
(eval '(g 12)))
(λ (x)
(and (exn? x)
(regexp-match #rx"broke the contract.*on g" (exn-message x)))))
(contract-error-test
#'(begin
(eval '(module pce10-bug scheme
(define (f x) "wrong")
(provide/contract
[rename f g
(-> number? number?)])))
(eval '(require 'pce10-bug))
(eval '(g 'a)))
(λ (x)
(and (exn? x)
(regexp-match #rx"broke the contract.*on g" (exn-message x)))))
(contract-eval (contract-eval
`(,test `(,test
'pos 'pos