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

Added `define-typed/untyped-identifier' to typed/untyped-utils

Browse Source 
Made return types of `flvector-length' and `unsafe-flvector-length' more precise (they return Index)

original commit: ac424a73a5f3fa81d34f11585ff80b63b5cdebb6
This commit is contained in:
Neil Toronto 2012-11-16 10:52:56 -07:00
parent 728e347f29
commit 690f54e633
2 changed files with 29 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-racket/base-env/base-env-indexing-abs.rkt
View File

@ -268,7 +268,7 @@
[make-flvector (cl->* (-> index-type -FlVector)
(-> index-type -Flonum -FlVector))]
[flvector-length (-> -FlVector -NonNegFixnum)]
[flvector-length (-> -FlVector -Index)]
[flvector-ref (cl->* (-> -FlVector -NonNegFixnum -Flonum)
(-> -FlVector -Fixnum -Flonum)
(-> -FlVector index-type -Flonum))]
@ -279,7 +279,7 @@
(-> -FlVector index-type -FlVector)
(-> -FlVector index-type index-type -FlVector))]
[unsafe-flvector-length (-> -FlVector -NonNegFixnum)]
[unsafe-flvector-length (-> -FlVector -Index)]
[unsafe-flvector-ref (cl->* (-> -FlVector -NonNegFixnum -Flonum)
(-> -FlVector -Fixnum -Flonum)
(-> -FlVector index-type -Flonum))]

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

@ -2,9 +2,28 @@
(require (for-syntax racket/base
syntax/parse
racket/syntax))
racket/syntax
typed-racket/utils/tc-utils))
(provide require/untyped-contract)
(provide require/untyped-contract
define-typed/untyped-identifier)
(define-for-syntax (rename-head stx id)
(syntax-case stx ()
[(_ . args) (quasisyntax/loc stx (#,id . args))]
[_ (quasisyntax/loc stx #,id)]))
(define-for-syntax ((typed/untyped-renamer typed-name untyped-name) stx)
(if (unbox typed-context?)
(rename-head stx typed-name)
(rename-head stx untyped-name)))
(define-syntax (define-typed/untyped-identifier stx)
(syntax-parse stx
[(_ name:id typed-name:id untyped-name:id)
(syntax/loc stx
(define-syntax name
(typed/untyped-renamer #'typed-name #'untyped-name)))]))
(define-syntax (require/untyped-contract stx)
(syntax-parse stx #:literals (begin)
@ -25,23 +44,13 @@
(define untyped-name name) ...)
(module untyped-module racket/base
(require (for-syntax racket/base
typed-racket/utils/tc-utils)
(rename-in from-module-spec [name typed-name] ...)
(rename-in (submod ".." typed-module) [untyped-name untyped2-name] ...))
(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] ...))
(provide macro-name ...)
(define-for-syntax (rename-head stx id)
(syntax-case stx ()
[(_ . args) (quasisyntax/loc stx (#,id . args))]
[_ (quasisyntax/loc stx #,id)]))
(define-syntax (macro-name stx)
(if (unbox typed-context?)
(rename-head stx #'typed-name)
(rename-head stx #'untyped2-name)))
...)
(define-typed/untyped-identifier macro-name typed-name untyped2-name) ...)
(require (rename-in (submod "." untyped-module) [macro-name name] ...)))))]
[(_ from-module-spec:expr [name:id T:expr] ...)