From 88fac43d551687efc72b6241c2dffbbaffe270d7 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 31 Jan 2011 12:36:23 -0500 Subject: [PATCH] Add an Exact-Number type. --- .../unit-tests/typecheck-tests.rkt | 2 +- collects/typed-scheme/private/base-types.rkt | 1 + .../typed-scheme/private/type-contract.rkt | 1 + .../typed-scheme/typecheck/tc-expr-unit.rkt | 2 ++ collects/typed-scheme/types/convenience.rkt | 1 + collects/typed-scheme/types/numeric-tower.rkt | 23 ++++++++++--------- 6 files changed, 18 insertions(+), 12 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index f6b0642a7f..50ded9b7bc 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -871,7 +871,7 @@ (tc-l -5# -NegFlonum) (tc-l -5.0 -NegFlonum) (tc-l -5.1 -NegFlonum) - (tc-l 1+1i N) + (tc-l 1+1i -ExactNumber) (tc-l 1+1.0i -FloatComplex) (tc-l 1.0+1i -FloatComplex) (tc-l 1.0+1.1i -FloatComplex) diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 29d7b7b8b5..161a255e41 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -5,6 +5,7 @@ [Inexact-Complex -InexactComplex] [Single-Flonum-Complex -SingleFlonumComplex] [Float-Complex -FloatComplex] +[Exact-Number -ExactNumber] [Real -Real] [Nonpositive-Real -NonPosReal] [Negative-Real -NegReal] diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index 06ba685aa3..d17e71b395 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/collects/typed-scheme/private/type-contract.rkt @@ -164,6 +164,7 @@ [(== t:-NegReal type-equal?) #'(flat-named-contract 'Negative-Real (and/c real? negative?))] [(== t:-NonPosReal type-equal?) #'(flat-named-contract 'Nonpositive-Real (and/c real? (lambda (x) (<= x 0))))] [(== t:-Real type-equal?) #'(flat-named-contract 'Real real?)] + [(== t:-ExactNumber type-equal?) #'(flat-named-contract 'Exact-Number (and/c number? exact?))] [(== t:-InexactComplex type-equal?) #'(flat-named-contract 'Inexact-Complex (and/c number? diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index d602751d2a..2462bec2d9 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -59,6 +59,8 @@ [(~var i (3d inexact-real?)) -InexactReal] ; catch-all, just in case [(~var i (3d real?)) -Real] ; catch-all, just in case ;; a complex number can't have a float imaginary part and an exact real part + [(~var i (3d (conjoin number? exact?))) + -ExactNumber] [(~var i (3d (conjoin number? (lambda (x) (and (flonum? (imag-part x)) (flonum? (real-part x))))))) -FloatComplex] diff --git a/collects/typed-scheme/types/convenience.rkt b/collects/typed-scheme/types/convenience.rkt index 0f05188234..3c76f116df 100644 --- a/collects/typed-scheme/types/convenience.rkt +++ b/collects/typed-scheme/types/convenience.rkt @@ -38,6 +38,7 @@ [(? (lambda (t) (subtype t -SingleFlonum))) -SingleFlonum] [(? (lambda (t) (subtype t -InexactReal))) -InexactReal] [(? (lambda (t) (subtype t -Real))) -Real] + [(? (lambda (t) (subtype t -ExactNumber))) -ExactNumber] [(? (lambda (t) (subtype t -FloatComplex))) -FloatComplex] [(? (lambda (t) (subtype t -SingleFlonumComplex))) -SingleFlonumComplex] [(? (lambda (t) (subtype t -Number))) -Number] diff --git a/collects/typed-scheme/types/numeric-tower.rkt b/collects/typed-scheme/types/numeric-tower.rkt index 3c3a306fe5..3c90e472de 100644 --- a/collects/typed-scheme/types/numeric-tower.rkt +++ b/collects/typed-scheme/types/numeric-tower.rkt @@ -16,7 +16,7 @@ -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero -PosSingleFlonum -NonNegSingleFlonum -NegSingleFlonum -NonPosSingleFlonum -SingleFlonum -InexactRealPosZero -InexactRealNegZero -InexactRealZero -PosInexactReal -NonNegInexactReal -NegInexactReal -NonPosInexactReal -InexactReal -RealZero -PosReal -NonNegReal -NegReal -NonPosReal -Real - -FloatComplex -SingleFlonumComplex -InexactComplex -Number + -ExactNumber -FloatComplex -SingleFlonumComplex -InexactComplex -Number (rename-out (-Int -Integer))) @@ -204,6 +204,16 @@ ;; Both parts of a complex number must be of the same exactness. ;; Thus, the only possible kinds of complex numbers are: ;; Real/Real, Flonum/Flonum, SingleFlonum/SingleFlonum +(define -ExactNumberNotReal + (make-Base 'Complex-Not-Real + #'(and/c number? + (not/c real?) + (lambda (x) (exact? (imag-part x)))) + (conjoin number? + (negate real?) + (lambda (x) (exact? (imag-part x)))) + #'-ExactNumberNotReal)) +(define -ExactNumber (*Un -ExactNumberNotReal -Rat)) (define -FloatComplex (make-Base 'Float-Complex #'(and/c number? (lambda (x) @@ -225,14 +235,5 @@ (single-flonum? (real-part x))))) #'-SingleFlonumComplex)) (define -InexactComplex (*Un -FloatComplex -SingleFlonumComplex)) -(define -ExactComplexNotReal - (make-Base 'Complex-Not-Real - #'(and/c number? - (not/c real?) - (lambda (x) (exact? (imag-part x)))) - (conjoin number? - (negate real?) - (lambda (x) (exact? (imag-part x)))) - #'-ExactComplexNotReal)) -(define -Complex (*Un -Real -InexactComplex -ExactComplexNotReal)) +(define -Complex (*Un -Real -InexactComplex -ExactNumberNotReal)) (define -Number -Complex)