From 690f54e633ea354dbe0bebea73337c2af4c1e38c Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Fri, 16 Nov 2012 10:52:56 -0700 Subject: [PATCH] Added `define-typed/untyped-identifier' to typed/untyped-utils Made return types of `flvector-length' and `unsafe-flvector-length' more precise (they return Index) original commit: ac424a73a5f3fa81d34f11585ff80b63b5cdebb6 --- .../base-env/base-env-indexing-abs.rkt | 4 +- collects/typed/untyped-utils.rkt | 45 +++++++++++-------- 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/collects/typed-racket/base-env/base-env-indexing-abs.rkt b/collects/typed-racket/base-env/base-env-indexing-abs.rkt index 5b31d5d8..07e04f51 100644 --- a/collects/typed-racket/base-env/base-env-indexing-abs.rkt +++ b/collects/typed-racket/base-env/base-env-indexing-abs.rkt @@ -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))] diff --git a/collects/typed/untyped-utils.rkt b/collects/typed/untyped-utils.rkt index c041ce75..b03f5986 100644 --- a/collects/typed/untyped-utils.rkt +++ b/collects/typed/untyped-utils.rkt @@ -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] ...)