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

Don't export required bindings with all-defined-out and require/typed.

Browse Source 
Closes PR11425.

original commit: 44396383088e8bcebd33f6ee92013c6ae9751685
This commit is contained in:
Eric Dobson 2011-06-30 16:03:21 -04:00 committed by Vincent St-Amour
parent 3d15ead6b5
commit 27265fe60e
4 changed files with 56 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/tests/typed-scheme/succeed/rts-prov.rkt → collects/tests/typed-scheme/fail/rts-prov.rkt
View File

@ -1,3 +1,6 @@
#;
(exn-pred exn:fail:syntax? #rx".*unbound identifier.*make-q.*")
#lang scheme/load
(module l scheme

12
collects/tests/typed-scheme/succeed/pr11425.rkt Normal file
View File

@ -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)

31
collects/typed-scheme/base-env/prims.rkt
View File

@ -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

41
collects/typed-scheme/utils/require-contract.rkt
View File

@ -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))))]))