[MLton-commit] r5766

Matthew Fluet fluet at mlton.org
Wed Jul 11 21:23:09 PDT 2007


Float to/from unsigned integer conversion primitives were never exercised; added float to/from word conversions
----------------------------------------------------------------------

U   mlton/trunk/basis-library/build/sources.mlb
U   mlton/trunk/basis-library/integer/num0.sml
U   mlton/trunk/basis-library/integer/word.sig
U   mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml
U   mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig
U   mlton/trunk/basis-library/mlton/mlton.sig
U   mlton/trunk/basis-library/mlton/mlton.sml
A   mlton/trunk/basis-library/mlton/real.sig
U   mlton/trunk/basis-library/mlton.mlb
U   mlton/trunk/basis-library/primitive/prim-real.sml
U   mlton/trunk/basis-library/real/real.sig
U   mlton/trunk/basis-library/real/real.sml

----------------------------------------------------------------------

Modified: mlton/trunk/basis-library/build/sources.mlb
===================================================================
--- mlton/trunk/basis-library/build/sources.mlb	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/build/sources.mlb	2007-07-12 04:23:01 UTC (rev 5766)
@@ -357,6 +357,7 @@
    ../mlton/weak.sml
    ../mlton/finalizable.sig
    ../mlton/finalizable.sml
+   ../mlton/real.sig
    ../mlton/word.sig
    ../mlton/world.sig
    ../mlton/world.sml

Modified: mlton/trunk/basis-library/integer/num0.sml
===================================================================
--- mlton/trunk/basis-library/integer/num0.sml	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/integer/num0.sml	2007-07-12 04:23:01 UTC (rev 5766)
@@ -57,6 +57,8 @@
       val zero: word
       val one: word
 
+      val maxWord': word
+
       val div: word * word -> word
       val mod: word * word -> word
 
@@ -84,6 +86,8 @@
             val zero = zextdFromWord32 0w0
             val one = zextdFromWord32 0w1
 
