[MLton-devel] cvs commit: the beginnings of a Real32 structure
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 24 Jul 2003 12:47:11 -0700
sweeks 03/07/24 12:47:11
Modified: basis-library/libs/basis-2002/top-level basis.sig
basis-library/misc primitive.sml
basis-library/real IEEE-real.sig IEEE-real.sml real.sig
real.sml
runtime Makefile
Added: regression real32.sml
runtime/basis/Real toReal.c
Log:
Revision Changes Path
1.11 +1 -1 mlton/basis-library/libs/basis-2002/top-level/basis.sig
Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- basis.sig 26 Jun 2003 14:08:47 -0000 1.10
+++ basis.sig 24 Jul 2003 19:47:09 -0000 1.11
@@ -187,7 +187,7 @@
structure RealVector : MONO_VECTOR
structure RealVectorSlice : MONO_VECTOR_SLICE
structure RealArray2 : MONO_ARRAY2
- (* structure Real32 : REAL *)
+ structure Real32 : REAL32
structure Real32Array : MONO_ARRAY
structure Real32ArraySlice : MONO_ARRAY_SLICE
structure Real32Vector : MONO_VECTOR
1.66 +11 -2 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -r1.65 -r1.66
--- primitive.sml 20 Jul 2003 18:07:58 -0000 1.65
+++ primitive.sml 24 Jul 2003 19:47:10 -0000 1.66
@@ -77,6 +77,7 @@
structure Int = Int32
type int = Int.int
+structure LargeReal = Real64
structure Real = Real64
type real = Real.real
structure Word = Word32
@@ -731,9 +732,17 @@
_import "Ptrace_ptrace4": int * pid * word * word ref -> int;
end
- structure Real =
+ structure Real32 =
struct
- type real = real64
+ type real = Real32.real
+
+ val fromLarge = _import "Real64_toReal32": LargeReal.real -> real;
+ val toLarge = _import "Real32_toReal64": real -> LargeReal.real;
+ end
+
+ structure Real64 =
+ struct
+ type real = Real64.real
structure Math =
struct
1.6 +11 -6 mlton/basis-library/real/IEEE-real.sig
Index: IEEE-real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/IEEE-real.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- IEEE-real.sig 1 Jun 2003 00:31:30 -0000 1.5
+++ IEEE-real.sig 24 Jul 2003 19:47:11 -0000 1.6
@@ -17,17 +17,22 @@
| TO_POSINF
| TO_ZERO
- val setRoundingMode: rounding_mode -> unit
- val getRoundingMode: unit -> rounding_mode
-
type decimal_approx = {class: float_class,
digits: int list,
exp: int,
sign: bool}
- val toString: decimal_approx -> string
- val scan: (char, 'a) StringCvt.reader
- -> (decimal_approx, 'a) StringCvt.reader
val fromString: string -> decimal_approx option
+ val getRoundingMode: unit -> rounding_mode
+ val scan: (char, 'a) StringCvt.reader
+ -> (decimal_approx, 'a) StringCvt.reader
+ val setRoundingMode: rounding_mode -> unit
+ val toString: decimal_approx -> string
end
+signature IEEE_REAL_EXTRA =
+ sig
+ include IEEE_REAL
+
+ val withRoundingMode: rounding_mode * (unit -> 'a) -> 'a
+ end
1.8 +12 -2 mlton/basis-library/real/IEEE-real.sml
Index: IEEE-real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/IEEE-real.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- IEEE-real.sml 2 Jun 2003 20:03:59 -0000 1.7
+++ IEEE-real.sml 24 Jul 2003 19:47:11 -0000 1.8
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure IEEEReal: IEEE_REAL =
+structure IEEEReal: IEEE_REAL_EXTRA =
struct
val op + = Int.+
val op - = Int.-
@@ -44,7 +44,17 @@
val setRoundingMode = Prim.setRoundingMode o rounding_modeToInt
val getRoundingMode = intToRounding_mode o Prim.getRoundingMode
-
+
+ fun withRoundingMode (m: rounding_mode, th: unit -> 'a): 'a =
+ let
+ val m' = getRoundingMode ()
+ val _ = setRoundingMode m
+ val res = th ()
+ val _ = setRoundingMode m'
+ in
+ res
+ end
+
type decimal_approx = {class: float_class,
digits: int list,
exp: int,
1.7 +8 -0 mlton/basis-library/real/real.sig
Index: real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- real.sig 1 Jun 2003 00:31:30 -0000 1.6
+++ real.sig 24 Jul 2003 19:47:11 -0000 1.7
@@ -81,3 +81,11 @@
val toString: real -> string
val unordered: real * real -> bool
end
+
+signature REAL32 =
+ sig
+ type real
+
+ val toLarge: real -> LargeReal.real
+ val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
+ end
1.22 +17 -15 mlton/basis-library/real/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sml,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- real.sml 23 Jun 2003 04:58:53 -0000 1.21
+++ real.sml 24 Jul 2003 19:47:11 -0000 1.22
@@ -1,6 +1,18 @@
+structure Real32: REAL32 =
+ struct
+ structure Prim = Primitive.Real32
+
+ type real = Prim.real
+
+ fun fromLarge m r =
+ IEEEReal.withRoundingMode (m, fn () => Prim.fromLarge r)
+
+ val toLarge = Prim.toLarge
+ end
+
structure Real64: REAL =
struct
- structure Prim = Primitive.Real
+ structure Prim = Primitive.Real64
local
open IEEEReal
in
@@ -8,7 +20,7 @@
datatype z = datatype rounding_mode
end
infix 4 == != ?=
- type real = real
+ type real = Prim.real
local
open Prim
@@ -169,23 +181,13 @@
| NAN => raise Div
| _ => x
- fun withRoundingMode (m, th) =
- let
- val m' = IEEEReal.getRoundingMode ()
- val _ = IEEEReal.setRoundingMode m
- val res = th ()
- val _ = IEEEReal.setRoundingMode m'
- in
- res
- end
-
val maxInt = fromInt Int.maxInt'
val minInt = fromInt Int.minInt'
fun toInt mode x =
let
- fun doit () = withRoundingMode (mode, fn () =>
- Prim.toInt (Prim.round x))
+ fun doit () = IEEEReal.withRoundingMode (mode, fn () =>
+ Prim.toInt (Prim.round x))
in
case class x of
NAN => raise Domain
@@ -233,7 +235,7 @@
case class x of
NAN => x
| INF => x
- | _ => withRoundingMode (mode, fn () => Prim.round x)
+ | _ => IEEEReal.withRoundingMode (mode, fn () => Prim.round x)
in
val realFloor = round TO_NEGINF
val realCeil = round TO_POSINF
1.1 mlton/regression/real32.sml
Index: real32.sml
===================================================================
datatype z = datatype IEEEReal.rounding_mode
val _ =
List.app
(fn r =>
List.app
(fn m =>
let
val r' = Real32.toLarge (Real32.fromLarge m r)
in
print (concat [Real.fmt StringCvt.EXACT r,
" ",
Real.fmt StringCvt.EXACT r',
"\n"])
end)
[TO_NEAREST, TO_NEGINF, TO_POSINF, TO_ZERO])
[Real.negInf,
~ Real.maxFinite,
~1.0,
~ Real.minNormalPos,
~ Real.minPos,
0.0,
Real.minPos,
Real.minNormalPos,
1.0,
Real.maxFinite,
Real.posInf,
Real.posInf + Real.negInf]
1.68 +2 -0 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -r1.67 -r1.68
--- Makefile 26 Jun 2003 03:28:20 -0000 1.67
+++ Makefile 24 Jul 2003 19:47:11 -0000 1.68
@@ -87,6 +87,7 @@
basis/Real/round.o \
basis/Real/signBit.o \
basis/Real/strtod.o \
+ basis/Real/toReal.o \
basis/Stdio.o \
basis/Thread.o \
basis/Time.o \
@@ -254,6 +255,7 @@
basis/Real/round-gdb.o \
basis/Real/signBit-gdb.o \
basis/Real/strtod-gdb.o \
+ basis/Real/toReal-gdb.o \
basis/Stdio-gdb.o \
basis/Thread-gdb.o \
basis/Time-gdb.o \
1.1 mlton/runtime/basis/Real/toReal.c
Index: toReal.c
===================================================================
#include <math.h>
#include "mlton-basis.h"
Real32 Real64_toReal32 (Real64 r) {
return (Real32)r;
}
Real64 Real32_toReal64 (Real32 r) {
return (Real64)r;
}
-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100003ave/direct;at.aspnet_072303_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel