diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index aa30d49080..581e5efa99 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -17,7 +17,7 @@ [(_ name x) (a:known-good-contract? #'x) #'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 (let ([saved-id-table (make-hasheq)]) (λ (stx) @@ -30,6 +30,7 @@ ;; No: lift the contract creation: (with-syntax ([contract-id contract-id] [id id] + [external-id external-id] [pos-module-source pos-module-source] [id-ref (syntax-case stx (set!) [(set! whatever e) @@ -45,7 +46,7 @@ id pos-module-source (quote-module-path) - 'id + 'external-id (quote-syntax id))))))]) (when key (hash-set! saved-id-table key lifted-id)) @@ -655,6 +656,7 @@ (define-syntax id-rename (make-provide/contract-transformer (quote-syntax contract-id) (quote-syntax id) + (quote-syntax external-name) (quote-syntax pos-module-source))) (provide (rename-out [id-rename external-name]))))]) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index e5e0269ee2..860cc64e38 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -7079,7 +7079,8 @@ so that propagation occurs. (eval '(require 'provide/contract34-m2)) (eval 'provide/contract34-x)) 10) - + + (contract-error-test #'(begin (eval '(module pce1-bug scheme/base @@ -7180,7 +7181,33 @@ so that propagation occurs. (printf ">> ~s\n" (exn-message x)) (and (exn? 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 `(,test 'pos