[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