+            val maxWord' = notb zero
+
             local
                fun make f (w, w') =
                   if Primitive.Controls.safe andalso w' = zero

Modified: mlton/trunk/basis-library/integer/word.sig
===================================================================
--- mlton/trunk/basis-library/integer/word.sig	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/integer/word.sig	2007-07-12 04:23:01 UTC (rev 5766)
@@ -62,6 +62,8 @@
       val zero: word
       val one: word
 
+      val maxWord' : word
+
       val toWord: word -> Word.word
       val toWordX: word -> Word.word
       val fromWord: Word.word -> word

Modified: mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml	2007-07-12 04:23:01 UTC (rev 5766)
@@ -100,6 +100,7 @@
 signature MLTON_PROCESS = MLTON_PROCESS
 signature MLTON_PROFILE = MLTON_PROFILE
 signature MLTON_RANDOM = MLTON_RANDOM
+signature MLTON_REAL = MLTON_REAL
 signature MLTON_RLIMIT = MLTON_RLIMIT
 signature MLTON_RUSAGE = MLTON_RUSAGE
 signature MLTON_SIGNAL = MLTON_SIGNAL

Modified: mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig	2007-07-12 04:23:01 UTC (rev 5766)
@@ -325,6 +325,8 @@
       sharing type MLton.IntInf.t = IntInf.int
       sharing type MLton.Process.pid = Posix.Process.pid
       sharing type MLton.ProcEnv.gid = Posix.ProcEnv.gid
+      sharing type MLton.Real32.t = Real32.real
+      sharing type MLton.Real64.t = Real64.real
       sharing type MLton.Signal.t = Posix.Signal.signal
       sharing type MLton.Word.t = Word.word
       sharing type MLton.Word8.t = Word8.word

Modified: mlton/trunk/basis-library/mlton/mlton.sig
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sig	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/mlton/mlton.sig	2007-07-12 04:23:01 UTC (rev 5766)
@@ -38,12 +38,14 @@
       structure Process: MLTON_PROCESS
       structure Profile: MLTON_PROFILE
 (*      structure Ptrace: MLTON_PTRACE *)
-      structure Random: MLTON_RANDOM
+      structure Random: MLTON_RANDOM 
       structure Real32: sig
-                           val castFromWord: Word32.word -> Real32.real
-                           val castToWord: Real32.real -> Word32.word
+                           include MLTON_REAL
+                           val castFromWord: Word32.word -> t
+                           val castToWord: t -> Word32.word
                         end
       structure Real64: sig
+                           include MLTON_REAL
                            val castFromWord: Word64.word -> Real64.real
                            val castToWord: Real64.real -> Word64.word
                         end

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2007-07-12 04:23:01 UTC (rev 5766)
@@ -60,8 +60,18 @@
 (* structure Ptrace = MLtonPtrace *)
 structure Profile = MLtonProfile
 structure Random = MLtonRandom
-structure Real32 = Primitive.PackReal32
-structure Real64 = Primitive.PackReal64
+structure Real32 = 
+   struct
+      open Real32
+      type t = real
+      open Primitive.PackReal32
+   end
+structure Real64 = 
+   struct
+      open Real64 
+      type t = real
+      open Primitive.PackReal64
+   end
 structure Rlimit = MLtonRlimit
 structure Rusage = MLtonRusage
 structure Signal = MLtonSignal

Added: mlton/trunk/basis-library/mlton/real.sig
===================================================================
--- mlton/trunk/basis-library/mlton/real.sig	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/mlton/real.sig	2007-07-12 04:23:01 UTC (rev 5766)
@@ -0,0 +1,17 @@
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature MLTON_REAL =
+   sig
+      type t
+
+      val fromWord: word -> t
+      val fromLargeWord: LargeWord.word -> t
+      val toWord: IEEEReal.rounding_mode -> t -> word
+      val toLargeWord: IEEEReal.rounding_mode -> t -> LargeWord.word
+   end

Modified: mlton/trunk/basis-library/mlton.mlb
===================================================================
--- mlton/trunk/basis-library/mlton.mlb	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/mlton.mlb	2007-07-12 04:23:01 UTC (rev 5766)
@@ -32,6 +32,7 @@
       signature MLTON_PROCESS
       signature MLTON_PROFILE
       signature MLTON_RANDOM
+      signature MLTON_REAL
       signature MLTON_RLIMIT
       signature MLTON_RUSAGE
       signature MLTON_SIGNAL

Modified: mlton/trunk/basis-library/primitive/prim-real.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim-real.sml	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/primitive/prim-real.sml	2007-07-12 04:23:01 UTC (rev 5766)
@@ -76,6 +76,12 @@
       val fromReal32Unsafe: Primitive.Real32.real -> real
       val fromReal64Unsafe: Primitive.Real64.real -> real
 
+      (* Word to float; depends on rounding mode. *)
+      val fromWord8Unsafe: Primitive.Word8.word -> real
+      val fromWord16Unsafe: Primitive.Word16.word -> real
+      val fromWord32Unsafe: Primitive.Word32.word -> real
+      val fromWord64Unsafe: Primitive.Word64.word -> real
+
       (* Float to integer, taking lowbits. *)
       val toInt8Unsafe: real -> Primitive.Int8.int
       val toInt16Unsafe: real -> Primitive.Int16.int
@@ -85,6 +91,12 @@
       (* Float to float; depends on rounding mode. *)
       val toReal32Unsafe: real -> Primitive.Real32.real
       val toReal64Unsafe: real -> Primitive.Real64.real
+
+      (* Float to word, taking lowbits. *)
+      val toWord8Unsafe: real -> Primitive.Word8.word
+      val toWord16Unsafe: real -> Primitive.Word16.word
+      val toWord32Unsafe: real -> Primitive.Word32.word
+      val toWord64Unsafe: real -> Primitive.Word64.word
    end
 
 structure Primitive = struct
@@ -156,6 +168,11 @@
       val fromReal32Unsafe = _prim "Real32_rndToReal32": Real32.real -> real;
       val fromReal64Unsafe = _prim "Real64_rndToReal32": Real64.real -> real;
 
+      val fromWord8Unsafe = _prim "WordU8_rndToReal32": Word8.word -> real;
+      val fromWord16Unsafe = _prim "WordU16_rndToReal32": Word16.word -> real;
+      val fromWord32Unsafe = _prim "WordU32_rndToReal32": Word32.word -> real;
+      val fromWord64Unsafe = _prim "WordU64_rndToReal32": Word64.word -> real;
+
       val toInt8Unsafe = _prim "Real32_rndToWordS8": real -> Int8.int;
       val toInt16Unsafe = _prim "Real32_rndToWordS16": real -> Int16.int;
       val toInt32Unsafe = _prim "Real32_rndToWordS32": real -> Int32.int;
@@ -163,6 +180,11 @@
 
       val toReal32Unsafe = _prim "Real32_rndToReal32": real -> Real32.real;
       val toReal64Unsafe = _prim "Real32_rndToReal64": real -> Real64.real;
+
+      val toWord8Unsafe = _prim "Real32_rndToWordU8": real -> Word8.word;
+      val toWord16Unsafe = _prim "Real32_rndToWordU16": real -> Word16.word;
+      val toWord32Unsafe = _prim "Real32_rndToWordU32": real -> Word32.word;
+      val toWord64Unsafe = _prim "Real32_rndToWordU64": real -> Word64.word;
    end
 structure Real32 =
    struct
@@ -243,6 +265,11 @@
       val fromReal32Unsafe = _prim "Real32_rndToReal64": Real32.real -> real;
       val fromReal64Unsafe = _prim "Real64_rndToReal64": Real64.real -> real;
 
+      val fromWord8Unsafe = _prim "WordU8_rndToReal64": Word8.word -> real;
+      val fromWord16Unsafe = _prim "WordU16_rndToReal64": Word16.word -> real;
+      val fromWord32Unsafe = _prim "WordU32_rndToReal64": Word32.word -> real;
+      val fromWord64Unsafe = _prim "WordU64_rndToReal64": Word64.word -> real;
+
       val toInt8Unsafe = _prim "Real64_rndToWordS8": real -> Int8.int;
       val toInt16Unsafe = _prim "Real64_rndToWordS16": real -> Int16.int;
       val toInt32Unsafe = _prim "Real64_rndToWordS32": real -> Int32.int;
@@ -251,6 +278,11 @@
       val toReal32Unsafe = _prim "Real64_rndToReal32": real -> Real32.real;
       val toReal64Unsafe = _prim "Real64_rndToReal64": real -> Real64.real;
 
+      val toWord8Unsafe = _prim "Real64_rndToWordU8": real -> Word8.word;
+      val toWord16Unsafe = _prim "Real64_rndToWordU16": real -> Word16.word;
+      val toWord32Unsafe = _prim "Real64_rndToWordU32": real -> Word32.word;
+      val toWord64Unsafe = _prim "Real64_rndToWordU64": real -> Word64.word;
+
       val castFromWord64 = _prim "Word64_castToReal64": Word64.t -> real;
       val castToWord64 = _prim "Real64_castToWord64": real -> Word64.t;
    end

Modified: mlton/trunk/basis-library/real/real.sig
===================================================================
--- mlton/trunk/basis-library/real/real.sig	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/real/real.sig	2007-07-12 04:23:01 UTC (rev 5766)
@@ -53,6 +53,11 @@
       val fromReal32Unsafe: Primitive.Real32.real -> real
       val fromReal64Unsafe: Primitive.Real64.real -> real
 
+      val fromWord8Unsafe: Primitive.Word8.word -> real
+      val fromWord16Unsafe: Primitive.Word16.word -> real
+      val fromWord32Unsafe: Primitive.Word32.word -> real
+      val fromWord64Unsafe: Primitive.Word64.word -> real
+
       val toInt8Unsafe: real -> Primitive.Int8.int
       val toInt16Unsafe: real -> Primitive.Int16.int
       val toInt32Unsafe: real -> Primitive.Int32.int
@@ -60,6 +65,11 @@
 
       val toReal32Unsafe: real -> Primitive.Real32.real
       val toReal64Unsafe: real -> Primitive.Real64.real
+
+      val toWord8Unsafe: real -> Primitive.Word8.word
+      val toWord16Unsafe: real -> Primitive.Word16.word
+      val toWord32Unsafe: real -> Primitive.Word32.word
+      val toWord64Unsafe: real -> Primitive.Word64.word
   end
 
 signature REAL_GLOBAL =
@@ -140,4 +150,9 @@
    sig
       include REAL
       val realSize: Int.int
+
+      val fromWord: word -> real
+      val fromLargeWord: LargeWord.word -> real
+      val toWord: IEEEReal.rounding_mode -> real -> word
+      val toLargeWord: IEEEReal.rounding_mode -> real -> LargeWord.word
    end

Modified: mlton/trunk/basis-library/real/real.sml
===================================================================
--- mlton/trunk/basis-library/real/real.sml	2007-07-12 04:17:17 UTC (rev 5765)
+++ mlton/trunk/basis-library/real/real.sml	2007-07-12 04:23:01 UTC (rev 5766)
@@ -771,6 +771,147 @@
       val trunc = toInt TO_ZERO
       val round = toInt TO_NEAREST
 
+      local
+         fun 'a make {fromWordUnsafe: 'a -> real,
+                      toWordUnsafe: real -> 'a,
+                      other : {maxWord': 'a,
+                               wordSize: int,
+                               zeroWord: 'a}} =
+            (fromWordUnsafe,
+             if Int.<= (precision, #wordSize other)
+                then let
+                        val maxWord' = #maxWord' other
+                        (* maxWord can't be represented exactly. *)
+                        val maxWord = 
+                           IEEEReal.withRoundingMode
+                           (TO_ZERO, fn () => fromWordUnsafe maxWord')
+                        val zeroWord = #zeroWord other
+                     in
+                        fn (m: rounding_mode) => fn x =>
+                        case class x of
+                           INF => raise Overflow
+                         | NAN => raise Domain
+                         | _ => if zero <= x
+                                   then if x <= maxWord
+                                           then toWordUnsafe (roundReal (x, m))
+                                        else raise Overflow
+                                else if x > ~one 
+                                   then (case m of
+                                            TO_NEGINF => raise Overflow
+                                          | TO_POSINF => zeroWord
+                                          | TO_ZERO => zeroWord
+                                          | TO_NEAREST =>
+                                               if x < ~half
+                                                  then raise Overflow
+                                               else zeroWord)
+                                else raise Overflow
+                     end
+             else let
+                     val maxWord' = #maxWord' other
+                     val maxWord = fromWordUnsafe maxWord'
+                     val zeroWord = #zeroWord other
+                  in
+                     fn (m: rounding_mode) => fn x =>
+                     case class x of
+                        INF => raise Overflow
+                      | NAN => raise Domain
+                      | _ => if zero <= x
+                                then if x <= maxWord
+                                        then toWordUnsafe (roundReal (x, m))
+                             else if x < maxWord + one
+                                then (case m of
+                                         TO_NEGINF => maxWord'
+                                       | TO_POSINF => raise Overflow
+                                       | TO_ZERO => maxWord'
+                                       | TO_NEAREST =>
+                                            (* Depends on maxWord being odd. *)
+                                            if x - maxWord >= half
+                                               then raise Overflow
+                                            else maxWord')
+                                else raise Overflow
+                             else if x > ~one 
+                                then (case m of
+                                         TO_NEGINF => raise Overflow
+                                       | TO_POSINF => zeroWord
+                                       | TO_ZERO => zeroWord
+                                       | TO_NEAREST =>
+                                            if x < ~half
+                                               then raise Overflow
+                                            else zeroWord)
+                             else raise Overflow
+                  end)
+      in
+         val (fromWord8,toWord8) =
+            make {fromWordUnsafe = R.fromWord8Unsafe,
+                  toWordUnsafe = R.toWord8Unsafe,
+                  other = {maxWord' = Word8.maxWord',
+                           wordSize = Word8.wordSize,
+                           zeroWord = Word8.zero}}
+         val (fromWord16,toWord16) =
+            make {fromWordUnsafe = R.fromWord16Unsafe,
+                  toWordUnsafe = R.toWord16Unsafe,
+                  other = {maxWord' = Word16.maxWord',
+                           wordSize = Word16.wordSize,
+                           zeroWord = Word16.zero}}
+         val (fromWord32,toWord32) =
+            make {fromWordUnsafe = R.fromWord32Unsafe,
+                  toWordUnsafe = R.toWord32Unsafe,
+                  other = {maxWord' = Word32.maxWord',
+                           wordSize = Word32.wordSize,
+                           zeroWord = Word32.zero}}
+         val (fromWord64,toWord64) =
+            make {fromWordUnsafe = R.fromWord64Unsafe,
+                  toWordUnsafe = R.toWord64Unsafe,
+                  other = {maxWord' = Word64.maxWord',
+                           wordSize = Word64.wordSize,
+                           zeroWord = Word64.zero}}
+      end
+
+      local
+         structure S =
+            Word_ChooseWordN
+            (type 'a t = 'a -> real
+             val fWord8 = fromWord8
+             val fWord16 = fromWord16
+             val fWord32 = fromWord32
+             val fWord64 = fromWord64)
+      in
+         val fromWord = S.f
+      end
+      local
+         structure S =
+            LargeWord_ChooseWordN
+            (type 'a t = 'a -> real
+             val fWord8 = fromWord8
+             val fWord16 = fromWord16
+             val fWord32 = fromWord32
+             val fWord64 = fromWord64)
+      in
+         val fromLargeWord = S.f
+      end
+      local
+         structure S =
+            Word_ChooseWordN
+            (type 'a t = rounding_mode -> real -> 'a
+             val fWord8 = toWord8
+             val fWord16 = toWord16
+             val fWord32 = toWord32
+             val fWord64 = toWord64)
+      in
+         val toWord = S.f
+      end
+      local
+         structure S =
+            LargeWord_ChooseWordN
+            (type 'a t = rounding_mode -> real -> 'a
+             val fWord8 = toWord8
+             val fWord16 = toWord16
+             val fWord32 = toWord32
+             val fWord64 = toWord64)
+      in
+         val toLargeWord = S.f
+      end
+
       structure Math =
          struct
             open Prim.Math




More information about the MLton-commit mailing list