[MLton-commit] r4408
Matthew Fluet
MLton@mlton.org
Mon, 24 Apr 2006 19:41:22 -0700
Mostly refactored real; some work left on C-side
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-prim.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-top.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-int-inf.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-int-inf.map
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int-inf.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real32.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real64.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/dynamic-wind.sig
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile 2006-04-25 02:41:19 UTC (rev 4408)
@@ -25,7 +25,7 @@
SEQ_INDEX_MAPS = seqindex-int32.map seqindex-int64.map
CTYPES_MAPS = c-types.m32.map c-types.m64.map c-types.weird.map
DEFAULT_CHAR_MAPS = default-char8.map
-DEFAULT_INT_MAPS = default-int32.map default-int64.map default-intinf.map
+DEFAULT_INT_MAPS = default-int32.map default-int64.map default-int-inf.map
DEFAULT_REAL_MAPS = default-real32.map default-real64.map
DEFAULT_WORD_MAPS = default-word32.map default-word64.map
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-25 02:41:19 UTC (rev 4408)
@@ -34,7 +34,7 @@
local
local
../config/bind/int-prim.sml
- ../config/bind/intinf-prim.sml
+ ../config/bind/int-inf-prim.sml
../config/bind/word-prim.sml
in ann "forceUsed" in
../config/default/$(DEFAULT_INT)
@@ -50,7 +50,7 @@
local
../config/bind/char-prim.sml
../config/bind/int-prim.sml
- ../config/bind/intinf-prim.sml
+ ../config/bind/int-inf-prim.sml
../config/bind/real-prim.sml
../config/bind/string-prim.sml
../config/bind/word-prim.sml
@@ -122,7 +122,7 @@
../integer/int-inf.sml
local
../config/bind/int-top.sml
- ../config/bind/intinf-top.sml
+ ../config/bind/int-inf-top.sml
../config/bind/word-top.sml
in ann "forceUsed" in
../config/default/$(DEFAULT_INT)
@@ -139,6 +139,14 @@
../integer/embed-word.sml
../integer/pack-word.sig
(* ../integer/pack-word32.sml *)
+ local
+ ../config/bind/int-top.sml
+ ../config/bind/pointer-prim.sml
+ ../config/bind/real-prim.sml
+ ../config/bind/word-top.sml
+ in ann "forceUsed" in
+ ../config/c/misc/$(CTYPES)
+ end end
../text/char.sig
../text/char.sml
@@ -154,25 +162,24 @@
../text/text.sig
../text/text.sml
+ ../text/nullstring.sml
+ ../util/CUtil.sig
+ ../util/CUtil.sml
+
../real/IEEE-real.sig
../real/IEEE-real.sml
- (* ../../misc/C.sig *)
- (* ../../misc/C.sml *)
../real/math.sig
../real/real.sig
- ../real/real.fun
+ ../real/real.sml
../real/pack-real.sig
(* ../real/pack-real.sml *)
- (* ../real/real32.sml *)
- (* ../real/real64.sml *)
local
../config/bind/real-top.sml
in ann "forceUsed" in
../config/default/$(DEFAULT_REAL)
../config/default/large-real.sml
end end
-
-(*
+ ../real/real-global.sml
local
../config/bind/int-top.sml
../config/bind/pointer-prim.sml
@@ -183,7 +190,6 @@
../config/c/position.sml
../config/c/sys-word.sml
end end
-*)
../util/unique-id.sig
../util/unique-id.fun
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-prim.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-top.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,8 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure IntInf = Primitive.IntInf
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,8 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure IntInf = IntInf
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -7,6 +7,6 @@
structure SysWord = C_UIntmax
-functor SysWord_ChooseWordN (A: CHOOSE_WORD_ARG) :
+functor SysWord_ChooseWordN (A: CHOOSE_WORDN_ARG) :
sig val f : SysWord.word A.t end =
C_UIntmax_ChooseWordN (A)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-int-inf.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,13 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure Int = IntInf
-type int = Int.int
-
-functor Int_ChooseInt (A: CHOOSE_INT_ARG) :
- sig val f : Int.int A.t end =
- ChooseInt_IntInf (A)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -29,6 +29,35 @@
fun rol (w, n) = W.rol (w, Primitive.Word32.fromWord n)
fun ror (w, n) = W.ror (w, Primitive.Word32.fromWord n)
+local
+ (* Allocate a buffer large enough to hold any formatted word in any radix.
+ * The most that will be required is for maxWord in binary.
+ *)
+ val maxNumDigits = wordSize
+ val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
+in
+ fun fmt radix (w: word): string =
+ One.use
+ (oneBuf, fn buf =>
+ let
+ val radix = fromInt (StringCvt.radixToInt radix)
+ fun loop (q, i: Int.int) =
+ let
+ val _ =
+ CharArray.update
+ (buf, i, StringCvt.digitToChar (toInt (q mod radix)))
+ val q = q div radix
+ in
+ if q = zero
+ then CharArraySlice.vector
+ (CharArraySlice.slice (buf, i, NONE))
+ else loop (q, Int.- (i, 1))
+ end
+ in
+ loop (w, Int.- (maxNumDigits, 1))
+ end)
+end
+
fun fmt radix (w: word): string =
let val radix = fromInt (StringCvt.radixToInt radix)
fun loop (q, chars) =
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-int-inf.map (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-int-inf.map 2006-04-25 02:41:19 UTC (rev 4408)
@@ -0,0 +1 @@
+DEFAULT_INT default-int-inf.sml
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1 +0,0 @@
-DEFAULT_INT default-intinf.sml
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int-inf.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,41 +0,0 @@
-(* Copyright (C) 1999-2006 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.
- *)
-
-(* Primitive names are special -- see atoms/prim.fun. *)
-
-structure Primitive = struct
-
-open Primitive
-
-structure IntInf =
- struct
- open IntInf
-
- val + = _prim "IntInf_add": int * int * C_Size.t -> int;
- val andb = _prim "IntInf_andb": int * int * C_Size.t -> int;
- val ~>> = _prim "IntInf_arshift": int * Word32.word * C_Size.t -> int;
- val compare = _prim "IntInf_compare": int * int -> Int32.int;
- val fromVector = _prim "WordVector_toIntInf": C_MPLimb.t vector -> int;
- val fromWord = _prim "Word_toIntInf": ObjptrWord.word -> int;
- val gcd = _prim "IntInf_gcd": int * int * C_Size.t -> int;
- val << = _prim "IntInf_lshift": int * Word32.word * C_Size.t -> int;
- val * = _prim "IntInf_mul": int * int * C_Size.t -> int;
- val ~ = _prim "IntInf_neg": int * C_Size.t -> int;
- val notb = _prim "IntInf_notb": int * C_Size.t -> int;
- val orb = _prim "IntInf_orb": int * int * C_Size.t -> int;
- val quot = _prim "IntInf_quot": int * int * C_Size.t -> int;
- val rem = _prim "IntInf_rem": int * int * C_Size.t -> int;
- val - = _prim "IntInf_sub": int * int * C_Size.t -> int;
- val toString =
- _prim "IntInf_toString": int * Int32.int * C_Size.t -> String8.string;
- val toVector = _prim "IntInf_toVector": int -> C_MPLimb.t vector;
- val toWord = _prim "IntInf_toWord": int -> ObjptrWord.word;
- val xorb = _prim "IntInf_xorb": int * int * C_Size.t -> int;
- end
-
-end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -190,6 +190,12 @@
struct
open Pointer
+ local
+ exception IsNull
+ in
+ val isNull : t -> bool = fn _ => raise IsNull
+ end
+
val getInt8 = _prim "Pointer_getWord8": t * C_Ptrdiff.t -> Int8.int;
val getInt16 = _prim "Pointer_getWord16": t * C_Ptrdiff.t -> Int16.int;
val getInt32 = _prim "Pointer_getWord32": t * C_Ptrdiff.t -> Int32.int;
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -13,15 +13,13 @@
open Primitive
(* NullString is used for strings that must be passed to C and hence must be
- * null terminated. After the Primitive structure is defined,
- * NullString.fromString is replaced by a version that checks that the string
- * is indeed null terminated. See the bottom of this file.
+ * null terminated.
*)
structure NullString8 :>
sig
type t
- val empty: String8.string
+ val empty: t
val fromString: String8.string -> t
end =
struct
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb 2006-04-25 02:41:19 UTC (rev 4408)
@@ -25,7 +25,7 @@
local
../config/bind/char-prim.sml
../config/bind/int-prim.sml
- ../config/bind/intinf-prim.sml
+ ../config/bind/int-inf-prim.sml
../config/bind/real-prim.sml
../config/bind/string-prim.sml
../config/bind/word-prim.sml
@@ -50,7 +50,7 @@
prim-seq.sml
prim-nullstring.sml
- prim-intinf.sml
+ prim-int-inf.sml
prim-char.sml
prim-string.sml
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -51,166 +51,6 @@
_import "PackReal64_updateRev": Word8.word array * int * real -> unit;
end
- structure Real64 =
- struct
- open Real64
-
- structure Class =
- struct
- type t = int
-
- val inf = _const "FP_INFINITE": t;
- val nan = _const "FP_NAN": t;
- val normal = _const "FP_NORMAL": t;
- val subnormal = _const "FP_SUBNORMAL": t;
- val zero = _const "FP_ZERO": t;
- end
-
- structure Math =
- struct
- type real = real
-
- val acos = _prim "Real64_Math_acos": real -> real;
- val asin = _prim "Real64_Math_asin": real -> real;
- val atan = _prim "Real64_Math_atan": real -> real;
- val atan2 = _prim "Real64_Math_atan2": real * real -> real;
- val cos = _prim "Real64_Math_cos": real -> real;
- val cosh = _import "cosh": real -> real;
- val e = #1 _symbol "Real64_Math_e": real GetSet.t; ()
- val exp = _prim "Real64_Math_exp": real -> real;
- val ln = _prim "Real64_Math_ln": real -> real;
- val log10 = _prim "Real64_Math_log10": real -> real;
- val pi = #1 _symbol "Real64_Math_pi": real GetSet.t; ()
- val pow = _import "pow": real * real -> real;
- val sin = _prim "Real64_Math_sin": real -> real;
- val sinh = _import "sinh": real -> real;
- val sqrt = _prim "Real64_Math_sqrt": real -> real;
- val tan = _prim "Real64_Math_tan": real -> real;
- val tanh = _import "tanh": real -> real;
- end
-
- val * = _prim "Real64_mul": real * real -> real;
- val *+ = _prim "Real64_muladd": real * real * real -> real;
- val *- = _prim "Real64_mulsub": real * real * real -> real;
- val + = _prim "Real64_add": real * real -> real;
- val - = _prim "Real64_sub": real * real -> real;
- val / = _prim "Real64_div": real * real -> real;
- val op < = _prim "Real64_lt": real * real -> bool;
- val op <= = _prim "Real64_le": real * real -> bool;
- val == = _prim "Real64_equal": real * real -> bool;
- val ?= = _prim "Real64_qequal": real * real -> bool;
- val abs = _prim "Real64_abs": real -> real;
- val class = _import "Real64_class": real -> int;
- val frexp = _import "Real64_frexp": real * int ref -> real;
- val gdtoa =
- _import "Real64_gdtoa": real * int * int * int ref -> CString.t;
- val fromInt = _prim "WordS32_toReal64": int -> real;
- val ldexp = _prim "Real64_ldexp": real * int -> real;
- val maxFinite = #1 _symbol "Real64_maxFinite": real GetSet.t; ()
- val minNormalPos = #1 _symbol "Real64_minNormalPos": real GetSet.t; ()
- val minPos = #1 _symbol "Real64_minPos": real GetSet.t; ()
- val modf = _import "Real64_modf": real * real ref -> real;
- val nextAfter = _import "Real64_nextAfter": real * real -> real;
- val round = _prim "Real64_round": real -> real;
- val signBit = _import "Real64_signBit": real -> int;
- val strto = _import "Real64_strto": NullString.t -> real;
- val toInt = _prim "Real64_toWordS32": real -> int;
- val ~ = _prim "Real64_neg": real -> real;
-
- val fromLarge : real -> real = fn x => x
- val toLarge : real -> real = fn x => x
- val precision : int = 53
- val radix : int = 2
- end
-
- structure Real32 =
- struct
- open Real32
-
- val precision : int = 24
- val radix : int = 2
-
- val fromLarge = _prim "Real64_toReal32": Real64.real -> real;
- val toLarge = _prim "Real32_toReal64": real -> Real64.real;
-
- fun unary (f: Real64.real -> Real64.real) (r: real): real =
- fromLarge (f (toLarge r))
-
- fun binary (f: Real64.real * Real64.real -> Real64.real)
- (r: real, r': real): real =
- fromLarge (f (toLarge r, toLarge r'))
-
- structure Math =
- struct
- type real = real
-
- val acos = _prim "Real32_Math_acos": real -> real;
- val asin = _prim "Real32_Math_asin": real -> real;
- val atan = _prim "Real32_Math_atan": real -> real;
- val atan2 = _prim "Real32_Math_atan2": real * real -> real;
- val cos = _prim "Real32_Math_cos": real -> real;
- val cosh = unary Real64.Math.cosh
- val e = #1 _symbol "Real32_Math_e": real GetSet.t; ()
- val exp = _prim "Real32_Math_exp": real -> real;
- val ln = _prim "Real32_Math_ln": real -> real;
- val log10 = _prim "Real32_Math_log10": real -> real;
- val pi = #1 _symbol "Real32_Math_pi": real GetSet.t; ()
- val pow = binary Real64.Math.pow
- val sin = _prim "Real32_Math_sin": real -> real;
- val sinh = unary Real64.Math.sinh
- val sqrt = _prim "Real32_Math_sqrt": real -> real;
- val tan = _prim "Real32_Math_tan": real -> real;
- val tanh = unary Real64.Math.tanh
- end
-
- val * = _prim "Real32_mul": real * real -> real;
- val *+ = _prim "Real32_muladd": real * real * real -> real;
- val *- = _prim "Real32_mulsub": real * real * real -> real;
- val + = _prim "Real32_add": real * real -> real;
- val - = _prim "Real32_sub": real * real -> real;
- val / = _prim "Real32_div": real * real -> real;
- val op < = _prim "Real32_lt": real * real -> bool;
- val op <= = _prim "Real32_le": real * real -> bool;
- val == = _prim "Real32_equal": real * real -> bool;
- val ?= = _prim "Real32_qequal": real * real -> bool;
- val abs = _prim "Real32_abs": real -> real;
- val class = _import "Real32_class": real -> int;
- fun frexp (r: real, ir: int ref): real =
- fromLarge (Real64.frexp (toLarge r, ir))
- val gdtoa =
- _import "Real32_gdtoa": real * int * int * int ref -> CString.t;
- val fromInt = _prim "WordS32_toReal32": int -> real;
- val ldexp = _prim "Real32_ldexp": real * int -> real;
- val maxFinite = #1 _symbol "Real32_maxFinite": real GetSet.t; ()
- val minNormalPos = #1 _symbol "Real32_minNormalPos": real GetSet.t; ()
- val minPos = #1 _symbol "Real32_minPos": real GetSet.t; ()
- val modf = _import "Real32_modf": real * real ref -> real;
- val signBit = _import "Real32_signBit": real -> int;
- val strto = _import "Real32_strto": NullString.t -> real;
- val toInt = _prim "Real32_toWordS32": real -> int;
- val ~ = _prim "Real32_neg": real -> real;
- end
-
- structure Real32 =
- struct
- open Real32
- local
- structure S = RealComparisons (Real32)
- in
- open S
- end
- end
-
- structure Real64 =
- struct
- open Real64
- local
- structure S = RealComparisons (Real64)
- in
- open S
- end
- end
-
structure TextIO =
struct
val bufSize = _command_line_const "TextIO.bufSize": int = 4096;
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,859 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-functor Real (R: PRE_REAL)(*: REAL*) =
- struct
- structure MLton = Primitive.MLton
- structure Prim = R
- local
- open IEEEReal
- in
- datatype float_class = datatype float_class
- datatype rounding_mode = datatype rounding_mode
- end
- infix 4 == != ?=
- type real = R.real
-
- local
- open Prim
- val isBytecode = MLton.Codegen.isBytecode
- in
- val *+ =
- if isBytecode
- then fn (r1, r2, r3) => r1 * r2 + r3
- else *+
- val *- =
- if isBytecode
- then fn (r1, r2, r3) => r1 * r2 - r3
- else *-
- val op * = op *
- val op + = op +
- val op - = op -
- val op / = op /
- val op / = op /
- val op < = op <
- val op <= = op <=
- val op > = op >
- val op >= = op >=
- val ~ = ~
- val abs = abs
-
- val maxFinite = maxFinite
- val minNormalPos = minNormalPos
- val minPos = minPos
-
- val precision = Primitive.Int32.toInt precision
- val radix = Primitive.Int32.toInt radix
-
- val signBit = fn r => signBit r <> 0
- end
-
- val zero = R.fromInt32Unsafe 0
- val one = R.fromInt32Unsafe 1
- val two = R.fromInt32Unsafe 2
-
- val negOne = ~ one
- val half = one / two
-
- val posInf = one / zero
- val negInf = ~one / zero
-
- val nan = posInf + negInf
-
- local
- val classes =
- let
- open R.Class
- in
- (* order here is chosen based on putting the more
- * commonly used classes at the front.
- *)
- [(normal, NORMAL),
- (zero, ZERO),
- (inf, INF),
- (nan, NAN),
- (subnormal, SUBNORMAL)]
- end
- in
- fun class x =
- let
- val i = R.class x
- in
- case List.find (fn (i', _) => i = i') classes of
- NONE => raise Fail "Real_class returned bogus integer"
- | SOME (_, c) => c
- end
- end
-
- val abs =
- if MLton.Codegen.isNative
- then abs
- else
- fn x =>
- case class x of
- INF => posInf
- | NAN => x
- | _ => if signBit x then ~x else x
-
- fun isFinite r =
- case class r of
- INF => false
- | NAN => false
- | _ => true
-
- fun isNan r = class r = NAN
-
- fun isNormal r = class r = NORMAL
-
- val op == =
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => false
- | (_, NAN) => false
- | (ZERO, ZERO) => true
- | _ => R.== (x, y)
-
- val op != = not o op ==
-
- val op ?= =
- if MLton.Codegen.isNative
- then R.?=
- else
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => true
- | (_, NAN) => true
- | (ZERO, ZERO) => true
- | _ => R.== (x, y)
-
- fun min (x, y) =
- if isNan x
- then y
- else if isNan y
- then x
- else if x < y then x else y
-
- fun max (x, y) =
- if isNan x
- then y
- else if isNan y
- then x
- else if x > y then x else y
-
- fun sign (x: real): int =
- case class x of
- NAN => raise Domain
- | ZERO => 0
- | _ => if x > zero then 1 else ~1
-
- fun sameSign (x, y) = signBit x = signBit y
-
- fun copySign (x, y) =
- if sameSign (x, y)
- then x
- else ~ x
-
- local
- datatype z = datatype IEEEReal.real_order
- in
- fun compareReal (x, y) =
- case (class x, class y) of
- (NAN, _) => UNORDERED
- | (_, NAN) => UNORDERED
- | (ZERO, ZERO) => EQUAL
- | _ => if x < y then LESS
- else if x > y then GREATER
- else EQUAL
- end
-
- local
- structure I = IEEEReal
- structure G = General
- in
- fun compare (x, y) =
- case compareReal (x, y) of
- I.EQUAL => G.EQUAL
- | I.GREATER => G.GREATER
- | I.LESS => G.LESS
- | I.UNORDERED => raise IEEEReal.Unordered
- end
-
- fun unordered (x, y) = isNan x orelse isNan y
-
- val nextAfter: real * real -> real =
- fn (r, t) =>
- case (class r, class t) of
- (NAN, _) => nan
- | (_, NAN) => nan
- | (INF, _) => r
- | (ZERO, ZERO) => r
- | (ZERO, _) => if t > zero then minPos else ~minPos
- | _ =>
- if r == t
- then r
- else
- let
- fun doit (r, t) =
- if r == maxFinite andalso t == posInf
- then posInf
- else if r > t
- then R.nextAfter (r, negInf)
- else R.nextAfter (r, posInf)
- in
- if r > zero
- then doit (r, t)
- else ~ (doit (~r, ~t))
- end
-
- fun toManExp x =
- case class x of
- INF => {exp = 0, man = x}
- | NAN => {exp = 0, man = nan}
- | ZERO => {exp = 0, man = x}
- | _ =>
- let
- val r: C_Int.t ref = ref 0
- val man = R.frexp (x, r)
- in
- {exp = C_Int.toInt (!r), man = man}
- end
-
- fun fromManExp {exp, man} =
- (R.ldexp (man, C_Int.fromInt exp))
- handle Overflow =>
- man * (if Int.< (exp, 0) then zero else posInf)
-
- val fromManExp =
- if MLton.Codegen.isNative
- then fromManExp
- else
- fn {exp, man} =>
- case class man of
- INF => man
- | NAN => man
- | ZERO => man
- | _ => fromManExp {exp = exp, man = man}
-
- fun split x =
- case class x of
- INF => {frac = if x > zero then zero else ~zero,
- whole = x}
- | NAN => {frac = nan, whole = nan}
- | _ =>
- let
- val int = ref zero
- val frac = R.modf (x, int)
- val whole = !int
- (* Some platforms' C libraries don't get sign of
- * zero right.
- *)
- fun fix y =
- if class y = ZERO andalso not (sameSign (x, y))
- then ~ y
- else y
- in
- {frac = fix frac,
- whole = fix whole}
- end
-
- val realMod = #frac o split
-
- fun checkFloat x =
- case class x of
- INF => raise Overflow
- | NAN => raise Div
- | _ => x
-
- local
- fun 'a make {fromRealUnsafe: 'a -> real,
- toRealUnsafe: real -> 'a,
- other : {precision: Primitive.Int32.int}} =
- if R.precision = #precision other
- then (fromRealUnsafe,
- fn (m: rounding_mode) => fromRealUnsafe,
- toRealUnsafe,
- fn (m: rounding_mode) => toRealUnsafe)
- else (fromRealUnsafe,
- fn (m: rounding_mode) => fn r =>
- IEEEReal.withRoundingMode (m, fn () => fromRealUnsafe r),
- toRealUnsafe,
- fn (m: rounding_mode) => fn r =>
- IEEEReal.withRoundingMode (m, fn () => toRealUnsafe r))
- in
- val (fromReal32,fromReal32M,toReal32,toReal32M) =
- make {fromRealUnsafe = R.fromReal32Unsafe,
- toRealUnsafe = R.toReal32Unsafe,
- other = {precision = Primitive.Real32.precision}}
- val (fromReal64,fromReal64M,toReal64,toReal64M) =
- make {fromRealUnsafe = R.fromReal64Unsafe,
- toRealUnsafe = R.toReal64Unsafe,
- other = {precision = Primitive.Real64.precision}}
- end
- local
- structure S =
- LargeReal_ChooseRealN
- (type 'a t = real -> 'a
- val fReal32 = toReal32
- val fReal64 = toReal64)
- in
- val toLarge = S.f
- end
- local
- structure S =
- LargeReal_ChooseRealN
- (type 'a t = rounding_mode -> 'a -> real
- val fReal32 = fromReal32M
- val fReal64 = fromReal64M)
- in
- val fromLarge = S.f
- end
-
- fun roundReal (x: real, m: rounding_mode): real =
- IEEEReal.withRoundingMode (m, fn () => R.round x)
-
- local
- fun 'a make {fromIntUnsafe: 'a -> real,
- toIntUnsafe: real -> 'a,
- other : {maxInt': 'a,
- minInt': 'a}} =
- let
- val maxInt' = #maxInt' other
- val minInt' = #minInt' other
- val maxInt = fromIntUnsafe maxInt'
- val minInt = fromIntUnsafe minInt'
- in
- (fromIntUnsafe,
- fn (m: rounding_mode) => fn i =>
- IEEEReal.withRoundingMode (m, fn () => fromIntUnsafe i),
- toIntUnsafe,
- fn (m: rounding_mode) => fn x =>
- case class x of
- INF => raise Overflow
- | NAN => raise Domain
- | _ => if minInt <= x
- then if x <= maxInt
- then toIntUnsafe (roundReal (x, m))
- else if x < maxInt + one
- then (case m of
- TO_NEGINF => maxInt'
- | TO_POSINF => raise Overflow
- | TO_ZERO => maxInt'
- | TO_NEAREST =>
- (* Depends on maxInt being odd. *)
- if x - maxInt >= half
- then raise Overflow
- else maxInt')
- else raise Overflow
- else if x > minInt - one
- then (case m of
- TO_NEGINF => raise Overflow
- | TO_POSINF => minInt'
- | TO_ZERO => minInt'
- | TO_NEAREST =>
- (* Depends on minInt being even. *)
- if x - minInt < ~half
- then raise Overflow
- else minInt')
- else raise Overflow)
- end
- in
- val (fromInt8,fromInt8M,toInt8,toInt8M) =
- make {fromIntUnsafe = R.fromInt8Unsafe,
- toIntUnsafe = R.toInt8Unsafe,
- other = {maxInt' = Int8.maxInt',
- minInt' = Int8.minInt'}}
- val (fromInt16,fromInt16M,toInt16,toInt16M) =
- make {fromIntUnsafe = R.fromInt16Unsafe,
- toIntUnsafe = R.toInt16Unsafe,
- other = {maxInt' = Int16.maxInt',
- minInt' = Int16.minInt'}}
- val (fromInt32,fromInt32M,toInt32,toInt32M) =
- make {fromIntUnsafe = R.fromInt32Unsafe,
- toIntUnsafe = R.toInt32Unsafe,
- other = {maxInt' = Int32.maxInt',
- minInt' = Int32.minInt'}}
- val (fromInt64,fromInt64M,toInt64,toInt64M) =
- make {fromIntUnsafe = R.fromInt64Unsafe,
- toIntUnsafe = R.toInt64Unsafe,
- other = {maxInt' = Int64.maxInt',
- minInt' = Int64.minInt'}}
- end
-
-(*
- val floor = toInt TO_NEGINF
- val ceil = toInt TO_POSINF
- val trunc = toInt TO_ZERO
- val round = toInt TO_NEAREST
-
- local
- fun round mode x =
- case class x of
- INF => x
- | NAN => x
- | _ => roundReal (x, mode)
- in
- val realCeil = round TO_POSINF
- val realFloor = round TO_NEGINF
- val realRound = round TO_NEAREST
- val realTrunc = round TO_ZERO
- end
-
- fun rem (x, y) =
- case class x of
- INF => nan
- | NAN => nan
- | ZERO => zero
- | _ =>
- case class y of
- INF => x
- | NAN => nan
- | ZERO => nan
- | _ => x - realTrunc (x/y) * y
-
- (* fromDecimal, scan, fromString: decimal -> binary conversions *)
- exception Bad
- fun fromDecimal ({class, digits, exp, sign}: IEEEReal.decimal_approx) =
- let
- fun doit () =
- let
- val exp =
- if Int.< (exp, 0)
- then concat ["-", Int.toString (Int.~ exp)]
- else Int.toString exp
-(* val x = concat ["0.", digits, "E", exp, "\000"] *)
- val n =
- Int.+ (4, Int.+ (List.length digits, String.size exp))
- val a = Array.rawArray n
- fun up (i, c) = (Array.update (a, i, c); Int.+ (i, 1))
- val i = 0
- val i = up (i, #"0")
- val i = up (i, #".")
- val i =
- List.foldl
- (fn (d, i) =>
- if Int.< (d, 0) orelse Int.> (d, 9)
- then raise Bad
- else up (i, Char.chr (Int.+ (d, Char.ord #"0"))))
- i digits
- val i = up (i, #"E")
- val i = CharVector.foldl (fn (c, i) => up (i, c)) i exp
- val _ = up (i, #"\000")
- val x = Vector.fromArray a
- val x = Prim.strto (NullString.fromString x)
- in
- if sign
- then ~ x
- else x
- end
- in
- SOME (case class of
- INF => if sign then negInf else posInf
- | NAN => nan
- | NORMAL => doit ()
- | SUBNORMAL => doit ()
- | ZERO => if sign then ~ zero else zero)
- handle Bad => NONE
- end
-
- fun scan reader state =
- case IEEEReal.scan reader state of
- NONE => NONE
- | SOME (da, state) => SOME (valOf (fromDecimal da), state)
-
- val fromString = StringCvt.scanString scan
-
- (* toDecimal, fmt, toString: binary -> decimal conversions. *)
- datatype mode = Fix | Gen | Sci
- local
- val decpt: int ref = ref 0
- in
- fun gdtoa (x: real, mode: mode, ndig: int) =
- let
- val mode =
- case mode of
- Fix => 3
- | Gen => 0
- | Sci => 2
- val cs = Prim.gdtoa (x, mode, ndig, decpt)
- in
- (cs, !decpt)
- end
- end
-
- fun toDecimal (x: real): IEEEReal.decimal_approx =
- case class x of
- INF => {class = INF,
- digits = [],
- exp = 0,
- sign = x < zero}
- | NAN => {class = NAN,
- digits = [],
- exp = 0,
- sign = false}
- | ZERO => {class = ZERO,
- digits = [],
- exp = 0,
- sign = signBit x}
- | c =>
- let
- val (cs, exp) = gdtoa (x, Gen, 0)
- fun loop (i, ac) =
- if Int.< (i, 0)
- then ac
- else loop (Int.- (i, 1),
- (Int.- (Char.ord (COld.CS.sub (cs, i)),
- Char.ord #"0"))
- :: ac)
- val digits = loop (Int.- (COld.CS.length cs, 1), [])
- in
- {class = c,
- digits = digits,
- exp = exp,
- sign = x < zero}
- end
-
- datatype realfmt = datatype StringCvt.realfmt
-
- fun add1 n = Int.+ (n, 1)
-
- local
- fun fix (sign: string, cs: COld.CS.t, decpt: int, ndig: int): string =
- let
- val length = COld.CS.length cs
- in
- if Int.< (decpt, 0)
- then
- concat [sign,
- "0.",
- String.new (Int.~ decpt, #"0"),
- COld.CS.toString cs,
- String.new (Int.+ (Int.- (ndig, length),
- decpt),
- #"0")]
- else
- let
- val whole =
- if decpt = 0
- then "0"
- else
- String.tabulate (decpt, fn i =>
- if Int.< (i, length)
- then COld.CS.sub (cs, i)
- else #"0")
- in
- if 0 = ndig
- then concat [sign, whole]
- else
- let
- val frac =
- String.tabulate
- (ndig, fn i =>
- let
- val j = Int.+ (i, decpt)
- in
- if Int.< (j, length)
- then COld.CS.sub (cs, j)
- else #"0"
- end)
- in
- concat [sign, whole, ".", frac]
- end
- end
- end
- fun sci (x: real, ndig: int): string =
- let
- val sign = if x < zero then "~" else ""
- val (cs, decpt) = gdtoa (x, Sci, add1 ndig)
- val length = COld.CS.length cs
- val whole = String.tabulate (1, fn _ => COld.CS.sub (cs, 0))
- val frac =
- if 0 = ndig
- then ""
- else concat [".",
- String.tabulate
- (ndig, fn i =>
- let
- val j = Int.+ (i, 1)
- in
- if Int.< (j, length)
- then COld.CS.sub (cs, j)
- else #"0"
- end)]
- val exp = Int.- (decpt, 1)
- val exp =
- let
- val (exp, sign) =
- if Int.< (exp, 0)
- then (Int.~ exp, "~")
- else (exp, "")
- in
- concat [sign, Int.toString exp]
- end
- in
- concat [sign, whole, frac, "E", exp]
- end
- fun gen (x: real, n: int): string =
- case class x of
- INF => if x > zero then "inf" else "~inf"
- | NAN => "nan"
- | _ =>
- let
- val (prefix, x) =
- if x < zero
- then ("~", ~ x)
- else ("", x)
- val ss = Substring.full (sci (x, Int.- (n, 1)))
- fun isE c = c = #"E"
- fun isZero c = c = #"0"
- val expS =
- Substring.string (Substring.taker (not o isE) ss)
- val exp = valOf (Int.fromString expS)
- val man =
- String.translate
- (fn #"." => "" | c => str c)
- (Substring.string (Substring.dropr isZero
- (Substring.takel (not o isE) ss)))
- val manSize = String.size man
- fun zeros i = CharVector.tabulate (i, fn _ => #"0")
- fun dotAt i =
- concat [String.substring (man, 0, i),
- ".", String.extract (man, i, NONE)]
- fun sci () = concat [prefix,
- if manSize = 1 then man else dotAt 1,
- "E", expS]
- val op - = Int.-
- val op + = Int.+
- val ~ = Int.~
- val op >= = Int.>=
- in
- if exp >= (if manSize = 1 then 3 else manSize + 3)
- then sci ()
- else if exp >= manSize - 1
- then concat [prefix, man, zeros (exp - (manSize - 1))]
- else if exp >= 0
- then concat [prefix, dotAt (exp + 1)]
- else if exp >= (if manSize = 1 then ~2 else ~3)
- then concat [prefix, "0.", zeros (~exp - 1), man]
- else sci ()
- end
- in
- fun fmt spec =
- let
- val doit =
- case spec of
- EXACT => IEEEReal.toString o toDecimal
- | FIX opt =>
- let
- val n =
- case opt of
- NONE => 6
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 0)
- then raise Size
- else n
- in
- fn x =>
- let
- val sign = if x < zero then "~" else ""
- val (cs, decpt) = gdtoa (x, Fix, n)
- in
- fix (sign, cs, decpt, n)
- end
- end
- | GEN opt =>
- let
- val n =
- case opt of
- NONE => 12
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 1)
- then raise Size
- else n
- in
- fn x => gen (x, n)
- end
- | SCI opt =>
- let
- val n =
- case opt of
- NONE => 6
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 0)
- then raise Size
- else n
- in
- fn x => sci (x, n)
- end
- in
- fn x =>
- case class x of
- NAN => "nan"
- | INF => if x > zero then "inf" else "~inf"
- | _ => doit x
- end
- end
-
- val toString = fmt (StringCvt.GEN NONE)
-
- val fromLargeInt: LargeInt.int -> real =
- fn i =>
- fromInt (IntInf.toInt i)
- handle Overflow =>
- let
- val (i, sign) =
- if LargeInt.< (i, 0)
- then (LargeInt.~ i, true)
- else (i, false)
- val x = Prim.strto (NullString.fromString
- (concat [LargeInt.toString i, "\000"]))
- in
- if sign then ~ x else x
- end
-
- val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int =
- fn mode => fn x =>
- case class x of
- INF => raise Overflow
- | NAN => raise Domain
- | ZERO => 0
- | _ =>
- let
- (* This round may turn x into an INF, so we need to check the
- * class again.
- *)
- val x = roundReal (x, mode)
- in
- case class x of
- INF => raise Overflow
- | _ =>
- if minInt <= x andalso x <= maxInt
- then LargeInt.fromInt (Prim.toInt x)
- else
- valOf
- (LargeInt.fromString (fmt (StringCvt.FIX (SOME 0)) x))
- end
-
- structure Math =
- struct
- open Prim.Math
-
- (* Patch functions to handle out-of-range args. Many C math
- * libraries do not do what the SML Basis Spec requires.
- *)
-
- local
- fun patch f x =
- if x < ~one orelse x > one
- then nan
- else f x
- in
- val acos = patch acos
- val asin = patch asin
- end
-
- local
- fun patch f x = if x < zero then nan else f x
- in
- val ln = patch ln
- val log10 = patch log10
- end
-
- (* The x86 doesn't get exp right on infs. *)
- val exp =
- if MLton.Codegen.isNative
- andalso let open MLton.Platform.Arch in host = X86 end
- then (fn x =>
- case class x of
- INF => if x > zero then posInf else zero
- | _ => exp x)
- else exp
-
- (* The Cygwin math library doesn't get pow right on some exceptional
- * cases.
- *
- * The Linux math library doesn't get pow (x, y) right when x < 0
- * and y is large (but finite).
- *
- * So, we define a pow function that gives the correct result on
- * exceptional cases, and only calls the C pow with x > 0.
- *)
- fun isInt (x: real): bool = x == realFloor x
-
- (* isEven x assumes isInt x. *)
- fun isEven (x: real): bool = isInt (x / two)
-
- fun isOddInt x = isInt x andalso not (isEven x)
-
- fun isNeg x = x < zero
-
- fun pow (x, y) =
- case class y of
- INF =>
- if class x = NAN
- then nan
- else if x < negOne orelse x > one
- then if isNeg y then zero else posInf
- else if negOne < x andalso x < one
- then if isNeg y then posInf else zero
- else (* x = 1 orelse x = ~1 *)
- nan
- | NAN => nan
- | ZERO => one
- | _ =>
- (case class x of
- INF =>
- if isNeg x
- then if isNeg y
- then if isOddInt y
- then ~ zero
- else zero
- else if isOddInt y
- then negInf
- else posInf
- else (* x = posInf *)
- if isNeg y then zero else posInf
- | NAN => nan
- | ZERO =>
- if isNeg y
- then if isOddInt y
- then copySign (posInf, x)
- else posInf
- else if isOddInt y
- then x
- else zero
- | _ =>
- if isNeg x
- then if isInt y
- then if isEven y
- then Prim.Math.pow (~ x, y)
- else negOne * Prim.Math.pow (~ x, y)
- else nan
- else Prim.Math.pow (x, y))
-
- fun cosh x =
- case class x of
- INF => x
- | ZERO => one
- | _ => R.Math.cosh x
-
- fun sinh x =
- case class x of
- INF => x
- | ZERO => x
- | _ => R.Math.sinh x
-
- fun tanh x =
- case class x of
- INF => if x > zero then one else negOne
- | ZERO => x
- | _ => R.Math.tanh x
- end
-*)
- end
-
-structure Real32 = Real (Primitive.Real32)
-structure Real64 = Real (Primitive.Real64)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig 2006-04-25 02:41:19 UTC (rev 4408)
@@ -51,12 +51,8 @@
val modf: real * real ref -> real
val round: real -> real
-(*
- val gdtoa: real * int * int * int ref -> C_String.t
- val nextAfterDown: real -> real
- val nextAfterUp: real -> real
- val strto: NullString.t -> real
-*)
+ val gdtoa: real * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+ val strto: Primitive.NullString8.t -> real
val fromInt8Unsafe: Primitive.Int8.int -> real
val fromInt16Unsafe: Primitive.Int16.int -> real
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -0,0 +1,905 @@
+(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor Real (R: PRE_REAL): REAL =
+ struct
+ structure MLton = Primitive.MLton
+ structure Prim = R
+ local
+ open IEEEReal
+ in
+ datatype float_class = datatype float_class
+ datatype rounding_mode = datatype rounding_mode
+ end
+ infix 4 == != ?=
+ type real = R.real
+
+ local
+ open Prim
+ val isBytecode = MLton.Codegen.isBytecode
+ in
+ val *+ =
+ if isBytecode
+ then fn (r1, r2, r3) => r1 * r2 + r3
+ else *+
+ val *- =
+ if isBytecode
+ then fn (r1, r2, r3) => r1 * r2 - r3
+ else *-
+ val op * = op *
+ val op + = op +
+ val op - = op -
+ val op / = op /
+ val op / = op /
+ val op < = op <
+ val op <= = op <=
+ val op > = op >
+ val op >= = op >=
+ val ~ = ~
+ val abs = abs
+
+ val maxFinite = maxFinite
+ val minNormalPos = minNormalPos
+ val minPos = minPos
+
+ val precision = Primitive.Int32.toInt precision
+ val radix = Primitive.Int32.toInt radix
+
+ val signBit = fn r => signBit r <> 0
+ end
+
+ local
+ fun 'a make {fromRealUnsafe: 'a -> real,
+ toRealUnsafe: real -> 'a,
+ other : {precision: Primitive.Int32.int}} =
+ if R.precision = #precision other
+ then (fromRealUnsafe,
+ fn (m: rounding_mode) => fromRealUnsafe,
+ toRealUnsafe,
+ fn (m: rounding_mode) => toRealUnsafe)
+ else (fromRealUnsafe,
+ fn (m: rounding_mode) => fn r =>
+ IEEEReal.withRoundingMode (m, fn () => fromRealUnsafe r),
+ toRealUnsafe,
+ fn (m: rounding_mode) => fn r =>
+ IEEEReal.withRoundingMode (m, fn () => toRealUnsafe r))
+ in
+ val (fromReal32,fromReal32M,toReal32,toReal32M) =
+ make {fromRealUnsafe = R.fromReal32Unsafe,
+ toRealUnsafe = R.toReal32Unsafe,
+ other = {precision = Primitive.Real32.precision}}
+ val (fromReal64,fromReal64M,toReal64,toReal64M) =
+ make {fromRealUnsafe = R.fromReal64Unsafe,
+ toRealUnsafe = R.toReal64Unsafe,
+ other = {precision = Primitive.Real64.precision}}
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = real -> 'a
+ val fReal32 = toReal32
+ val fReal64 = toReal64)
+ in
+ val toLarge = S.f
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = rounding_mode -> 'a -> real
+ val fReal32 = fromReal32M
+ val fReal64 = fromReal64M)
+ in
+ val fromLarge = S.f
+ end
+
+ val zero = fromLarge TO_NEAREST 0.0
+ val one = fromLarge TO_NEAREST 1.0
+ val two = fromLarge TO_NEAREST 2.0
+
+ val half = one / two
+ val negOne = ~ one
+
+ val posInf = one / zero
+ val negInf = ~one / zero
+
+ val nan = posInf + negInf
+
+ local
+ val classes =
+ let
+ open R.Class
+ in
+ (* order here is chosen based on putting the more
+ * commonly used classes at the front.
+ *)
+ [(normal, NORMAL),
+ (zero, ZERO),
+ (inf, INF),
+ (nan, NAN),
+ (subnormal, SUBNORMAL)]
+ end
+ in
+ fun class x =
+ let
+ val i = R.class x
+ in
+ case List.find (fn (i', _) => i = i') classes of
+ NONE => raise Fail "Real_class returned bogus integer"
+ | SOME (_, c) => c
+ end
+ end
+
+ val abs =
+ if MLton.Codegen.isNative
+ then abs
+ else
+ fn x =>
+ case class x of
+ INF => posInf
+ | NAN => x
+ | _ => if signBit x then ~x else x
+
+ fun isFinite r =
+ case class r of
+ INF => false
+ | NAN => false
+ | _ => true
+
+ val op == = Prim.==
+
+ val op != = not o op ==
+
+ fun isNan r = r != r
+
+ fun isNormal r = class r = NORMAL
+
+ fun isNormal r = class r = NORMAL
+
+ val op ?= =
+ if MLton.Codegen.isNative
+ then R.?=
+ else
+ fn (x, y) =>
+ case (class x, class y) of
+ (NAN, _) => true
+ | (_, NAN) => true
+ | (ZERO, ZERO) => true
+ | _ => R.== (x, y)
+
+ fun min (x, y) =
+ if isNan x
+ then y
+ else if isNan y
+ then x
+ else if x < y then x else y
+
+ fun max (x, y) =
+ if isNan x
+ then y
+ else if isNan y
+ then x
+ else if x > y then x else y
+
+ fun sign (x: real): int =
+ case class x of
+ NAN => raise Domain
+ | ZERO => 0
+ | _ => if x > zero then 1 else ~1
+
+ fun sameSign (x, y) = signBit x = signBit y
+
+ fun copySign (x, y) =
+ if sameSign (x, y)
+ then x
+ else ~ x
+
+ local
+ datatype z = datatype IEEEReal.real_order
+ in
+ fun compareReal (x, y) =
+ case (class x, class y) of
+ (NAN, _) => UNORDERED
+ | (_, NAN) => UNORDERED
+ | (ZERO, ZERO) => EQUAL
+ | _ => if x < y then LESS
+ else if x > y then GREATER
+ else EQUAL
+ end
+
+ local
+ structure I = IEEEReal
+ structure G = General
+ in
+ fun compare (x, y) =
+ case compareReal (x, y) of
+ I.EQUAL => G.EQUAL
+ | I.GREATER => G.GREATER
+ | I.LESS => G.LESS
+ | I.UNORDERED => raise IEEEReal.Unordered
+ end
+
+ fun unordered (x, y) = isNan x orelse isNan y
+
+ val nextAfter: real * real -> real =
+ fn (r, t) =>
+ case (class r, class t) of
+ (NAN, _) => nan
+ | (_, NAN) => nan
+ | (INF, _) => r
+ | (ZERO, ZERO) => r
+ | (ZERO, _) => if t > zero then minPos else ~minPos
+ | _ =>
+ if r == t
+ then r
+ else
+ let
+ fun doit (r, t) =
+ if r == maxFinite andalso t == posInf
+ then posInf
+ else if r > t
+ then R.nextAfter (r, negInf)
+ else R.nextAfter (r, posInf)
+ in
+ if r > zero
+ then doit (r, t)
+ else ~ (doit (~r, ~t))
+ end
+
+ fun toManExp x =
+ case class x of
+ INF => {exp = 0, man = x}
+ | NAN => {exp = 0, man = nan}
+ | ZERO => {exp = 0, man = x}
+ | _ =>
+ let
+ val r: C_Int.t ref = ref 0
+ val man = R.frexp (x, r)
+ in
+ {exp = C_Int.toInt (!r), man = man}
+ end
+
+ fun fromManExp {exp, man} =
+ (R.ldexp (man, C_Int.fromInt exp))
+ handle Overflow =>
+ man * (if Int.< (exp, 0) then zero else posInf)
+
+ val fromManExp =
+ if MLton.Codegen.isNative
+ then fromManExp
+ else
+ fn {exp, man} =>
+ case class man of
+ INF => man
+ | NAN => man
+ | ZERO => man
+ | _ => fromManExp {exp = exp, man = man}
+
+ local
+ val oneInt = One.make (fn () => ref zero)
+ in
+ fun split x =
+ case class x of
+ INF => {frac = if x > zero then zero else ~zero,
+ whole = x}
+ | NAN => {frac = nan, whole = nan}
+ | _ =>
+ One.use
+ (oneInt, fn int =>
+ let
+ val frac = R.modf (x, int)
+ val whole = !int
+ (* Some platforms' C libraries don't get sign of
+ * zero right.
+ *)
+ fun fix y =
+ if class y = ZERO andalso not (sameSign (x, y))
+ then ~ y
+ else y
+ in
+ {frac = fix frac,
+ whole = fix whole}
+ end)
+ end
+
+ val realMod = #frac o split
+
+ fun checkFloat x =
+ case class x of
+ INF => raise Overflow
+ | NAN => raise Div
+ | _ => x
+
+ fun roundReal (x: real, m: rounding_mode): real =
+ IEEEReal.withRoundingMode (m, fn () => R.round x)
+
+ local
+ fun round mode x =
+ case class x of
+ INF => x
+ | NAN => x
+ | _ => roundReal (x, mode)
+ in
+ val realCeil = round TO_POSINF
+ val realFloor = round TO_NEGINF
+ val realRound = round TO_NEAREST
+ val realTrunc = round TO_ZERO
+ end
+
+ fun rem (x, y) =
+ (case class x of
+ INF => nan
+ | NAN => nan
+ | ZERO => zero
+ | _ => (case class y of
+ INF => x
+ | NAN => nan
+ | ZERO => nan
+ | _ => x - realTrunc (x/y) * y))
+
+ (* fromDecimal, scan, fromString: decimal -> binary conversions *)
+ exception Bad
+ fun fromDecimal ({class, digits, exp, sign}: IEEEReal.decimal_approx) =
+ let
+ fun doit () =
+ let
+ val exp =
+ if Int.< (exp, 0)
+ then concat ["-", Int.toString (Int.~ exp)]
+ else Int.toString exp
+(* val x = concat ["0.", digits, "E", exp, "\000"] *)
+ val n = Int.+ (4, Int.+ (List.length digits, String.size exp))
+ val a = Array.arrayUninit n
+ fun upd (i, c) = (Array.update (a, i, c); Int.+ (i, 1))
+ val i = 0
+ val i = upd (i, #"0")
+ val i = upd (i, #".")
+ val i =
+ List.foldl
+ (fn (d, i) =>
+ if Int.< (d, 0) orelse Int.> (d, 9)
+ then raise Bad
+ else upd (i, Char.chr (Int.+ (d, Char.ord #"0"))))
+ i digits
+ val i = upd (i, #"E")
+ val i = CharVector.foldl (fn (c, i) => upd (i, c)) i exp
+ val _ = upd (i, #"\000")
+ val x = Vector.fromArray a
+ val x = Prim.strto (NullString.fromString x)
+ in
+ if sign
+ then ~ x
+ else x
+ end
+ in
+ SOME (case class of
+ INF => if sign then negInf else posInf
+ | NAN => nan
+ | NORMAL => doit ()
+ | SUBNORMAL => doit ()
+ | ZERO => if sign then ~ zero else zero)
+ handle Bad => NONE
+ end
+
+ fun scan reader state =
+ case IEEEReal.scan reader state of
+ NONE => NONE
+ | SOME (da, state) => SOME (valOf (fromDecimal da), state)
+
+ val fromString = StringCvt.scanString scan
+
+ (* toDecimal, fmt, toString: binary -> decimal conversions. *)
+ datatype mode = Fix | Gen | Sci
+ local
+ val decpt: C_Int.int ref = ref 0
+ in
+ fun gdtoa (x: real, mode: mode, ndig: int) =
+ let
+ val mode : C_Int.int =
+ case mode of
+ Fix => 3
+ | Gen => 0
+ | Sci => 2
+ val cs = Prim.gdtoa (x, mode, C_Int.fromInt ndig, decpt)
+ in
+ (cs, C_Int.toInt (!decpt))
+ end
+ end
+
+ fun toDecimal (x: real): IEEEReal.decimal_approx =
+ case class x of
+ INF => {class = INF,
+ digits = [],
+ exp = 0,
+ sign = x < zero}
+ | NAN => {class = NAN,
+ digits = [],
+ exp = 0,
+ sign = false}
+ | ZERO => {class = ZERO,
+ digits = [],
+ exp = 0,
+ sign = signBit x}
+ | c =>
+ let
+ val (cs, exp) = gdtoa (x, Gen, 0)
+ fun loop (i, ac) =
+ if Int.< (i, 0)
+ then ac
+ else loop (Int.- (i, 1),
+ (Int.- (Char.ord (CUtil.C_String.sub (cs, i)),
+ Char.ord #"0"))
+ :: ac)
+ val digits = loop (Int.- (CUtil.C_String.length cs, 1), [])
+ in
+ {class = c,
+ digits = digits,
+ exp = exp,
+ sign = x < zero}
+ end
+
+ datatype realfmt = datatype StringCvt.realfmt
+
+ local
+ fun fix (sign: string, cs: CUtil.C_String.t, decpt: int, ndig: int): string =
+ let
+ val length = CUtil.C_String.length cs
+ in
+ if Int.< (decpt, 0)
+ then
+ concat [sign,
+ "0.",
+ String.new (Int.~ decpt, #"0"),
+ CUtil.C_String.toString cs,
+ String.new (Int.+ (Int.- (ndig, length),
+ decpt),
+ #"0")]
+ else
+ let
+ val whole =
+ if decpt = 0
+ then "0"
+ else
+ String.tabulate (decpt, fn i =>
+ if Int.< (i, length)
+ then CUtil.C_String.sub (cs, i)
+ else #"0")
+ in
+ if 0 = ndig
+ then concat [sign, whole]
+ else
+ let
+ val frac =
+ String.tabulate
+ (ndig, fn i =>
+ let
+ val j = Int.+ (i, decpt)
+ in
+ if Int.< (j, length)
+ then CUtil.C_String.sub (cs, j)
+ else #"0"
+ end)
+ in
+ concat [sign, whole, ".", frac]
+ end
+ end
+ end
+ fun sci (x: real, ndig: int): string =
+ let
+ val sign = if x < zero then "~" else ""
+ val (cs, decpt) = gdtoa (x, Sci, Int.+ (1, ndig))
+ val length = CUtil.C_String.length cs
+ val whole = String.tabulate (1, fn _ => CUtil.C_String.sub (cs, 0))
+ val frac =
+ if 0 = ndig
+ then ""
+ else concat [".",
+ String.tabulate
+ (ndig, fn i =>
+ let
+ val j = Int.+ (i, 1)
+ in
+ if Int.< (j, length)
+ then CUtil.C_String.sub (cs, j)
+ else #"0"
+ end)]
+ val exp = Int.- (decpt, 1)
+ val exp =
+ let
+ val (exp, sign) =
+ if Int.< (exp, 0)
+ then (Int.~ exp, "~")
+ else (exp, "")
+ in
+ concat [sign, Int.toString exp]
+ end
+ in
+ concat [sign, whole, frac, "E", exp]
+ end
+ fun gen (x: real, n: int): string =
+ case class x of
+ INF => if x > zero then "inf" else "~inf"
+ | NAN => "nan"
+ | _ =>
+ let
+ val (prefix, x) =
+ if x < zero
+ then ("~", ~ x)
+ else ("", x)
+ val ss = Substring.full (sci (x, Int.- (n, 1)))
+ fun isE c = c = #"E"
+ fun isZero c = c = #"0"
+ val expS =
+ Substring.string (Substring.taker (not o isE) ss)
+ val exp = valOf (Int.fromString expS)
+ val man =
+ String.translate
+ (fn #"." => "" | c => str c)
+ (Substring.string (Substring.dropr isZero
+ (Substring.takel (not o isE) ss)))
+ val manSize = String.size man
+ fun zeros i = CharVector.tabulate (i, fn _ => #"0")
+ fun dotAt i =
+ concat [String.substring (man, 0, i),
+ ".", String.extract (man, i, NONE)]
+ fun sci () = concat [prefix,
+ if manSize = 1 then man else dotAt 1,
+ "E", expS]
+ val op - = Int.-
+ val op + = Int.+
+ val ~ = Int.~
+ val op >= = Int.>=
+ in
+ if exp >= (if manSize = 1 then 3 else manSize + 3)
+ then sci ()
+ else if exp >= manSize - 1
+ then concat [prefix, man, zeros (exp - (manSize - 1))]
+ else if exp >= 0
+ then concat [prefix, dotAt (exp + 1)]
+ else if exp >= (if manSize = 1 then ~2 else ~3)
+ then concat [prefix, "0.", zeros (~exp - 1), man]
+ else sci ()
+ end
+ in
+ fun fmt spec =
+ let
+ val doit =
+ case spec of
+ EXACT => IEEEReal.toString o toDecimal
+ | FIX opt =>
+ let
+ val n =
+ case opt of
+ NONE => 6
+ | SOME n =>
+ if Primitive.Controls.safe andalso Int.< (n, 0)
+ then raise Size
+ else n
+ in
+ fn x =>
+ let
+ val sign = if x < zero then "~" else ""
+ val (cs, decpt) = gdtoa (x, Fix, n)
+ in
+ fix (sign, cs, decpt, n)
+ end
+ end
+ | GEN opt =>
+ let
+ val n =
+ case opt of
+ NONE => 12
+ | SOME n =>
+ if Primitive.Controls.safe andalso Int.< (n, 1)
+ then raise Size
+ else n
+ in
+ fn x => gen (x, n)
+ end
+ | SCI opt =>
+ let
+ val n =
+ case opt of
+ NONE => 6
+ | SOME n =>
+ if Primitive.Controls.safe andalso Int.< (n, 0)
+ then raise Size
+ else n
+ in
+ fn x => sci (x, n)
+ end
+ in
+ fn x =>
+ case class x of
+ NAN => "nan"
+ | INF => if x > zero then "inf" else "~inf"
+ | _ => doit x
+ end
+ end
+
+ val toString = fmt (StringCvt.GEN NONE)
+
+ local
+ fun 'a make {fromIntUnsafe: 'a -> real,
+ toIntUnsafe: real -> 'a,
+ other : {maxInt': 'a,
+ minInt': 'a}} =
+ let
+ val maxInt' = #maxInt' other
+ val minInt' = #minInt' other
+ val maxInt = fromIntUnsafe maxInt'
+ val minInt = fromIntUnsafe minInt'
+ in
+ (fromIntUnsafe,
+ fn (m: rounding_mode) => fn i =>
+ IEEEReal.withRoundingMode (m, fn () => fromIntUnsafe i),
+ toIntUnsafe,
+ fn (m: rounding_mode) => fn x =>
+ case class x of
+ INF => raise Overflow
+ | NAN => raise Domain
+ | _ => if minInt <= x
+ then if x <= maxInt
+ then toIntUnsafe (roundReal (x, m))
+ else if x < maxInt + one
+ then (case m of
+ TO_NEGINF => maxInt'
+ | TO_POSINF => raise Overflow
+ | TO_ZERO => maxInt'
+ | TO_NEAREST =>
+ (* Depends on maxInt being odd. *)
+ if x - maxInt >= half
+ then raise Overflow
+ else maxInt')
+ else raise Overflow
+ else if x > minInt - one
+ then (case m of
+ TO_NEGINF => raise Overflow
+ | TO_POSINF => minInt'
+ | TO_ZERO => minInt'
+ | TO_NEAREST =>
+ (* Depends on minInt being even. *)
+ if x - minInt < ~half
+ then raise Overflow
+ else minInt')
+ else raise Overflow)
+ end
+ in
+ val (fromInt8,fromInt8M,toInt8,toInt8M) =
+ make {fromIntUnsafe = R.fromInt8Unsafe,
+ toIntUnsafe = R.toInt8Unsafe,
+ other = {maxInt' = Int8.maxInt',
+ minInt' = Int8.minInt'}}
+ val (fromInt16,fromInt16M,toInt16,toInt16M) =
+ make {fromIntUnsafe = R.fromInt16Unsafe,
+ toIntUnsafe = R.toInt16Unsafe,
+ other = {maxInt' = Int16.maxInt',
+ minInt' = Int16.minInt'}}
+ val (fromInt32,fromInt32M,toInt32,toInt32M) =
+ make {fromIntUnsafe = R.fromInt32Unsafe,
+ toIntUnsafe = R.toInt32Unsafe,
+ other = {maxInt' = Int32.maxInt',
+ minInt' = Int32.minInt'}}
+ val (fromInt64,fromInt64M,toInt64,toInt64M) =
+ make {fromIntUnsafe = R.fromInt64Unsafe,
+ toIntUnsafe = R.toInt64Unsafe,
+ other = {maxInt' = Int64.maxInt',
+ minInt' = Int64.minInt'}}
+ end
+
+ val fromIntInf: IntInf.int -> real =
+ fn i =>
+(*
+ fromInt (IntInf.toInt i)
+ handle Overflow =>
+*)
+ let
+ val (i, sign) =
+ if IntInf.< (i, 0)
+ then (IntInf.~ i, true)
+ else (i, false)
+ val x = Prim.strto (NullString.nullTerm (IntInf.toString i))
+ in
+ if sign then ~ x else x
+ end
+
+ val toIntInfM: rounding_mode -> real -> LargeInt.int =
+ fn mode => fn x =>
+ case class x of
+ INF => raise Overflow
+ | NAN => raise Domain
+ | ZERO => 0
+ | _ =>
+ let
+ (* This round may turn x into an INF, so we need to check the
+ * class again.
+ *)
+ val x = roundReal (x, mode)
+ in
+ case class x of
+ INF => raise Overflow
+ | _ =>
+(*
+ if minInt <= x andalso x <= maxInt
+ then IntInf.fromInt (Prim.toInt x)
+ else
+*)
+ valOf (IntInf.fromString (fmt (StringCvt.FIX (SOME 0)) x))
+ end
+
+ local
+ structure S =
+ Int_ChooseInt
+ (type 'a t = 'a -> real
+ val fInt8 = fromInt8
+ val fInt16 = fromInt16
+ val fInt32 = fromInt32
+ val fInt64 = fromInt64
+ val fIntInf = fromIntInf)
+ in
+ val fromInt = S.f
+ end
+ local
+ structure S =
+ LargeInt_ChooseInt
+ (type 'a t = 'a -> real
+ val fInt8 = fromInt8
+ val fInt16 = fromInt16
+ val fInt32 = fromInt32
+ val fInt64 = fromInt64
+ val fIntInf = fromIntInf)
+ in
+ val fromLargeInt = S.f
+ end
+ local
+ structure S =
+ Int_ChooseInt
+ (type 'a t = rounding_mode -> real -> 'a
+ val fInt8 = toInt8M
+ val fInt16 = toInt16M
+ val fInt32 = toInt32M
+ val fInt64 = toInt64M
+ val fIntInf = toIntInfM)
+ in
+ val toInt = S.f
+ end
+ local
+ structure S =
+ LargeInt_ChooseInt
+ (type 'a t = rounding_mode -> real -> 'a
+ val fInt8 = toInt8M
+ val fInt16 = toInt16M
+ val fInt32 = toInt32M
+ val fInt64 = toInt64M
+ val fIntInf = toIntInfM)
+ in
+ val toLargeInt = S.f
+ end
+
+ val floor = toInt TO_NEGINF
+ val ceil = toInt TO_POSINF
+ val trunc = toInt TO_ZERO
+ val round = toInt TO_NEAREST
+
+ structure Math =
+ struct
+ open Prim.Math
+
+ (* Patch functions to handle out-of-range args. Many C math
+ * libraries do not do what the SML Basis Spec requires.
+ *)
+
+ local
+ fun patch f x =
+ if x < ~one orelse x > one
+ then nan
+ else f x
+ in
+ val acos = patch acos
+ val asin = patch asin
+ end
+
+ local
+ fun patch f x = if x < zero then nan else f x
+ in
+ val ln = patch ln
+ val log10 = patch log10
+ end
+
+ (* The x86 doesn't get exp right on infs. *)
+ val exp =
+ if MLton.Codegen.isNative
+ andalso let open MLton.Platform.Arch in host = X86 end
+ then (fn x =>
+ case class x of
+ INF => if x > zero then posInf else zero
+ | _ => exp x)
+ else exp
+
+ (* The Cygwin math library doesn't get pow right on some exceptional
+ * cases.
+ *
+ * The Linux math library doesn't get pow (x, y) right when x < 0
+ * and y is large (but finite).
+ *
+ * So, we define a pow function that gives the correct result on
+ * exceptional cases, and only calls the C pow with x > 0.
+ *)
+ fun isInt (x: real): bool = x == realFloor x
+
+ (* isEven x assumes isInt x. *)
+ fun isEven (x: real): bool = isInt (x / two)
+
+ fun isOddInt x = isInt x andalso not (isEven x)
+
+ fun isNeg x = x < zero
+
+ fun pow (x, y) =
+ case class y of
+ INF =>
+ if class x = NAN
+ then nan
+ else if x < negOne orelse x > one
+ then if isNeg y then zero else posInf
+ else if negOne < x andalso x < one
+ then if isNeg y then posInf else zero
+ else (* x = 1 orelse x = ~1 *)
+ nan
+ | NAN => nan
+ | ZERO => one
+ | _ =>
+ (case class x of
+ INF =>
+ if isNeg x
+ then if isNeg y
+ then if isOddInt y
+ then ~ zero
+ else zero
+ else if isOddInt y
+ then negInf
+ else posInf
+ else (* x = posInf *)
+ if isNeg y then zero else posInf
+ | NAN => nan
+ | ZERO =>
+ if isNeg y
+ then if isOddInt y
+ then copySign (posInf, x)
+ else posInf
+ else if isOddInt y
+ then x
+ else zero
+ | _ =>
+ if isNeg x
+ then if isInt y
+ then if isEven y
+ then Prim.Math.pow (~ x, y)
+ else negOne * Prim.Math.pow (~ x, y)
+ else nan
+ else Prim.Math.pow (x, y))
+
+ fun cosh x =
+ case class x of
+ INF => x
+ | ZERO => one
+ | _ => R.Math.cosh x
+
+ fun sinh x =
+ case class x of
+ INF => x
+ | ZERO => x
+ | _ => R.Math.sinh x
+
+ fun tanh x =
+ case class x of
+ INF => if x > zero then one else negOne
+ | ZERO => x
+ | _ => R.Math.tanh x
+ end
+ end
+
+structure Real32 = Real (Primitive.Real32)
+structure Real64 = Real (Primitive.Real64)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,16 +0,0 @@
-(* Copyright (C) 1999-2006 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 REAL0 =
- sig
- include PRIM_REAL
-
- val zero: real
- val one: real
-
- end
\ No newline at end of file
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real32.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real32.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real32.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,33 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure Real32 =
- Real
- (structure P = Primitive.Real32
- open P
- fun fromLarge m r =
- IEEEReal.withRoundingMode (m, fn () => P.fromLarge r)
-
- val realToWord: real -> word =
- fn r =>
- Word.fromLarge (PackWord32Little.subVec (PackReal32Little.toBytes r, 0))
-
- val wordToReal: word -> real =
- let
- val a = Word8Array.array (4, 0w0)
- in
- fn w =>
- let
- val _ = PackWord32Little.update (a, 0, Word.toLarge w)
- in
- PackReal32Little.subArr (a, 0)
- end
- end
-
- fun nextAfterUp r = wordToReal (Word.+ (realToWord r, 0w1))
- fun nextAfterDown r = wordToReal (Word.- (realToWord r, 0w1))
- )
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real64.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real64.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real64.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,22 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure Real64 =
- Real
- (structure P = Primitive.Real64
- open P
- fun fromLarge _ r = P.fromLarge r
- val negInf = ~1.0 / 0.0
- val posInf = 1.0 / 0.0
- fun nextAfterDown r = nextAfter (r, negInf)
- fun nextAfterUp r = nextAfter (r, posInf)
- )
-structure Real = Real64
-val real = Real.fromInt
-structure RealGlobal: REAL_GLOBAL = Real
-open RealGlobal
-structure LargeReal = Real64
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/Makefile 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/Makefile 2006-04-25 02:41:19 UTC (rev 4408)
@@ -39,6 +39,7 @@
-mlb-path-map "../maps/default-int32.map" \
-mlb-path-map "../maps/default-real64.map" \
-mlb-path-map "../maps/default-word32.map" \
+ -codegen c \
-const 'Exn.keepHistory true' \
-profile-include '<basis>' \
-profile-branch true \
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -67,6 +67,20 @@
printString s
; printString "\n"
end
+fun printReal32 r =
+ let
+ val s = Real32.fmt StringCvt.EXACT r
+ in
+ printString s
+ ; printString "\n"
+ end
+fun printReal64 r =
+ let
+ val s = Real64.fmt StringCvt.EXACT r
+ in
+ printString s
+ ; printString "\n"
+ end
@@ -472,3 +486,11 @@
val _ = (printString "Word64.fromLargeInt (Int64.toLarge Int64.maxInt') = \n"
; printWord64 (Word64.fromLargeInt (Int64.toLarge Int64.maxInt')))
+val _ = (printString "Real32.fromInt 1 = \n"
+ ; printReal32 (Real32.fromInt 1))
+val _ = (printString "Real64.fromInt 1 = \n"
+ ; printReal64 (Real64.fromInt 1))
+val _ = (printString "Real32.fromLarge 0.9 = \n"
+ ; printReal32 (Real32.fromLarge IEEEReal.TO_NEAREST 0.9))
+val _ = (printString "Real64.fromLarge 0.9 = \n"
+ ; printReal64 (Real64.fromLarge IEEEReal.TO_NEAREST 0.9))
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sig (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/C.sig)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/C.sig 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sig 2006-04-25 02:41:19 UTC (rev 4408)
@@ -0,0 +1,37 @@
+(* Copyright (C) 1999-2005 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 C_UTIL =
+ sig
+ (* C char* *)
+ structure C_String :
+ sig
+ type t = C_String.t
+
+ (* string must be null terminated *)
+ val length: t -> int
+ val sub: t * int -> char
+ val toCharArrayOfLength: t * int -> char array
+ (* string must be null terminated *)
+ val toString: t -> string
+ (* extract first n characters of string *)
+ val toStringOfLength: t * int -> string
+ val update: t * int * char -> unit
+ end
+
+ (* NULL terminated char** *)
+ structure C_StringArray :
+ sig
+ type t = C_StringArray.t
+
+ val fromList: string list -> NullString.t array
+ (* extract first n strings from array *)
+ val toArrayOfLength: t * int -> string array
+ val toList: t -> string list
+ end
+ end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/C.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/C.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -0,0 +1,92 @@
+(* Copyright (C) 1999-2005 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.
+ *)
+
+structure CUtil: C_UTIL =
+ struct
+ open Int
+
+ fun makeLength (sub, term) p =
+ let
+ fun loop i =
+ if term (sub (p, i))
+ then i
+ else loop (i +? 1)
+ in loop 0
+ end
+
+ fun toArrayOfLength (s: 'a,
+ sub: 'a * int -> 'b,
+ n: int) : 'b array =
+ let
+ val a = Array.arrayUninit n
+ fun loop i =
+ if i >= n
+ then ()
+ else (Array.update (a, i, sub (s, i))
+ ; loop (i + 1))
+ val () = loop 0
+ in
+ a
+ end
+
+ structure C_String =
+ struct
+ type t = C_String.t
+
+ fun sub (cs, i) =
+ Primitive.Char8.fromWord8Unsafe
+ (Primitive.MLton.Pointer.getWord8 (cs, C_Ptrdiff.fromInt i))
+
+ fun update (cs, i, c) =
+ Primitive.MLton.Pointer.setWord8
+ (cs, C_Ptrdiff.fromInt i, Primitive.Char8.toWord8Unsafe c)
+
+ fun toCharArrayOfLength (cs, n) = toArrayOfLength (cs, sub, n)
+
+ fun toStringOfLength cs =
+ String.fromArray (CharArray.fromPoly (toCharArrayOfLength cs))
+
+ val length = makeLength (sub, fn #"\000" => true | _ => false)
+
+ fun toString cs = toStringOfLength (cs, length cs)
+ end
+
+ structure C_StringArray =
+ struct
+ type t = C_StringArray.t
+
+ fun sub (css: t, i) =
+ Primitive.MLton.Pointer.getPointer (css, C_Ptrdiff.fromInt i)
+
+ val length = makeLength (sub, Primitive.MLton.Pointer.isNull)
+
+ val toArrayOfLength =
+ fn (css, n) => toArrayOfLength (css, C_String.toString o sub, n)
+
+ fun toArray css = toArrayOfLength (css, length css)
+
+ val toList = Array.toList o toArray
+
+ (* The C side converts the last element of the array, "",
+ * to the null terminator that C primitives expect.
+ * As far as C can tell, the other elements of the array
+ * are just char*'s.
+ *)
+ fun fromList l =
+ let
+ val a = Array.array (1 +? List.length l, NullString.empty)
+ val _ =
+ List.foldl (fn (s, i) =>
+ (Array.update (a, i, NullString.nullTerm s)
+ ; i +? 1))
+ 0 l
+ in
+ a
+ end
+ end
+ end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/dynamic-wind.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/dynamic-wind.sig 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/dynamic-wind.sig 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,3 +1,11 @@
+(* Copyright (C) 1999-2005 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 DYNAMIC_WIND =
sig
val wind: (unit -> 'a) * (unit -> unit) -> 'a