From 4f7c6aff6afece9984f62529cecbdfaad1b60761 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 Aug 2008 20:57:48 +0000 Subject: [PATCH] Fix bug 9649. svn: r11029 original commit: 28c5e71b01454eda4328a8abceed12f11aaeb865 --- .../succeed/require-typed-rename.ss | 5 +++ collects/typed-scheme/private/prims.ss | 37 ++++++++++--------- .../typed-scheme/private/require-contract.ss | 4 ++ 3 files changed, 28 insertions(+), 18 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/require-typed-rename.ss diff --git a/collects/tests/typed-scheme/succeed/require-typed-rename.ss b/collects/tests/typed-scheme/succeed/require-typed-rename.ss new file mode 100644 index 00000000..ffa51d6a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/require-typed-rename.ss @@ -0,0 +1,5 @@ +#lang typed-scheme + +(require/typed srfi/67 [(char-compare s67:char-compare) (Char Char -> Integer)]) + +s67:char-compare diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index f94b97b5..c08757f2 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -59,24 +59,25 @@ This file defines two sorts of primitives. All of them are provided into any mod #'(begin (require/typed nm ty lib) ...)] [(_ nm ty lib) (identifier? #'nm) - (quasisyntax/loc stx (begin - #,(syntax-property (syntax-property #'(define cnt* #f) - 'typechecker:contract-def #'ty) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal nm ty)) - #,(syntax-property #'(require/contract nm cnt* lib) - 'typechecker:ignore #t)))] - [(_ (rename internal-nm nm) ty lib) - (raise-syntax-error "rename not currently supported" stx) - #; #; - (identifier? #'nm) - (quasisyntax/loc stx (begin - #,(syntax-property (syntax-property #'(define cnt* #f) - 'typechecker:contract-def #'ty) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal internal-nm ty)) - #,(syntax-property #'(require/contract nm cnt* lib) - 'typechecker:ignore #t)))])) + (with-syntax ([(cnt*) (syntax->datum #'(nm))]) + (quasisyntax/loc stx (begin + #,(syntax-property (syntax-property #'(define cnt* #f) + 'typechecker:contract-def #'ty) + 'typechecker:ignore #t) + #,(internal #'(require/typed-internal nm ty)) + #,(syntax-property #'(require/contract nm cnt* lib) + 'typechecker:ignore #t))))] + [(_ (orig-nm nm) ty lib) + (and (identifier? #'nm) + (identifier? #'orig-nm)) + (with-syntax ([(cnt*) (syntax->datum #'(nm))]) + (quasisyntax/loc stx (begin + #,(syntax-property (syntax-property #'(define cnt* #f) + 'typechecker:contract-def #'ty) + 'typechecker:ignore #t) + #,(internal #'(require/typed-internal nm ty)) + #,(syntax-property #'(require/contract (orig-nm nm) cnt* lib) + 'typechecker:ignore #t))))])) (define-syntax (require/opaque-type stx) (syntax-case stx () diff --git a/collects/typed-scheme/private/require-contract.ss b/collects/typed-scheme/private/require-contract.ss index a31bb1b8..e86e5f0d 100644 --- a/collects/typed-scheme/private/require-contract.ss +++ b/collects/typed-scheme/private/require-contract.ss @@ -17,5 +17,9 @@ (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 '#,(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))))]))