diff --git a/collects/tests/typed-scheme/succeed/rts-prov.rkt b/collects/tests/typed-scheme/fail/rts-prov.rkt similarity index 80% rename from collects/tests/typed-scheme/succeed/rts-prov.rkt rename to collects/tests/typed-scheme/fail/rts-prov.rkt index f20b849e..616c2ab6 100644 --- a/collects/tests/typed-scheme/succeed/rts-prov.rkt +++ b/collects/tests/typed-scheme/fail/rts-prov.rkt @@ -1,3 +1,6 @@ +#; +(exn-pred exn:fail:syntax? #rx".*unbound identifier.*make-q.*") + #lang scheme/load (module l scheme diff --git a/collects/tests/typed-scheme/succeed/pr11425.rkt b/collects/tests/typed-scheme/succeed/pr11425.rkt new file mode 100644 index 00000000..6d6efc36 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/pr11425.rkt @@ -0,0 +1,12 @@ +#lang racket/load + +(module sgn-exporter typed/racket/base + (require/typed + racket/math + [sgn (Integer -> Fixnum)]) + (provide (all-defined-out))) + +(module sgn-importer typed/racket/base + (require racket/math 'sgn-exporter)) + +(require 'sgn-exporter) diff --git a/collects/typed-scheme/base-env/prims.rkt b/collects/typed-scheme/base-env/prims.rkt index 9a35d8f0..eda281a1 100644 --- a/collects/typed-scheme/base-env/prims.rkt +++ b/collects/typed-scheme/base-env/prims.rkt @@ -122,6 +122,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #'()))] [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) (with-syntax ([cnt* (generate-temporary #'nm.nm)] + [hidden (generate-temporary #'nm.nm)] [sm (if (attribute parent) #'(#:struct-maker parent) #'())]) @@ -141,8 +142,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-property #'(define cnt* #f) prop-name #'ty)) 'typechecker:ignore #t) - #,(internal #'(require/typed-internal nm.nm ty . sm)) - #,(syntax-property #'(require/contract nm.spec cnt* lib) + #,(internal #'(require/typed-internal hidden ty . sm)) + #,(syntax-property #'(require/contract nm.spec hidden cnt* lib) 'typechecker:ignore #t)))))])) (values (r/t-maker #t) (r/t-maker #f)))) @@ -177,16 +178,17 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...) (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) - (quasisyntax/loc stx - (begin - #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) - #,(if (attribute ne) - (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) - (syntax/loc stx (define-type-alias ty (Opaque pred)))) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t)))])) + (with-syntax ([hidden (generate-temporary #'pred)]) + (quasisyntax/loc stx + (begin + #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) + 'typechecker:ignore #t) + #,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred)))) + #,(if (attribute ne) + (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) + (syntax/loc stx (define-type-alias ty (Opaque pred)))) + #,(syntax-property #'(require/contract pred hidden pred-cnt lib) + 'typechecker:ignore #t))))])) (define-syntax (plambda: stx) (syntax-parse stx @@ -443,6 +445,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ name:opt-parent ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) lib) (with-syntax* ([nm #'name.nm] [parent #'name.parent] + [hidden (generate-temporary #'name.nm)] [spec (if (syntax-e #'name.parent) #'(nm parent) #'nm)] [(struct-info _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] @@ -474,8 +477,8 @@ This file defines two sorts of primitives. All of them are provided into any mod si)) (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only) - #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib)) - #,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) + #,(ignore #'(require/contract pred hidden (any/c . c-> . boolean?) lib)) + #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm))) (require/typed (maker-name real-maker) nm lib #:struct-maker parent) ;This needs to be a different identifier to meet the specifications diff --git a/collects/typed-scheme/utils/require-contract.rkt b/collects/typed-scheme/utils/require-contract.rkt index bb2ffb47..10a14519 100644 --- a/collects/typed-scheme/utils/require-contract.rkt +++ b/collects/typed-scheme/utils/require-contract.rkt @@ -4,6 +4,7 @@ syntax/location (for-syntax scheme/base syntax/parse + racket/syntax (prefix-in tr: "../private/typed-renaming.rkt"))) (provide require/contract define-ignored) @@ -31,26 +32,32 @@ [(_ id) (tr:get-alternate #'id)])) + + +;Requires an identifier from an untyped module into a typed module +;nm is the import +;hidden is an id that will end up being the actual definition +;nm will be bound to a rename transformer so that it is not provided +;with all-defined-out (define-syntax (require/contract stx) (define-syntax-class renameable (pattern nm:id - #:with r ((make-syntax-introducer) #'nm))) + #:with orig-nm #'nm + #:with orig-nm-r ((make-syntax-introducer) #'nm)) + (pattern (orig-nm:id nm:id) + #:with orig-nm-r ((make-syntax-introducer) #'nm))) + (syntax-parse stx - [(require/contract nm:renameable cnt lib) - #`(begin (require (only-in lib [nm nm.r])) - (define-ignored nm + [(require/contract nm:renameable hidden:id cnt lib) + #`(begin (require (only-in lib [nm.orig-nm nm.orig-nm-r])) + (define-syntax nm.nm (make-rename-transformer + (syntax-property (syntax-property (quote-syntax hidden) + 'not-free-identifier=? #t) + 'not-provide-all-defined #t))) + (define-ignored hidden (contract cnt - (get-alternate nm.r) - '(interface for #,(syntax->datum #'nm)) + (get-alternate nm.orig-nm-r) + '(interface for #,(syntax->datum #'nm.nm)) (current-contract-region) - (quote nm) - (quote-srcloc nm))))] - [(require/contract (orig-nm:renameable nm:id) cnt lib) - #`(begin (require (only-in lib [orig-nm orig-nm.r])) - (define-ignored nm - (contract cnt - (get-alternate orig-nm.r) - '#,(syntax->datum #'nm) - (current-contract-region) - (quote nm) - (quote-srcloc nm))))])) + (quote nm.nm) + (quote-srcloc nm.nm))))]))