[MLton-devel] cvs commit: Int64 is there
Stephen Weeks
sweeks@users.sourceforge.net
Wed, 25 Jun 2003 20:28:20 -0700
sweeks 03/06/25 20:28:20
Modified: basis-library/integer int-inf.sig int-inf.sml integer.fun
patch.sml
basis-library/libs build
basis-library/libs/basis-2002/top-level basis.sig basis.sml
basis-library/misc primitive.sml
include c-chunk.h
regression fixed-integer.ok fixed-integer.sml
runtime Makefile
Added: basis-library/arrays-and-vectors mono.sml
basis-library/integer int64.sml
runtime/basis/Int Int64.c
Removed: basis-library/arrays-and-vectors mono-array.sml
mono-array2.sml mono-vector.sml
Log:
A very simple implementation of Int64, using only _ffi. It works with
the C codegen. The only support needed from the x86 codegen is FFI of
Int64.int.
The implementation is probably slow, especially for
Int64.{{from,to}Large,*}, but is at least correct I hope. Henry, if
you feel like poking around and speeding stuff up, that would be
great.
Over time we can implement Int64 primitives, eliminating stuff from
runtime/basis/Int/Int64.c and puting the primitive in c-chunk.h and
the x86 codegen.
Combined all the monomorphic basis library Arrays, Vectors, etc. into
one file.
Revision Changes Path
1.1 mlton/basis-library/arrays-and-vectors/mono.sml
Index: mono.sml
===================================================================
(* Copyright (C) 1999-2003 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor EqMono (eqtype elem) =
struct
structure Vector = EqtypeMonoVector (type elem = elem)
structure VectorSlice = Vector.MonoVectorSlice
structure Array = MonoArray (type elem = elem
structure V = Vector)
structure ArraySlice = Array.MonoArraySlice
structure Array2 = MonoArray2 (type elem = elem
structure V = Vector)
end
functor Mono (type elem) =
struct
structure Vector = MonoVector (type elem = elem)
structure VectorSlice = Vector.MonoVectorSlice
structure Array = MonoArray (type elem = elem
structure V = Vector)
structure ArraySlice = Array.MonoArraySlice
structure Array2 = MonoArray2 (type elem = elem
structure V = Vector)
end
local
structure S = EqMono (type elem = Bool.bool)
open S
in
structure BoolVector = Vector
structure BoolVectorSlice = VectorSlice
structure BoolArray = Array
structure BoolArraySlice = ArraySlice
structure BoolArray2 = Array2
end
local
structure S = EqMono (type elem = Char.char)
open S
in
structure CharVector = Vector
structure CharVectorSlice = VectorSlice
structure CharArray = Array
structure CharArraySlice = ArraySlice
structure CharArray2 = Array2
end
local
structure S = EqMono (type elem = Int8.int)
open S
in
structure Int8Vector = Vector
structure Int8VectorSlice = VectorSlice
structure Int8Array = Array
structure Int8ArraySlice = ArraySlice
structure Int8Array2 = Array2
end
local
structure S = EqMono (type elem = Int16.int)
open S
in
structure Int16Vector = Vector
structure Int16VectorSlice = VectorSlice
structure Int16Array = Array
structure Int16ArraySlice = ArraySlice
structure Int16Array2 = Array2
end
local
structure S = EqMono (type elem = Int32.int)
open S
in
structure Int32Vector = Vector
structure Int32VectorSlice = VectorSlice
structure Int32Array = Array
structure Int32ArraySlice = ArraySlice
structure Int32Array2 = Array2
end
local
structure S = EqMono (type elem = Int64.int)
open S
in
structure Int64Vector = Vector
structure Int64VectorSlice = VectorSlice
structure Int64Array = Array
structure Int64ArraySlice = ArraySlice
structure Int64Array2 = Array2
end
local
structure S = Mono (type elem = Real32.real)
open S
in
structure Real32Vector = Vector
structure Real32VectorSlice = VectorSlice
structure Real32Array = Array
structure Real32ArraySlice = ArraySlice
structure Real32Array2 = Array2
end
local
structure S = Mono (type elem = Real64.real)
open S
in
structure Real64Vector = Vector
structure Real64VectorSlice = VectorSlice
structure Real64Array = Array
structure Real64ArraySlice = ArraySlice
structure Real64Array2 = Array2
end
local
structure S = EqMono (type elem = Word8.word)
open S
in
structure Word8Vector = Vector
structure Word8VectorSlice = VectorSlice
structure Word8Array = Array
structure Word8ArraySlice = ArraySlice
structure Word8Array2 = Array2
end
local
structure S = EqMono (type elem = Word16.word)
open S
in
structure Word16Vector = Vector
structure Word16VectorSlice = VectorSlice
structure Word16Array = Array
structure Word16ArraySlice = ArraySlice
structure Word16Array2 = Array2
end
local
structure S = EqMono (type elem = Word32.word)
open S
in
structure Word32Vector = Vector
structure Word32VectorSlice = VectorSlice
structure Word32Array = Array
structure Word32ArraySlice = ArraySlice
structure Word32Array2 = Array2
end
1.8 +2 -0 mlton/basis-library/integer/int-inf.sig
Index: int-inf.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/int-inf.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- int-inf.sig 24 Nov 2002 01:19:35 -0000 1.7
+++ int-inf.sig 26 Jun 2003 03:28:19 -0000 1.8
@@ -20,6 +20,7 @@
val areSmall: int * int -> bool
val bigIntConstant: Int.int -> int
+ val fromInt64: Int64.int -> int
val gcd: int * int -> int
val isSmall: int -> bool
datatype rep =
@@ -27,4 +28,5 @@
| Big of Word.word Vector.vector
val rep: int -> rep
val size: int -> Int.int
+ val toInt64: int -> Int64.int
end
1.13 +70 -1 mlton/basis-library/integer/int-inf.sml
Index: int-inf.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/int-inf.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- int-inf.sml 25 Jun 2003 20:44:43 -0000 1.12
+++ int-inf.sml 26 Jun 2003 03:28:19 -0000 1.13
@@ -10,7 +10,7 @@
* bits are the signed integer, or else the bottom bit is 0, in which case
* they point to an vector of Word.word's. The first word is either 0,
* indicating that the number is positive, or 1, indicating that it is
- * negative. The rest of the vector contains the `limbs' (big digits) or
+ * negative. The rest of the vector contains the `limbs' (big digits) of
* the absolute value of the number, from least to most significant.
*)
structure IntInf: INT_INF_EXTRA =
@@ -175,6 +175,73 @@
else raise Overflow
end
+ fun bigFromInt64 (i: Int64.int): bigInt =
+ if Int64.<= (~0x40000000, i) andalso Int64.<= (i, 0x3FFFFFFF)
+ then Prim.fromWord (addTag (Word.fromInt (Int64.toInt i)))
+ else
+ let
+ fun doit (i: Int64.int, isNeg): bigInt =
+ if Int64.<= (i, 0xFFFFFFFF)
+ then
+ let
+ val a = Primitive.Array.array 2
+ val _ = Array.update (a, 0, isNeg)
+ val _ = Array.update (a, 1, Int64.toWord i)
+ in
+ Prim.fromVector (Vector.fromArray a)
+ end
+ else
+ let
+ val a = Primitive.Array.array 3
+ val _ = Array.update (a, 0, isNeg)
+ val r = Int64.rem (i, 0x100000000)
+ val _ = Array.update (a, 1, Int64.toWord r)
+ val q = Int64.quot (i, 0x100000000)
+ val _ = Array.update (a, 2, Int64.toWord q)
+ in
+ Prim.fromVector (Vector.fromArray a)
+ end
+ in
+ if Int64.>= (i, 0)
+ then doit (i, 0w0)
+ else
+ if i = valOf Int64.minInt
+ then ~0x8000000000000000
+ else doit (Int64.~? i, 0w1)
+ end
+
+ fun bigToInt64 (arg: bigInt): Int64.int =
+ case rep arg of
+ Small w => Int64.fromInt (Word.toIntX w)
+ | Big v =>
+ if Vector.length v > 3
+ then raise Overflow
+ else let
+ val sign = Primitive.Vector.sub (v, 0)
+ val w1 = Primitive.Vector.sub (v, 1)
+ val w2 = Primitive.Vector.sub (v, 2)
+ in
+ if Word.> (w2, 0wx80000000)
+ then raise Overflow
+ else if w2 = 0wx80000000
+ then if w1 = 0w0 andalso sign = 0w1
+ then valOf Int64.minInt
+ else raise Overflow
+
+ else
+ let
+ val n =
+ Int64.+?
+ (Primitive.Int64.fromWord w1,
+ Int64.*? (Primitive.Int64.fromWord w2,
+ 0x100000000))
+ in
+ if sign = 0w1
+ then Int64.~ n
+ else n
+ end
+ end
+
(*
* bigInt negation.
*)
@@ -911,6 +978,7 @@
val divMod = divMod
val fmt = bigFmt
val fromInt = bigFromInt
+ val fromInt64 = bigFromInt64
val fromLarge = fn x => x
val fromString = bigFromString
val gcd = bigGcd
@@ -938,6 +1006,7 @@
val sign = bigSign
val size = size
val toInt = bigToInt
+ val toInt64 = bigToInt64
val toLarge = fn x => x
val toString = bigToString
val ~ = bigNegate
1.4 +1 -3 mlton/basis-library/integer/integer.fun
Index: integer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/integer.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- integer.fun 25 Jun 2003 23:15:32 -0000 1.3
+++ integer.fun 26 Jun 2003 03:28:19 -0000 1.4
@@ -5,9 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor Integer (I: sig
- include PRE_INTEGER_EXTRA
- end) : INTEGER_EXTRA =
+functor Integer (I: PRE_INTEGER_EXTRA): INTEGER_EXTRA =
struct
open I
1.7 +34 -12 mlton/basis-library/integer/patch.sml
Index: patch.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/patch.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- patch.sml 26 Jun 2003 02:13:17 -0000 1.6
+++ patch.sml 26 Jun 2003 03:28:19 -0000 1.7
@@ -8,26 +8,48 @@
(* Patch in fromLarge and toLarge now that IntInf is defined.
*)
-structure Int32: INTEGER_EXTRA =
+structure Int8: INTEGER_EXTRA =
struct
- open Int32
-
- val fromLarge = IntInf.toInt
- val toLarge = IntInf.fromInt
+ open Int8
+
+ val fromLarge = fromInt o IntInf.toInt
+ val toLarge = IntInf.fromInt o toInt
end
structure Int16: INTEGER_EXTRA =
struct
open Int16
- val fromLarge = fromInt o Int32.fromLarge
- val toLarge = Int32.toLarge o toInt
+ val fromLarge = fromInt o IntInf.toInt
+ val toLarge = IntInf.fromInt o toInt
end
-structure Int8: INTEGER_EXTRA =
+structure Int32: INTEGER_EXTRA =
struct
- open Int8
-
- val fromLarge = fromInt o Int32.fromLarge
- val toLarge = Int32.toLarge o toInt
+ open Int32
+
+ val fromLarge = IntInf.toInt
+ val toLarge = IntInf.fromInt
+ end
+structure Int64: INTEGER_EXTRA =
+ struct
+ open Int64
+
+ val fromLarge = IntInf.toInt64
+ val toLarge = IntInf.fromInt64
+
+ val op * =
+ if Primitive.detectOverflow
+ then fn (i, j) => fromLarge (IntInf.* (toLarge i, toLarge j))
+ else op *?
+
+ (* Must redefine scan because the Integer functor defines it in terms of
+ * Int64.*, which wasn't defined yet.
+ *)
+ fun scan radix reader state =
+ case IntInf.scan radix reader state of
+ NONE => NONE
+ | SOME (i, s) => SOME (fromLarge i, s)
+
+ val fromString = StringCvt.scanString (scan StringCvt.DEC)
end
structure Int = Int32
1.1 mlton/basis-library/integer/int64.sml
Index: int64.sml
===================================================================
(* Copyright (C) 1999-2003 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
structure Int64:
sig
include INTEGER_EXTRA
val fromWord: word -> int
val toWord: int -> word
end =
struct
structure P = Primitive.Int64
structure I = Integer (P)
open I
val fromWord = P.fromWord
val toWord = P.toWord
end
1.19 +2 -3 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- build 25 Jun 2003 23:15:32 -0000 1.18
+++ build 26 Jun 2003 03:28:19 -0000 1.19
@@ -35,6 +35,7 @@
arrays-and-vectors/mono-array.fun
arrays-and-vectors/mono-array2.sig
arrays-and-vectors/mono-array2.fun
+arrays-and-vectors/mono.sml
text/string0.sml
text/char0.sml
misc/reader.sig
@@ -48,6 +49,7 @@
integer/int8.sml
integer/int16.sml
integer/int32.sml
+integer/int64.sml
text/char.sig
text/char.sml
text/substring.sig
@@ -72,9 +74,6 @@
top-level/overloads.sml
-arrays-and-vectors/mono-vector.sml
-arrays-and-vectors/mono-array.sml
-arrays-and-vectors/mono-array2.sml
integer/pack-word.sig
integer/pack32.sml
text/byte.sig
1.9 +14 -2 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.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- basis.sig 26 Jun 2003 02:13:18 -0000 1.8
+++ basis.sig 26 Jun 2003 03:28:19 -0000 1.9
@@ -144,23 +144,29 @@
structure IntVectorSlice : MONO_VECTOR_SLICE
structure IntArray2 : MONO_ARRAY2
structure Int8 : INTEGER
+ structure Int16 : INTEGER
+ structure Int32 : INTEGER
+ structure Int64 : INTEGER
structure Int8Array : MONO_ARRAY
structure Int8ArraySlice : MONO_ARRAY_SLICE
structure Int8Vector : MONO_VECTOR
structure Int8VectorSlice : MONO_VECTOR_SLICE
structure Int8Array2 : MONO_ARRAY2
- structure Int16 : INTEGER
structure Int16Array : MONO_ARRAY
structure Int16ArraySlice : MONO_ARRAY_SLICE
structure Int16Vector : MONO_VECTOR
structure Int16VectorSlice : MONO_VECTOR_SLICE
structure Int16Array2 : MONO_ARRAY2
- structure Int32 : INTEGER
structure Int32Array : MONO_ARRAY
structure Int32ArraySlice : MONO_ARRAY_SLICE
structure Int32Vector : MONO_VECTOR
structure Int32VectorSlice : MONO_VECTOR_SLICE
structure Int32Array2 : MONO_ARRAY2
+ structure Int64Array : MONO_ARRAY
+ structure Int64ArraySlice : MONO_ARRAY_SLICE
+ structure Int64Vector : MONO_VECTOR
+ structure Int64VectorSlice : MONO_VECTOR_SLICE
+ structure Int64Array2 : MONO_ARRAY2
structure IntInf : INT_INF
structure NetHostDB : NET_HOST_DB
structure NetProtDB : NET_PROT_DB
@@ -181,6 +187,12 @@
structure RealVector : MONO_VECTOR
structure RealVectorSlice : MONO_VECTOR_SLICE
structure RealArray2 : MONO_ARRAY2
+(* structure Real32 : REAL *)
+ structure Real32Array : MONO_ARRAY
+ structure Real32ArraySlice : MONO_ARRAY_SLICE
+ structure Real32Vector : MONO_VECTOR
+ structure Real32VectorSlice : MONO_VECTOR_SLICE
+ structure Real32Array2 : MONO_ARRAY2
structure Real64 : REAL
structure Real64Array : MONO_ARRAY
structure Real64ArraySlice : MONO_ARRAY_SLICE
1.9 +32 -11 mlton/basis-library/libs/basis-2002/top-level/basis.sml
Index: basis.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- basis.sml 26 Jun 2003 02:13:18 -0000 1.8
+++ basis.sml 26 Jun 2003 03:28:19 -0000 1.9
@@ -57,11 +57,11 @@
structure FixedInt = FixedInt
structure GenericSock = GenericSock
structure INetSock = INetSock
- structure IntArray = IntArray
- structure IntArraySlice = IntArraySlice
- structure IntVector = IntVector
- structure IntVectorSlice = IntVectorSlice
- structure IntArray2 = IntArray2
+ structure IntArray = Int32Array
+ structure IntArraySlice = Int32ArraySlice
+ structure IntVector = Int32Vector
+ structure IntVectorSlice = Int32VectorSlice
+ structure IntArray2 = Int32Array2
structure Int8 = Int8
structure Int8Array = Int8Array
structure Int8ArraySlice = Int8ArraySlice
@@ -75,11 +75,27 @@
structure Int16VectorSlice = Int16VectorSlice
structure Int16Array2 = Int16Array2
structure Int32 = Int32
+ structure Int64 = Int64
+ structure Int8Array = Int8Array
+ structure Int8ArraySlice = Int8ArraySlice
+ structure Int8Vector = Int8Vector
+ structure Int8VectorSlice = Int8VectorSlice
+ structure Int8Array2 = Int8Array2
+ structure Int16Array = Int16Array
+ structure Int16ArraySlice = Int16ArraySlice
+ structure Int16Vector = Int16Vector
+ structure Int16VectorSlice = Int16VectorSlice
+ structure Int16Array2 = Int16Array2
structure Int32Array = Int32Array
structure Int32ArraySlice = Int32ArraySlice
structure Int32Vector = Int32Vector
structure Int32VectorSlice = Int32VectorSlice
structure Int32Array2 = Int32Array2
+ structure Int64Array = Int64Array
+ structure Int64ArraySlice = Int64ArraySlice
+ structure Int64Vector = Int64Vector
+ structure Int64VectorSlice = Int64VectorSlice
+ structure Int64Array2 = Int64Array2
structure IntInf = IntInf
structure NetHostDB = NetHostDB
structure NetProtDB = NetProtDB
@@ -95,11 +111,17 @@
*)
structure PackReal64Little = PackReal64Little
structure Posix = Posix
- structure RealArray = RealArray
- structure RealArraySlice = RealArraySlice
- structure RealVector = RealVector
- structure RealVectorSlice = RealVectorSlice
- structure RealArray2 = RealArray2
+ structure RealArray = Real64Array
+ structure RealArraySlice = Real64ArraySlice
+ structure RealVector = Real64Vector
+ structure RealVectorSlice = Real64VectorSlice
+ structure RealArray2 = Real64Array2
+ structure Real32 = Real32
+ structure Real32Array = Real32Array
+ structure Real32ArraySlice = Real32ArraySlice
+ structure Real32Vector = Real32Vector
+ structure Real32VectorSlice = Real32VectorSlice
+ structure Real32Array2 = Real32Array2
structure Real64 = Real64
structure Real64Array = Real64Array
structure Real64ArraySlice = Real64ArraySlice
@@ -125,7 +147,6 @@
(*
structure Windows = Windows
*)
- structure Word = Word
structure Word16 = Word16
structure Word16Array = Word16Array
structure Word16ArraySlice = Word16ArraySlice
1.61 +87 -14 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- primitive.sml 25 Jun 2003 23:15:32 -0000 1.60
+++ primitive.sml 26 Jun 2003 03:28:19 -0000 1.61
@@ -14,8 +14,16 @@
*)
type 'a array = 'a array
-datatype bool = datatype bool
-type char = char
+structure Bool =
+ struct
+ datatype bool = datatype bool
+ end
+datatype bool = datatype Bool.bool
+structure Char =
+ struct
+ type char = char
+ end
+type char = Char.char
type exn = exn
structure Int8 =
struct
@@ -33,7 +41,10 @@
struct
type int = int64
end
-type intInf = intInf
+structure IntInf =
+ struct
+ type int = intInf
+ end
datatype list = datatype list
type pointer = pointer (* C integer, not SML heap pointer *)
structure Real32 =
@@ -100,6 +111,13 @@
val touch = fn z => _prim "MLton_touch": 'a -> unit; z
val usesCallcc: bool ref = ref false;
+ structure Stdio =
+ struct
+ val print = _ffi "Stdio_print": string -> unit;
+ val sprintf =
+ _ffi "Stdio_sprintf": char array * nullString * real -> int;
+ end
+
structure Array =
struct
val array0Const =
@@ -277,7 +295,8 @@
structure Int8 =
struct
- type int = int8
+ type int = Int8.int
+
val precision' : Int.int = 8
val maxInt' : int = 0x7f
val minInt' : int = ~0x80
@@ -313,7 +332,8 @@
end
structure Int16 =
struct
- type int = int16
+ type int = Int16.int
+
val precision' : Int.int = 16
val maxInt' : int = 0x7fff
val minInt' : int = ~0x8000
@@ -349,7 +369,7 @@
end
structure Int32 =
struct
- type int = int32
+ type int = Int32.int
val precision' : Int.int = 32
val maxInt' : int = 0x7fffffff
val minInt' : int = ~0x80000000
@@ -384,6 +404,66 @@
val toInt : int -> int = fn x => x
end
structure Int = Int32
+ structure Int64 =
+ struct
+ infix 7 *?
+ infix 6 +? -?
+ infix 4 = <> > >= < <=
+
+ type int = Int64.int
+
+ val precision' : Int.int = 64
+ val maxInt' : int = 0x7FFFFFFFFFFFFFFF
+ val minInt' : int = ~0x8000000000000000
+
+ val op +? = _ffi "Int64_add": int * int -> int;
+ val op *? = _ffi "Int64_mul": int * int -> int;
+ val op -? = _ffi "Int64_sub": int * int -> int;
+ val ~? = fn i => 0 -? i
+ val op < = _ffi "Int64_lt": int * int -> bool;
+ val op <= = _ffi "Int64_le": int * int -> bool;
+ val op > = _ffi "Int64_gt": int * int -> bool;
+ val op >= = _ffi "Int64_ge": int * int -> bool;
+ val quot = _ffi "Int64_quot": int * int -> int;
+ val rem = _ffi "Int64_rem": int * int -> int;
+ val geu = _ffi "Int64_geu": int * int -> bool;
+ val gtu = _ffi "Int64_gtu": int * int -> bool;
+ val fromInt = _ffi "Int32_toInt64": Int.int -> int;
+ val fromWord = _ffi "Word32_toInt64": word -> int;
+ val toInt = _ffi "Int64_toInt32": int -> Int.int;
+ val toWord = _ffi "Int64_toWord32": int -> word;
+
+ val ~ =
+ if detectOverflow
+ then (fn i: int => if i = minInt'
+ then raise Overflow
+ else ~? i)
+ else ~?
+
+ val + =
+ if detectOverflow
+ then
+ fn (i, j) =>
+ if (if i >= 0
+ then j > maxInt' -? i
+ else j < minInt' -? i)
+ then raise Overflow
+ else i +? j
+ else op +?
+
+ val - =
+ if detectOverflow
+ then
+ fn (i, j) =>
+ if (if i >= 0
+ then j < i -? maxInt'
+ else j > i -? minInt')
+ then raise Overflow
+ else i -? j
+ else op -?
+
+ val * = fn _ => raise Fail "Int64.* unimplemented"
+ end
structure Array =
struct
@@ -398,7 +478,7 @@
structure IntInf =
struct
- type int = intInf
+ open IntInf
val + = _prim "IntInf_add": int * int * word -> int;
val andb = _prim "IntInf_andb": int * int * word -> int;
@@ -884,13 +964,6 @@
struct
end
end
- end
-
- structure Stdio =
- struct
- val print = _ffi "Stdio_print": string -> unit;
- val sprintf =
- _ffi "Stdio_sprintf": char array * nullString * real -> int;
end
structure String =
1.9 +16 -16 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- c-chunk.h 25 Jun 2003 23:15:33 -0000 1.8
+++ c-chunk.h 26 Jun 2003 03:28:19 -0000 1.9
@@ -234,8 +234,8 @@
#define Int16_min (Int16)0x8000
#define Int32_max (Int32)0x7FFFFFFF
#define Int32_min (Int32)0x80000000
-#define Int64_max (Int64)0x7FFFFFFFFFFFFFFF
-#define Int64_min (Int64)0x8000000000000000
+//#define Int64_max (Int64)0x7FFFFFFFFFFFFFFF
+//#define Int64_min (Int64)0x8000000000000000
#define Word8_max (Word8)0xFF
#define Word16_max (Word16)0xFFFF
#define Word32_max (Word32)0xFFFFFFFF
@@ -253,17 +253,17 @@
#define Int8_addCheckXC(dst, x, c, l) Int_addCheckXC(8, dst, x, c, l)
#define Int16_addCheckXC(dst, x, c, l) Int_addCheckXC(16, dst, x, c, l)
#define Int32_addCheckXC(dst, x, c, l) Int_addCheckXC(32, dst, x, c, l)
-#define Int64_addCheckXC(dst, x, c, l) Int_addCheckXC(64, dst, x, c, l)
+//#define Int64_addCheckXC(dst, x, c, l) Int_addCheckXC(64, dst, x, c, l)
#define Int8_addCheckCX(dst, c, x, l) Int8_addCheckXC(dst, x, c, l)
#define Int16_addCheckCX(dst, c, x, l) Int16_addCheckXC(dst, x, c, l)
#define Int32_addCheckCX(dst, c, x, l) Int32_addCheckXC(dst, x, c, l)
-#define Int64_addCheckCX(dst, c, x, l) Int64_addCheckXC(dst, x, c, l)
+//#define Int64_addCheckCX(dst, c, x, l) Int64_addCheckXC(dst, x, c, l)
#define Int8_addCheck Int8_addCheckXC
#define Int16_addCheck Int16_addCheckXC
#define Int32_addCheck Int32_addCheckXC
-#define Int64_addCheck Int64_addCheckXC
+//#define Int64_addCheck Int64_addCheckXC
#define Int_negCheck(size, dst, n, l) \
do { \
@@ -275,7 +275,7 @@
#define Int8_negCheck(dst, n, l) Int_negCheck(8, dst, n, l)
#define Int16_negCheck(dst, n, l) Int_negCheck(16, dst, n, l)
#define Int32_negCheck(dst, n, l) Int_negCheck(32, dst, n, l)
-#define Int64_negCheck(dst, n, l) Int_negCheck(64, dst, n, l)
+//#define Int64_negCheck(dst, n, l) Int_negCheck(64, dst, n, l)
#define Int_subCheckCX(size, dst, c, x, l) \
do { \
@@ -289,7 +289,7 @@
#define Int8_subCheckCX(dst, c, x, l) Int_subCheckCX(8, dst, c, x, l)
#define Int16_subCheckCX(dst, c, x, l) Int_subCheckCX(16, dst, c, x, l)
#define Int32_subCheckCX(dst, c, x, l) Int_subCheckCX(32, dst, c, x, l)
-#define Int64_subCheckCX(dst, c, x, l) Int_subCheckCX(64, dst, c, x, l)
+//#define Int64_subCheckCX(dst, c, x, l) Int_subCheckCX(64, dst, c, x, l)
#define Int_subCheckXC(size, dst, x, c, l) \
do { \
@@ -303,12 +303,12 @@
#define Int8_subCheckXC(dst, c, x, l) Int_subCheckXC(8, dst, c, x, l)
#define Int16_subCheckXC(dst, c, x, l) Int_subCheckXC(16, dst, c, x, l)
#define Int32_subCheckXC(dst, c, x, l) Int_subCheckXC(32, dst, c, x, l)
-#define Int64_subCheckXC(dst, c, x, l) Int_subCheckXC(64, dst, c, x, l)
+//#define Int64_subCheckXC(dst, c, x, l) Int_subCheckXC(64, dst, c, x, l)
#define Int8_subCheck Int8_subCheckXC
#define Int16_subCheck Int16_subCheckXC
#define Int32_subCheck Int32_subCheckXC
-#define Int64_subCheck Int64_subCheckXC
+//#define Int64_subCheck Int64_subCheckXC
#define Word_addCheckXC(size, dst, x, c, l) \
do { \
@@ -370,8 +370,8 @@
check (dst, n1, n2, l, Int16_mulOverflow)
#define Int32_mulCheck(dst, n1, n2, l) \
check (dst, n1, n2, l, Int32_mulOverflow)
-#define Int64_mulCheck(dst, n1, n2, l) \
- fprintf (stderr, "FIXME: Int64_mulCheck\n");
+//#define Int64_mulCheck(dst, n1, n2, l) \
+// fprintf (stderr, "FIXME: Int64_mulCheck\n");
#define Word8_mulCheck(dst, n1, n2, l) \
check (dst, n1, n2, l, Word8_mulOverflow)
@@ -392,8 +392,8 @@
#define intAllBinary(name, op) \
intBinary(name,op,8) \
intBinary(name,op,16) \
- intBinary(name,op,32) \
- intBinary(name,op,64)
+ intBinary(name,op,32)
+// intBinary(name,op,64)
intAllBinary (add, +)
intAllBinary (mul, *)
intAllBinary (sub, -)
@@ -408,8 +408,8 @@
#define intAllBinaryCompare(name, op) \
intBinaryCompare(name,op,8) \
intBinaryCompare(name,op,16) \
- intBinaryCompare(name,op,32) \
- intBinaryCompare(name,op,64)
+ intBinaryCompare(name,op,32)
+// intBinaryCompare(name,op,64)
intAllBinaryCompare (ge, >=)
intAllBinaryCompare (gt, >)
intAllBinaryCompare (le, <=)
@@ -424,7 +424,7 @@
Int_neg(8)
Int_neg(16)
Int_neg(32)
-Int_neg(64)
+//Int_neg(64)
#undef Int_neg
/* ------------------------------------------------- */
1.2 +1 -0 mlton/regression/fixed-integer.ok
Index: fixed-integer.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/fixed-integer.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- fixed-integer.ok 25 Jun 2003 21:22:53 -0000 1.1
+++ fixed-integer.ok 26 Jun 2003 03:28:20 -0000 1.2
@@ -1,3 +1,4 @@
Testing Int8
Testing Int16
Testing Int32
+Testing Int64
1.2 +18 -11 mlton/regression/fixed-integer.sml
Index: fixed-integer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/fixed-integer.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- fixed-integer.sml 25 Jun 2003 21:22:53 -0000 1.1
+++ fixed-integer.sml 26 Jun 2003 03:28:20 -0000 1.2
@@ -28,26 +28,19 @@
foreach
([("toString", I.toString, LargeInt.toString),
("fmt BIN", I.fmt BIN, LargeInt.fmt BIN),
- ("fmt OCT", I.fmt BIN, LargeInt.fmt BIN),
- ("fmt DEC", I.fmt BIN, LargeInt.fmt BIN),
- ("fmt HEX", I.fmt BIN, LargeInt.fmt BIN)],
+ ("fmt OCT", I.fmt OCT, LargeInt.fmt OCT),
+ ("fmt DEC", I.fmt DEC, LargeInt.fmt DEC),
+ ("fmt HEX", I.fmt HEX, LargeInt.fmt HEX)],
fn (name, f, f') =>
let
val s = f i
- val s' = f' (I.toLarge i)
+ val s' = f' (I.toLarge i) handle Overflow => "Overflow"
in
if s = s'
then ()
else err [name, " ", s, " <> ", name, " ", s']
end))
- val _ =
- foreach
- (nums, fn i =>
- if SOME i = (SOME (I.fromLarge (I.toLarge i)) handle Overflow => NONE)
- then ()
- else err ["{from,to}Large ", I.toString i, "\n"])
-
structure Answer =
struct
datatype t =
@@ -70,6 +63,19 @@
val _ =
foreach
+ (nums, fn i =>
+ let
+ val a1 = Answer.Int i
+ val a2 = Answer.run (fn () => I.fromLarge (I.toLarge i))
+ in
+ if Answer.equals (a1, a2)
+ then ()
+ else err ["fromLarge (toLarge ", I.toString i, ") = ",
+ Answer.toString a2]
+ end)
+
+ val _ =
+ foreach
([("abs", I.abs, LargeInt.abs),
("~", I.~, LargeInt.~),
("fromString o toString",
@@ -207,3 +213,4 @@
structure S = Test (Int8)
structure S = Test (Int16)
structure S = Test (Int32)
+structure S = Test (Int64)
1.67 +2 -0 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- Makefile 24 Jun 2003 21:25:37 -0000 1.66
+++ Makefile 26 Jun 2003 03:28:20 -0000 1.67
@@ -32,6 +32,7 @@
basis/GC/setSummary.o \
basis/IEEEReal.o \
basis/IntInf.o \
+ basis/Int/Int64.o \
basis/Int/addOverflow.o \
basis/Int/mulOverflow.o \
basis/Int/negOverflow.o \
@@ -198,6 +199,7 @@
basis/GC/setSummary-gdb.o \
basis/IEEEReal-gdb.o \
basis/IntInf-gdb.o \
+ basis/Int/Int64-gdb.o \
basis/Int/addOverflow-gdb.o \
basis/Int/mulOverflow-gdb.o \
basis/Int/negOverflow-gdb.o \
1.1 mlton/runtime/basis/Int/Int64.c
Index: Int64.c
===================================================================
#include "libmlton.h"
enum {
DEBUG = FALSE,
};
#define Int64_max (Int64)0x7FFFFFFFFFFFFFFF
#define Int64_min (Int64)0x8000000000000000
#define binary(name, op) \
Int64 Int64_##name (Int64 i, Int64 j) { \
if (DEBUG) \
fprintf (stderr, "%lld = " #name " (%lld, %lld)\n", \
i op j, i, j); \
return i op j; \
}
binary(add, +)
binary(mul, *)
binary(sub, -)
binary(quot, /)
binary(rem, %)
#undef binary
#define compare(name, op) \
Bool Int64_##name (Int64 i, Int64 j) { \
if (DEBUG) \
fprintf (stderr, "%d = %lld " #op " %lld\n", \
i op j, i, j); \
return i op j; \
}
compare(ge, >=)
compare(gt, >)
compare(le, <=)
compare(lt, <)
#undef compare
#define compareU(name,op) \
Bool Int64_##name (Int64 i, Int64 j) { \
return (Word64)i op (Word64)j; \
}
compareU(geu, >=)
compareU(gtu, >)
#undef compareU
Int32 Int64_toInt32 (Int64 i) {
return (Int32)i;
}
Int64 Int32_toInt64 (Int32 i) {
return (Int64)i;
}
Word32 Int64_toWord32 (Int64 i) {
return (Word32)i;
}
Int64 Word32_toInt64 (Word32 i) {
return (Int64)i;
}
-------------------------------------------------------
This SF.Net email is sponsored by: INetU
Attention Web Developers & Consultants: Become An INetU Hosting Partner.
Refer Dedicated Servers. We Manage Them. You Get 10% Monthly Commission!
INetU Dedicated Managed Hosting http://www.inetu.net/partner/index.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel