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

Fix require/untyped-contract to generate better names in contracts.

Browse Source 
Related to PR 13716.
(cherry picked from commit 9c71dafb63)
This commit is contained in:
Eric Dobson 2013-04-27 18:53:36 -07:00 committed by Ryan Culpepper
parent a901650bab
commit a9868eece1
5 changed files with 15 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/math/matrix.rkt
View File

@ -50,7 +50,7 @@
(require/untyped-contract
(begin (require "private/matrix/matrix-types.rkt"
"private/matrix/matrix-gauss-elim.rkt"))
(only-in "private/matrix/matrix-gauss-elim.rkt" Pivoting)))
"private/matrix/matrix-gauss-elim.rkt"
[matrix-gauss-elim
(case-> ((Matrix Number) -> (Values (Matrix Number) (Listof Index)))

4
collects/math/private/array/array-indexing.rkt
View File

@ -8,9 +8,7 @@
array-indexes-set!))
(require/untyped-contract
(begin (require "array-struct.rkt"
"utils.rkt"
"typed-array-indexing.rkt"))
(begin (require (only-in "array-struct.rkt" Array Settable-Array)))
"typed-array-indexing.rkt"
[array-ref (All (A) ((Array A) (Vectorof Integer) -> A))]
[array-set! (All (A) ((Settable-Array A) (Vectorof Integer) A -> Void))]

2
collects/math/private/array/array-struct.rkt
View File

@ -10,7 +10,7 @@
list->array))
(require/untyped-contract
(begin (require "typed-array-struct.rkt"))
(begin (require (only-in "typed-array-struct.rkt" Array)))
"typed-array-struct.rkt"
[build-array (All (A) ((Vectorof Integer) ((Vectorof Index) -> A) -> (Array A)))]
[build-simple-array (All (A) ((Vectorof Integer) ((Vectorof Index) -> A) -> (Array A)))]

2
collects/math/private/array/mutable-array.rkt
View File

@ -8,7 +8,7 @@
vector->array))
(require/untyped-contract
(begin (require "typed-mutable-array.rkt"))
(begin (require (only-in "typed-mutable-array.rkt" Mutable-Array)))
"typed-mutable-array.rkt"
[vector->array (All (A) (case-> ((Vectorof A) -> (Mutable-Array A))
((Vectorof Integer) (Vectorof A) -> (Mutable-Array A))))])

16
collects/typed/untyped-utils.rkt
View File

@ -3,6 +3,7 @@
(require (for-syntax racket/base
syntax/parse
racket/syntax
unstable/syntax
typed-racket/utils/tc-utils)
typed-racket/utils/tc-utils)
@ -30,12 +31,16 @@
(define-syntax name
(typed/untyped-renamer #'typed-name #'untyped-name)))]))
(define-for-syntax (freshen ids)
(syntax-map (lambda (id) ((make-syntax-introducer) id)) ids))
(define-syntax (require/untyped-contract stx)
(syntax-parse stx #:literals (begin)
[(_ (begin form ...) from-module-spec:expr [name:id T:expr] ...)
(with-syntax* ([(typed-name ...) (generate-temporaries #'(name ...))]
[(untyped-name ...) (generate-temporaries #'(name ...))]
[(untyped-name ...) (freshen #'(name ...))]
[(untyped2-name ...) (generate-temporaries #'(name ...))]
[(untyped3-name ...) (generate-temporaries #'(name ...))]
[(macro-name ...) (generate-temporaries #'(name ...))]
[typed-module (generate-temporary #'typed-module)]
[untyped-module (generate-temporary #'untyped-module)])
@ -43,19 +48,20 @@
(begin
(module typed-module typed/racket/base
(begin form ...)
(require (only-in from-module-spec name ...))
(require (rename-in (only-in from-module-spec name ...)
[name untyped2-name] ...))
(provide untyped-name ...)
(: untyped-name T) ...
(define untyped-name name) ...)
(define untyped-name untyped2-name) ...)
(module untyped-module racket/base
(require typed/untyped-utils
(rename-in (only-in from-module-spec name ...)
[name typed-name] ...)
(rename-in (only-in (submod ".." typed-module) untyped-name ...)
[untyped-name untyped2-name] ...))
[untyped-name untyped3-name] ...))
(provide macro-name ...)
(define-typed/untyped-identifier macro-name typed-name untyped2-name) ...)
(define-typed/untyped-identifier macro-name typed-name untyped3-name) ...)
(require (rename-in (submod "." untyped-module) [macro-name name] ...)))))]
[(_ from-module-spec:expr [name:id T:expr] ...)