mlton-commit — [MLton-commit] Code commits

[MLton-commit] r4388

[Stephen W. <sw...@ml...>]

Eliminated deprecated checkSlice{,Max}.

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

U   mlton/trunk/basis-library/arrays-and-vectors/array.sig
U   mlton/trunk/basis-library/arrays-and-vectors/array2.sml
U   mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
U   mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
U   mlton/trunk/basis-library/arrays-and-vectors/vector.sig
U   mlton/trunk/basis-library/real/pack-real.sml

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

Modified: mlton/trunk/basis-library/arrays-and-vectors/array.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array.sig	2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/array.sig	2006-03-30 20:37:36 UTC (rev 4388)
@@ -40,8 +40,6 @@
 
       structure ArraySlice: ARRAY_SLICE_EXTRA 
 
-      val checkSlice: 'a array * int * int option -> int (* Deprecated *)
-      val checkSliceMax: int * int option * int -> int (* Deprecated *)
       val concat: 'a array list -> 'a array
       val duplicate: 'a array -> 'a array
       val rawArray: int -> 'a array

Modified: mlton/trunk/basis-library/arrays-and-vectors/array2.sml
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array2.sml	2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/array2.sml	2006-03-30 20:37:36 UTC (rev 4388)
@@ -28,10 +28,28 @@
                         nrows: int option,
                         ncols: int option}
 
+      fun checkSliceMax (start: int, num: int option, max: int): int =
+         case num of
+            NONE =>
+               if Primitive.safe andalso (start < 0 orelse start > max) then
+                  raise Subscript
+               else
+                  max
+          | SOME num =>
+               if Primitive.safe
+                  andalso (start < 0
+                           orelse num < 0
+                           orelse start > max -? num) then
+                  raise Subscript
+               else
+                  start +? num
+
       fun checkRegion {base, row, col, nrows, ncols} =
-         let val (rows, cols) = dimensions base
-         in {stopRow = Array.checkSliceMax (row, nrows, rows),
-             stopCol = Array.checkSliceMax (col, ncols, cols)}
+         let
+            val (rows, cols) = dimensions base
+         in
+            {stopRow = checkSliceMax (row, nrows, rows),
+             stopCol = checkSliceMax (col, ncols, cols)}
          end
       
       fun wholeRegion (a: 'a array): 'a region =

Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.fun	2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.fun	2006-03-30 20:37:36 UTC (rev 4388)
@@ -456,18 +456,4 @@
         fun duplicate seq = make Slice.sequence seq
         fun toList seq = make Slice.toList seq
       end
-    
-      (* Deprecated *)
-      fun checkSliceMax (start: int, num: int option, max: int): int =
-         case num of
-            NONE => if Primitive.safe andalso (start < 0 orelse start > max)
-                       then raise Subscript
-                    else max
-          | SOME num =>
-               if Primitive.safe
-                  andalso (start < 0 orelse num < 0 orelse start > max -? num)
-                  then raise Subscript
-               else start +? num
-      (* Deprecated *)
-      fun checkSlice (s, i, opt) = checkSliceMax (i, opt, length s)
    end

Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.sig	2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.sig	2006-03-30 20:37:36 UTC (rev 4388)
@@ -63,9 +63,4 @@
       val new: int * 'a elt -> 'a sequence
       val toList: 'a sequence -> 'a elt list
       val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence * 'a
-
-      (* Deprecated *)
-      val checkSlice: 'a sequence * int * int option -> int
-      (* Deprecated *)
-      val checkSliceMax: int * int option * int -> int
    end

Modified: mlton/trunk/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/vector.sig	2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/vector.sig	2006-03-30 20:37:36 UTC (rev 4388)
@@ -34,28 +34,24 @@
       include VECTOR
       structure VectorSlice: VECTOR_SLICE_EXTRA 
 
-      val unsafeSub: 'a vector * int -> 'a
-
-      (* Used to implement Substring/String functions *)
-      val concatWith: 'a vector -> 'a vector list -> 'a vector
-      val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
-      val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
-      val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
-      val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
-      val tokens: ('a -> bool) -> 'a vector -> 'a vector list
-      val fields: ('a -> bool) -> 'a vector -> 'a vector list
-
       val append: 'a vector * 'a vector -> 'a vector
+      (* concatWith is used to implement Substring/String functions *)
+      val concatWith: 'a vector -> 'a vector list -> 'a vector
       val create:
-         int * ({sub: int -> 'a, update: int * 'a -> unit}
-                -> (int -> 'a) * (unit -> unit))
+         int
+         * ({sub: int -> 'a, update: int * 'a -> unit}
+            -> (int -> 'a) * (unit -> unit))
          -> 'a vector
       val duplicate: 'a vector -> 'a vector
+      val fields: ('a -> bool) -> 'a vector -> 'a vector list
       val fromArray: 'a array -> 'a vector
+      val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+      val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+      val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
       val toList: 'a vector -> 'a list
+      val tokens: ('a -> bool) -> 'a vector -> 'a vector list
+      val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
       val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
+      val unsafeSub: 'a vector * int -> 'a
       val vector: int * 'a -> 'a vector
-
-      (* Deprecated *)
-      val checkSlice: 'a vector * int * int option -> int
    end

Modified: mlton/trunk/basis-library/real/pack-real.sml
===================================================================
--- mlton/trunk/basis-library/real/pack-real.sml	2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/real/pack-real.sml	2006-03-30 20:37:36 UTC (rev 4388)
@@ -24,10 +24,16 @@
       then (subVec, update)
    else (subVecRev, updateRev)
 
+fun check (size, i) =
+   if Int.< (i, 0) orelse Int.> (i, size -? bytesPerElem) then
+      raise Subscript
+   else
+      ()
+
 fun update (a, i, r) =
    let
+      val () = check (Word8Array.length a, i)
       val a = Word8Array.toPoly a
-      val _ = Array.checkSlice (a, i, SOME bytesPerElem)
    in
       up (a, i, r)
    end
@@ -42,8 +48,8 @@
 
 fun subVec (v, i) =
    let
+      val () = check (Word8Vector.length v, i)
       val v = Word8Vector.toPoly v
-      val _ = Vector.checkSlice (v, i, SOME bytesPerElem)
    in
       sub (v, i)
    end

[MLton-commit] r4387

[Stephen W. <sw...@ml...>]

Changed unfoldi to return the state in addition to the created
object.

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

U   mlton/trunk/basis-library/arrays-and-vectors/array.sig
U   mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig
U   mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig
U   mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
U   mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
U   mlton/trunk/basis-library/arrays-and-vectors/vector.sig
U   mlton/trunk/basis-library/mlton/array.sig
U   mlton/trunk/basis-library/mlton/vector.sig

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

Modified: mlton/trunk/basis-library/arrays-and-vectors/array.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/array.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -40,17 +40,13 @@
 
       structure ArraySlice: ARRAY_SLICE_EXTRA 
 
-      val rawArray: int -> 'a array
-      val unsafeSub: 'a array * int -> 'a
-      val unsafeUpdate: 'a array * int * 'a -> unit
-
+      val checkSlice: 'a array * int * int option -> int (* Deprecated *)
+      val checkSliceMax: int * int option * int -> int (* Deprecated *)
       val concat: 'a array list -> 'a array
       val duplicate: 'a array -> 'a array
+      val rawArray: int -> 'a array
       val toList: 'a array -> 'a list
-      val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b array
-
-      (* Deprecated *)
-      val checkSlice: 'a array * int * int option -> int
-      (* Deprecated *)
-      val checkSliceMax: int * int option * int -> int
+      val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
+      val unsafeSub: 'a array * int -> 'a
+      val unsafeUpdate: 'a array * int * 'a -> unit
    end

Modified: mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -45,7 +45,7 @@
       val rawArray: int -> array
       val toList: array -> elem list
       val toPoly: array -> elem Array.array
-      val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array
+      val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array * 'a
       val unsafeSub: array * int -> elem
       val unsafeUpdate: array * int * elem -> unit
    end

Modified: mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -41,7 +41,7 @@
       val toList: vector -> elem list
       val tokens: (elem -> bool) -> vector -> vector list
       val translate: (elem -> vector) -> vector -> vector
-      val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector
+      val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector * 'a
       val unsafeSub: vector * int -> elem
       val vector: int * elem -> vector
    end

Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.fun	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.fun	2006-03-30 20:09:58 UTC (rev 4387)
@@ -39,21 +39,21 @@
          let
             val a = array n
             fun loop (i, b)  =
-               if i >= n
-                  then ()
+               if i >= n then
+                  b
                else
                   let
                      val (x, b') = f (i, b)
-                     val _ = Array.update (a, i, x)
+                     val () = Array.update (a, i, x)
                   in
                      loop (i +? 1, b')
                   end
-            val () = loop (0, b)
+            val b = loop (0, b)
          in
-            fromArray a
+            (fromArray a, b)
          end
 
-      fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
+      fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
 
       fun new (n, x) = tabulate (n, fn _ => x)
 
@@ -191,25 +191,26 @@
                in loop (min1, min2)
                end
             fun sequence (sl as T {seq, start, len}): 'a sequence =
-               if isMutable orelse (start <> 0 orelse len <> S.length seq)
-                  then map (fn x => x) sl
-               else seq
+               if isMutable orelse (start <> 0 orelse len <> S.length seq) then
+                  map (fn x => x) sl
+               else
+                  seq
             fun append (sl1: 'a slice, sl2: 'a slice): 'a sequence =
-               if length sl1 = 0
-                  then sequence sl2
-               else if length sl2 = 0
-                  then sequence sl1
+               if length sl1 = 0 then
+                  sequence sl2
+               else if length sl2 = 0 then
+                  sequence sl1
                else
                   let
                      val l1 = length sl1
                      val l2 = length sl2
                      val n = l1 + l2 handle Overflow => raise Size
                   in
-                     unfoldi (n, (0, sl1),
-                              fn (_, (i, sl)) =>
-                                  if i < length sl
-                                     then (unsafeSub (sl, i), (i +? 1, sl))
-                                  else (unsafeSub (sl2, 0), (1, sl2)))
+                     #1 (unfoldi (n, (0, sl1),
+                                  fn (_, (i, sl)) =>
+                                  if i < length sl then
+                                     (unsafeSub (sl, i), (i +? 1, sl))
+                                  else (unsafeSub (sl2, 0), (1, sl2))))
                   end
             fun concat (sls: 'a slice list): 'a sequence =
                case sls of
@@ -220,17 +221,19 @@
                         val n = List.foldl (fn (sl, s) => s + length sl) 0 sls'
                                 handle Overflow => raise Size
                      in
-                        unfoldi (n, (0, sl, sls),
-                                 fn (_, ac) =>
-                                 let
-                                    fun loop (i, sl, sls) =
-                                       if i < length sl
-                                          then (unsafeSub (sl, i), (i +? 1, sl, sls))
-                                       else case sls of
-                                               [] => raise Fail "concat bug"
-                                             | sl :: sls => loop (0, sl, sls)
-                                 in loop ac
-                                 end)
+                        #1 (unfoldi (n, (0, sl, sls),
+                                     fn (_, ac) =>
+                                     let
+                                        fun loop (i, sl, sls) =
+                                           if i < length sl then
+                                              (unsafeSub (sl, i),
+                                               (i +? 1, sl, sls))
+                                           else case sls of
+                                              [] => raise Fail "concat bug"
+                                            | sl :: sls => loop (0, sl, sls)
+                                     in
+                                        loop ac
+                                     end))
                      end
             fun concatWith (sep: 'a sequence) (sls: 'a slice list): 'a sequence =
                let val sep = full sep

Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -62,7 +62,7 @@
       val duplicate: 'a sequence -> 'a sequence
       val new: int * 'a elt -> 'a sequence
       val toList: 'a sequence -> 'a elt list
-      val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence
+      val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence * 'a
 
       (* Deprecated *)
       val checkSlice: 'a sequence * int * int option -> int

Modified: mlton/trunk/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/vector.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/vector.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -53,7 +53,7 @@
       val duplicate: 'a vector -> 'a vector
       val fromArray: 'a array -> 'a vector
       val toList: 'a vector -> 'a list
-      val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b vector
+      val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
       val vector: int * 'a -> 'a vector
 
       (* Deprecated *)

Modified: mlton/trunk/basis-library/mlton/array.sig
===================================================================
--- mlton/trunk/basis-library/mlton/array.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/mlton/array.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -10,5 +10,5 @@
    
 signature MLTON_ARRAY =
    sig
-      val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+      val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
    end

Modified: mlton/trunk/basis-library/mlton/vector.sig
===================================================================
--- mlton/trunk/basis-library/mlton/vector.sig	2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/mlton/vector.sig	2006-03-30 20:09:58 UTC (rev 4387)
@@ -14,6 +14,6 @@
          int * ({sub: int -> 'a, update: int * 'a -> unit}
                 -> (int -> 'a) * (unit -> unit))
          -> 'a vector
-      val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
+      val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
    end
    

[MLton-commit] r4386

[Matthew F. <fl...@ml...>]

Removed absolute paths
----------------------------------------------------------------------

U   mlton/trunk/lib/mlrisc-lib/MLRISC.patch

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

Modified: mlton/trunk/lib/mlrisc-lib/MLRISC.patch
===================================================================
--- mlton/trunk/lib/mlrisc-lib/MLRISC.patch	2006-03-29 22:04:27 UTC (rev 4385)
+++ mlton/trunk/lib/mlrisc-lib/MLRISC.patch	2006-03-30 11:07:48 UTC (rev 4386)
@@ -2544,15 +2544,15 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l50 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l9 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -3132,7 +3132,7 @@
 +    end
 +  basis l29 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -3844,15 +3844,15 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l16 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l37 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -4342,23 +4342,23 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l12 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l230 = 
 +    bas
-+      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb
++      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb
 +    end
 +  basis l39 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +  basis l311 = 
 +    bas
-+      (* $MLTREE.cm(=$SMLNJ-MLRISC)/MLTREE.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLTREE.mlb
++      (* $MLTREE.cm(=$SMLNJ-MLRISC)/MLTREE.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLTREE.mlb
 +    end
 +in
 +local
@@ -5119,15 +5119,15 @@
 +local
 +  basis l8 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l16 = 
 +    bas
-+      (* $IA32.cm(=$SMLNJ-MLRISC)/IA32.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/IA32.mlb
++      (* $IA32.cm(=$SMLNJ-MLRISC)/IA32.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/IA32.mlb
 +    end
 +  basis l4 = 
 +    bas
-+      (* $Peephole.cm(=$SMLNJ-MLRISC)/Peephole.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Peephole.mlb
++      (* $Peephole.cm(=$SMLNJ-MLRISC)/Peephole.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Peephole.mlb
 +    end
 +in
 +local
@@ -5462,15 +5462,15 @@
 +    end
 +  basis l44 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l5 = 
 +    bas
-+      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb
++      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb
 +    end
 +  basis l9 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -7171,15 +7171,15 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l42 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l68 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -7380,11 +7380,11 @@
 +local
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l14 = 
 +    bas
-+      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb
++      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb
 +    end
 +in
 +local
@@ -7453,15 +7453,15 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l50 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l9 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -8032,15 +8032,15 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l53 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l29 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -8188,15 +8188,15 @@
 +    end
 +  basis l4 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l46 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l30 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local
@@ -8728,19 +8728,19 @@
 +    end
 +  basis l66 = 
 +    bas
-+      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb
++      (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb
 +    end
 +  basis l5 = 
 +    bas
-+      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb
++      (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb
 +    end
 +  basis l12 = 
 +    bas
-+      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb
++      (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb
 +    end
 +  basis l19 = 
 +    bas
-+      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb
++      (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb
 +    end
 +in
 +local

[MLton-commit] r4385

[Stephen W. <sw...@ml...>]

Sped up the implementation of Real.{==,!=,isNan}.

Real.== no longer calls Real.class to ensure basis spec compliance.
Instead, it assumes that the primitive == does the right thing.

Real.isNan is now implemented with

  fun isNan r = r != r

This was about 4 times faster on my machine than the old version that
used Real.class.

Changed the primitive simplifier so that it doesn't simplify
Real_equal(x, x) to true, since this is incorrect for nans.


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

U   mlton/trunk/basis-library/real/real.fun
U   mlton/trunk/mlton/atoms/prim.fun

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

Modified: mlton/trunk/basis-library/real/real.fun
===================================================================
--- mlton/trunk/basis-library/real/real.fun	2006-03-29 00:21:10 UTC (rev 4384)
+++ mlton/trunk/basis-library/real/real.fun	2006-03-29 22:04:27 UTC (rev 4385)
@@ -105,19 +105,13 @@
           | NAN => false
           | _ => true
 
-      fun isNan r = class r = NAN
+      val op == = Prim.==
 
-      fun isNormal r = class r = NORMAL
+      val op != = not o op ==
 
-      val op == =
-         fn (x, y) =>
-         case (class x, class y) of
-            (NAN, _) => false
-          | (_, NAN) => false
-          | (ZERO, ZERO) => true
-          | _ => Prim.== (x, y)
+      fun isNan r = r != r
 
-      val op != = not o op ==
+      fun isNormal r = class r = NORMAL
 
       val op ?= =
          if MLton.Codegen.isNative

Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun	2006-03-29 00:21:10 UTC (rev 4384)
+++ mlton/trunk/mlton/atoms/prim.fun	2006-03-29 22:04:27 UTC (rev 4385)
@@ -1507,7 +1507,6 @@
                               | MLton_equal => t
                               | Real_lt _ => f
                               | Real_le _ => t
-                              | Real_equal _ => t
                               | Real_qequal _ => t
                               | Word_andb _ => Var x
                               | Word_equal _ => t

[MLton-commit] r4384

[Stephen W. <sw...@ml...>]

Made Primitive.Real.class return an abstract type.

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

U   mlton/trunk/basis-library/real/real.fun
U   mlton/trunk/basis-library/real/real.sig

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

Modified: mlton/trunk/basis-library/real/real.fun
===================================================================
--- mlton/trunk/basis-library/real/real.fun	2006-03-28 22:58:06 UTC (rev 4383)
+++ mlton/trunk/basis-library/real/real.fun	2006-03-29 00:21:10 UTC (rev 4384)
@@ -63,10 +63,11 @@
 
       val nan = posInf + negInf
 
+      structure Class = Primitive.Real64.Class
       local
          val classes =
             let
-               open Primitive.Real64.Class
+               open Class
             in
                (* order here is chosen based on putting the more commonly used
                 * classes at the front.
@@ -103,7 +104,7 @@
             INF => false
           | NAN => false
           | _ => true
-               
+
       fun isNan r = class r = NAN
 
       fun isNormal r = class r = NORMAL

Modified: mlton/trunk/basis-library/real/real.sig
===================================================================
--- mlton/trunk/basis-library/real/real.sig	2006-03-28 22:58:06 UTC (rev 4383)
+++ mlton/trunk/basis-library/real/real.sig	2006-03-29 00:21:10 UTC (rev 4384)
@@ -27,7 +27,7 @@
       val ?= : real * real -> bool
       val ~ : real -> real
       val abs: real -> real
-      val class: real -> int
+      val class: real -> Primitive.Real64.Class.t
       val frexp: real * int ref -> real
       val gdtoa: real * int * int * int ref -> Primitive.CString.t
       val fromInt: int -> real

[MLton-commit] r4383

[Stephen W. <sw...@ml...>]

Eliminated vestigial usesCallcc stuff.

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

U   mlton/trunk/basis-library/arrays-and-vectors/array2.sml
U   mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
U   mlton/trunk/basis-library/misc/primitive.sml
U   mlton/trunk/basis-library/mlton/cont.sml

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

Modified: mlton/trunk/basis-library/arrays-and-vectors/array2.sml
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array2.sml	2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/arrays-and-vectors/array2.sml	2006-03-28 22:58:06 UTC (rev 4383)
@@ -142,72 +142,12 @@
       fun modify trv f a = modifyi trv (f o #3) (wholeRegion a)
 
       fun tabulate trv (rows, cols, f) =
-         if !Primitive.usesCallcc
-            then
-               (* All this mess is careful to construct a list representing
-                * the array and then convert the list to the array after all
-                * the calls to f have been made, in case f uses callcc.
-                *)
-               let
-                  val size =
-                     if Primitive.safe andalso (rows < 0 orelse cols < 0)
-                        then raise Size
-                     else rows * cols handle Overflow => raise Size
-                  val (rows', cols', f) =
-                     case trv of
-                        RowMajor => (rows, cols, f)
-                      | ColMajor => (cols, rows, fn (c, r) => f (r, c))
-                  fun loopr (r, l) =
-                     if r >= rows'
-                        then l
-                     else
-                        let
-                           fun loopc (c, l) =
-                              if c >= cols'
-                                 then l
-                              else loopc (c + 1, f (r, c) :: l)
-                        in loopr (r + 1, loopc (0, l))
-                        end
-                  val l = loopr (0, [])
-                  val a = Primitive.Array.array size
-               in case trv of
-                  RowMajor =>
-                     (* The list holds the elements in row major order,
-                      * but reversed.
-                      *)
-                     let
-                        val _ =
-                           List.foldl (fn (x, i) =>
-                                       (Primitive.Array.update (a, i, x)
-                                        ; i -? 1))
-                           (size -? 1) l
-                     in
-                        ()
-                     end
-                | ColMajor =>
-                     (* The list holds the elements in column major order,
-                      * but reversed.
-                      *)
-                     let
-                        val _ =
-                           List.foldl (fn (x, (spot, r)) =>
-                                       (Primitive.Array.update (a, spot, x)
-                                        ; if r = 0
-                                             then (spot -? 1 +? size -? cols,
-                                                   rows -? 1)
-                                          else (spot -? cols, r -? 1)))
-                           (size -? 1, rows -? 1)
-                           l
-                     in
-                        ()
-                     end
-                  ; {rows = rows, cols = cols, array = a}
-               end
-         else
-            let val a = arrayUninit (rows, cols)
-            in modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
-               ; a
-            end
+         let
+            val a = arrayUninit (rows, cols)
+            val () = modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
+         in
+            a
+         end
 
       fun copy {src = src as {base, row, col, ...}: 'a region,
                 dst, dst_row, dst_col} =

Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.fun	2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.fun	2006-03-28 22:58:06 UTC (rev 4383)
@@ -32,6 +32,9 @@
 
       fun seq0 () = fromArray (array 0)
 
+      (* unfoldi depends on the fact that the runtime system fills in the array
+       * with reasonable bogus values.
+       *)
       fun unfoldi (n, b, f) =
          let
             val a = array n
@@ -45,42 +48,12 @@
                   in
                      loop (i +? 1, b')
                   end
-            val _ = loop (0, b)
+            val () = loop (0, b)
          in
             fromArray a
          end
 
-      (* Tabulate depends on the fact that the runtime system fills in the array
-       * with reasonable bogus values.
-       *)
-      fun tabulate (n, f) =
-(*
-         if !Primitive.usesCallcc
-            then
-               (* This code is careful to use a list to accumulate the 
-                * components of the array in case f uses callcc.
-                *)
-               let
-                  fun loop (i, l) =
-                     if i >= n
-                        then l
-                     else loop (i + 1, f i :: l)
-                  val l = loop (0, [])
-                  val a = array n
-                  fun loop (l, i) =
-                     case l of
-                        [] => ()
-                      | x :: l =>
-                           let val i = i -? 1
-                           in Array.update (a, i, x)
-                              ; loop (l, i)
-                           end
-               in loop (l, n)
-                  ; fromArray a
-               end
-         else
-*)
-            unfoldi (n, (), fn (i, ()) => (f i, ()))
+      fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
 
       fun new (n, x) = tabulate (n, fn _ => x)
 

Modified: mlton/trunk/basis-library/misc/primitive.sml
===================================================================
--- mlton/trunk/basis-library/misc/primitive.sml	2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/misc/primitive.sml	2006-03-28 22:58:06 UTC (rev 4383)
@@ -215,7 +215,6 @@
          _prim "MLton_installSignalHandler": unit -> unit;
       val safe = _command_line_const "MLton.safe": bool = true;
       val touch = _prim "MLton_touch": 'a -> unit;
-      val usesCallcc: bool ref = ref false;
 
       structure Stdio =
          struct
@@ -1293,7 +1292,16 @@
          struct
             open Real64
 
-            structure Class =
+            structure Class:>
+               sig
+                  eqtype t
+
+                  val inf: t
+                  val nan: t
+                  val normal: t
+                  val subnormal: t
+                  val zero: t
+               end =
                struct
                   type t = int
                      
@@ -1338,7 +1346,7 @@
             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 class = _import "Real64_class": real -> Class.t;
             val frexp = _import "Real64_frexp": real * int ref -> real;
             val gdtoa =
                _import "Real64_gdtoa": real * int * int * int ref -> CString.t;
@@ -1412,7 +1420,7 @@
             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;
+            val class = _import "Real32_class": real -> Real64.Class.t;
             fun frexp (r: real, ir: int ref): real =
                fromLarge (Real64.frexp (toLarge r, ir))
             val gdtoa =

Modified: mlton/trunk/basis-library/mlton/cont.sml
===================================================================
--- mlton/trunk/basis-library/mlton/cont.sml	2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/mlton/cont.sml	2006-03-28 22:58:06 UTC (rev 4383)
@@ -11,54 +11,44 @@
 
 structure Thread = Primitive.Thread
 
-(* This mess with dummy is so that if callcc is ever used anywhere in the
- * program, then Primitive.usesCallcc is set to true during basis library
- * evaluation.  This relies on the dead code elimination algorithm
- * (core-ml/dead-code.fun), which will keep dummy around only if callcc is used.
- *)
-val dummy =
-   (Primitive.usesCallcc := true
-    ; fn () => ())
-
 type 'a t = (unit -> 'a) -> unit
 
 fun callcc (f: 'a t -> 'a): 'a =
-   (dummy ()
-    ; if MLtonThread.amInSignalHandler ()
-         then die "callcc can not be used in a signal handler\n"
-      else 
-         let
-            datatype 'a state =
-               Original of 'a t -> 'a
-             | Copy of unit -> 'a
-             | Clear
-            val r: 'a state ref = ref (Original f)
-            val _ = Thread.atomicBegin () (* Match 1 *)
-            val _ = Thread.copyCurrent ()
-         in
-            case (!r before r := Clear) of
-               Clear => raise Fail "callcc saw Clear"
-             | Copy v => (Thread.atomicEnd () (* Match 2 *)
-                          ; v ())
-             | Original f =>
-                  let
-                     val t = Thread.savedPre ()
-                  in
-                     Thread.atomicEnd () (* Match 1 *)
-                     ; f (fn v =>
-                          let
-                             val _ = Thread.atomicBegin () (* Match 2 *)
-                             val _ = r := Copy v
-                             val new = Thread.copy t
-                             (* The following Thread.atomicBegin () 
-                              * is matched by Thread.switchTo.
-                              *)
-                             val _ = Thread.atomicBegin ()
-                          in
-                             Thread.switchTo new
-                          end)
-                  end
-         end)
+   if MLtonThread.amInSignalHandler () then
+      die "callcc can not be used in a signal handler\n"
+   else 
+      let
+         datatype 'a state =
+            Original of 'a t -> 'a
+          | Copy of unit -> 'a
+          | Clear
+         val r: 'a state ref = ref (Original f)
+         val _ = Thread.atomicBegin () (* Match 1 *)
+         val _ = Thread.copyCurrent ()
+      in
+         case (!r before r := Clear) of
+            Clear => raise Fail "callcc saw Clear"
+          | Copy v => (Thread.atomicEnd () (* Match 2 *)
+                       ; v ())
+          | Original f =>
+               let
+                  val t = Thread.savedPre ()
+               in
+                  Thread.atomicEnd () (* Match 1 *)
+                  ; f (fn v =>
+                       let
+                          val _ = Thread.atomicBegin () (* Match 2 *)
+                          val _ = r := Copy v
+                          val new = Thread.copy t
+                          (* The following Thread.atomicBegin () 
+                           * is matched by Thread.switchTo.
+                           *)
+                          val _ = Thread.atomicBegin ()
+                       in
+                          Thread.switchTo new
+                       end)
+               end
+      end
 
 fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
    (k v; raise Fail "throw bug")

[MLton-commit] r4382

[Stephen W. <sw...@ml...>]

Eliminated test code.

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

U   mlton/trunk/basis-library/mlton/mlton.sml

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

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2006-03-28 21:34:14 UTC (rev 4381)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2006-03-28 22:00:23 UTC (rev 4382)
@@ -102,13 +102,3 @@
                end
          end
    end
-
-local
-   open MLton.Vector
-in
-   fun fib n =
-      Vector.create (n,
-                     fn {sub = fib, ...} =>
-                     (fn i => if i <= 1 then 1 else fib (i - 1) + fib (i - 2),
-                      ignore))
-end

[MLton-commit] r4381

[Stephen W. <sw...@ml...>]

Added MLton.Vector.create, a more powerful vector-creation function
than is available in the basis library.


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

U   mlton/trunk/basis-library/arrays-and-vectors/vector.sig
U   mlton/trunk/basis-library/arrays-and-vectors/vector.sml
U   mlton/trunk/basis-library/misc/primitive.sml
U   mlton/trunk/basis-library/mlton/mlton.sml
U   mlton/trunk/basis-library/mlton/vector.sig

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

Modified: mlton/trunk/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/vector.sig	2006-03-24 23:33:21 UTC (rev 4380)
+++ mlton/trunk/basis-library/arrays-and-vectors/vector.sig	2006-03-28 21:34:14 UTC (rev 4381)
@@ -46,6 +46,10 @@
       val fields: ('a -> bool) -> 'a vector -> 'a vector list
 
       val append: 'a vector * 'a vector -> 'a vector
+      val create:
+         int * ({sub: int -> 'a, update: int * 'a -> unit}
+                -> (int -> 'a) * (unit -> unit))
+         -> 'a vector
       val duplicate: 'a vector -> 'a vector
       val fromArray: 'a array -> 'a vector
       val toList: 'a vector -> 'a list

Modified: mlton/trunk/basis-library/arrays-and-vectors/vector.sml
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/vector.sml	2006-03-24 23:33:21 UTC (rev 4380)
+++ mlton/trunk/basis-library/arrays-and-vectors/vector.sml	2006-03-28 21:34:14 UTC (rev 4381)
@@ -42,9 +42,37 @@
       val fromArray = Primitive.Vector.fromArray
 
       val vector = new
+
+      fun create (n, f) =
+         let
+            val a = Primitive.Array.array n
+            val subLim = ref 0
+            fun sub i =
+               if Primitive.safe andalso Primitive.Int.geu (i, !subLim) then
+                  raise Subscript
+               else
+                  Primitive.Array.sub (a, i)
+            val updateLim = ref 0
+            fun update (i, x) =
+               if Primitive.safe andalso Primitive.Int.geu (i, !updateLim) then
+                  raise Subscript
+               else
+                  Primitive.Array.update (a, i, x)
+            val (tab, finish) = f {sub = sub, update = update}
+            val () =
+               Util.naturalForeach
+               (n, fn i =>
+                (Primitive.Array.update (a, i, tab i);
+                 subLim := i + 1;
+                 updateLim := i + 1))
+            val () = finish ()
+            val () = updateLim := 0
+         in
+            fromArray a
+         end
    end
 structure VectorSlice: VECTOR_SLICE_EXTRA = Vector.VectorSlice
-
+   
 structure VectorGlobal: VECTOR_GLOBAL = Vector
 open VectorGlobal
 val vector = Vector.fromList

Modified: mlton/trunk/basis-library/misc/primitive.sml
===================================================================
--- mlton/trunk/basis-library/misc/primitive.sml	2006-03-24 23:33:21 UTC (rev 4380)
+++ mlton/trunk/basis-library/misc/primitive.sml	2006-03-28 21:34:14 UTC (rev 4381)
@@ -2262,3 +2262,5 @@
                "unhandled exception in Basis Library\000")))
 in
 end
+
+val op + = Primitive.Int.+

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2006-03-24 23:33:21 UTC (rev 4380)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2006-03-28 21:34:14 UTC (rev 4381)
@@ -102,3 +102,13 @@
                end
          end
    end
+
+local
+   open MLton.Vector
+in
+   fun fib n =
+      Vector.create (n,
+                     fn {sub = fib, ...} =>
+                     (fn i => if i <= 1 then 1 else fib (i - 1) + fib (i - 2),
+                      ignore))
+end

Modified: mlton/trunk/basis-library/mlton/vector.sig
===================================================================
--- mlton/trunk/basis-library/mlton/vector.sig	2006-03-24 23:33:21 UTC (rev 4380)
+++ mlton/trunk/basis-library/mlton/vector.sig	2006-03-28 21:34:14 UTC (rev 4381)
@@ -10,6 +10,10 @@
 
 signature MLTON_VECTOR =
    sig
+      val create:
+         int * ({sub: int -> 'a, update: int * 'a -> unit}
+                -> (int -> 'a) * (unit -> unit))
+         -> 'a vector
       val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
    end
    

[MLton-commit] r4380

[Stephen W. <sw...@ml...>]

Exported some structures from MLton lib:

  Byte, INetSock, Socket, Word8ArraySlice, Word16

A couple of these (Socket, Word8ArraySlice) required wrapping in our
SML/NJ stubs so they deal with 32-bit ints instead of 31-bit.


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

A   mlton/trunk/lib/mlton/basic/inet-sock.sml
A   mlton/trunk/lib/mlton/basic/socket.sml
U   mlton/trunk/lib/mlton/basic/sources.cm
A   mlton/trunk/lib/mlton/basic/word16.sml
A   mlton/trunk/lib/mlton/basic/word8-array-slice.sml
U   mlton/trunk/lib/mlton/pervasive/pervasive.sml
U   mlton/trunk/lib/mlton/sources.cm
U   mlton/trunk/lib/mlton-stubs/sources.cm
U   mlton/trunk/lib/mlton-stubs-in-smlnj/array.sml
U   mlton/trunk/lib/mlton-stubs-in-smlnj/open-int32.sml
A   mlton/trunk/lib/mlton-stubs-in-smlnj/socket.sml
U   mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm

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

Added: mlton/trunk/lib/mlton/basic/inet-sock.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/inet-sock.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/basic/inet-sock.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -0,0 +1 @@
+structure INetSock = INetSock

Added: mlton/trunk/lib/mlton/basic/socket.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/socket.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/basic/socket.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -0,0 +1 @@
+structure Socket = Pervasive.Socket

Modified: mlton/trunk/lib/mlton/basic/sources.cm
===================================================================
--- mlton/trunk/lib/mlton/basic/sources.cm	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/basic/sources.cm	2006-03-24 23:33:21 UTC (rev 4380)
@@ -37,6 +37,7 @@
 structure BinarySearch
 structure Bool
 structure Buffer
+structure Byte
 structure Char
 structure CharArray
 structure CharBuffer
@@ -71,6 +72,7 @@
 structure Int32
 structure IntInf
 structure InsertionSort
+structure INetSock
 structure Iterate
 structure Itimer
 structure Justify
@@ -118,6 +120,7 @@
 structure SMLofNJ
 structure Sexp
 structure Signal
+structure Socket
 structure Stream
 structure String
 structure StringCvt
@@ -137,7 +140,9 @@
 structure Word32
 structure Word8
 structure Word8Array
+structure Word8ArraySlice
 structure Word8Vector
+structure Word16
 
 functor AlphaBeta
 functor Control
@@ -328,6 +333,10 @@
 escape.sml
 buffer.sig
 buffer.sml
+socket.sml
+word16.sml
+inet-sock.sml
+word8-array-slice.sml
 
 # if ( defined(SMLNJ_VERSION) )
 

Added: mlton/trunk/lib/mlton/basic/word16.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/word16.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/basic/word16.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -0,0 +1 @@
+structure Word16 = Pervasive.Word16

Added: mlton/trunk/lib/mlton/basic/word8-array-slice.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/word8-array-slice.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/basic/word8-array-slice.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -0,0 +1 @@
+structure Word8ArraySlice = Word8ArraySlice

Modified: mlton/trunk/lib/mlton/pervasive/pervasive.sml
===================================================================
--- mlton/trunk/lib/mlton/pervasive/pervasive.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/pervasive/pervasive.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -36,6 +36,7 @@
       structure Real = Real
       structure Real32 = Real32
       structure Real64 = Real64
+      structure Socket = Socket
       structure String = String
       structure StringCvt = StringCvt
       structure Substring = Substring
@@ -47,6 +48,7 @@
       structure Word = Word
       structure Word32 = Word32
       structure Word8 = Word8
+      structure Word16 = Word16
       structure Word8Array = Word8Array
 
       type unit = General.unit

Modified: mlton/trunk/lib/mlton/sources.cm
===================================================================
--- mlton/trunk/lib/mlton/sources.cm	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton/sources.cm	2006-03-24 23:33:21 UTC (rev 4380)
@@ -56,6 +56,7 @@
 structure BinarySearch
 structure Bool
 structure Buffer
+structure Byte
 structure Char
 structure CharArray
 structure CharBuffer
@@ -91,6 +92,7 @@
 structure Int32
 structure IntInf
 structure InsertionSort
+structure INetSock
 structure Iterate
 structure Itimer
 structure Justify
@@ -139,6 +141,7 @@
 structure Sexp
 structure Signal
 structure SMLofNJ
+structure Socket
 structure Stream
 structure String
 structure StringCvt
@@ -157,7 +160,9 @@
 structure Word
 structure Word8
 structure Word8Array
+structure Word8ArraySlice
 structure Word8Vector
+structure Word16
 structure Word32
    
 functor AlphaBeta

Modified: mlton/trunk/lib/mlton-stubs/sources.cm
===================================================================
--- mlton/trunk/lib/mlton-stubs/sources.cm	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton-stubs/sources.cm	2006-03-24 23:33:21 UTC (rev 4380)
@@ -29,6 +29,7 @@
 structure Int32
 structure Int64
 structure IntInf
+structure INetSock
 structure IO
 structure LargeInt
 structure LargeReal
@@ -49,6 +50,7 @@
 structure RealVector
 structure SML90
 structure SMLofNJ
+structure Socket
 structure String
 structure StringCvt
 structure Substring
@@ -62,7 +64,9 @@
 structure Word
 structure Word8
 structure Word8Array
+structure Word8ArraySlice
 structure Word8Vector
+structure Word16
 structure Word32
 structure Word64
 

Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/array.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/array.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/array.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -100,3 +100,77 @@
 structure RealArray = MonoArray (RealArray)
 structure Real64Array = RealArray
 structure Word8Array = MonoArray (Word8Array)
+
+functor MonoArraySlice (S: MONO_ARRAY_SLICE) =
+   let
+      open OpenInt32
+   in
+      struct
+         type array = S.array
+         type elem = S.elem
+         type slice = S.slice
+         type vector = S.vector
+         type vector_slice = S.vector_slice
+
+         val all = S.all
+
+         val app = S.app
+
+         fun appi f = S.appi (fn (i, e) => f (fromInt i, e))
+
+         fun base s =
+            let
+               val (a, i, j) = S.base s
+            in
+               (a, fromInt i, fromInt j)
+            end
+         
+         val collate = S.collate
+
+         fun copy {di, dst, src} = S.copy {di = toInt di, dst = dst, src = src}
+
+         fun copyVec {di, dst, src} =
+            S.copyVec {di = toInt di, dst = dst, src = src}
+
+         val exists = S.exists
+
+         val find = S.find
+
+         fun findi f s =
+            case S.findi (fn (i, e) => f (fromInt i, e)) s of
+               NONE => NONE
+             | SOME (i, e) => SOME (fromInt i, e)
+                  
+         val foldl = S.foldl
+            
+         fun foldli f = S.foldli (fn (i, e, b) => f (fromInt i, e, b))
+            
+         val foldr = S.foldr
+
+         fun foldri f = S.foldri (fn (i, e, b) => f (fromInt i, e, b))
+
+         val full = S.full
+
+         val getItem = S.getItem
+
+         val isEmpty = S.isEmpty
+
+         val length = fromInt o S.length
+
+         val modify = S.modify
+
+         fun modifyi f = S.modifyi (fn (i, e) => f (fromInt i, e))
+
+         fun slice (a, i, j) = S.slice (a, toInt i, toIntOpt j)
+            
+         fun sub (s, i) = S.sub (s, toInt i)
+            
+         fun subslice (s, i, j) = S.subslice (s, toInt i, toIntOpt j)
+
+         fun update (s, i, e) = S.update (s, toInt i, e)
+
+         val vector = S.vector
+      end
+   end
+
+structure Word8ArraySlice = MonoArraySlice (Word8ArraySlice)

Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/open-int32.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/open-int32.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/open-int32.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -10,6 +10,9 @@
    struct
       val toInt = Pervasive.Int32.toInt
       val fromInt = Pervasive.Int32.fromInt
+      val fromIntOpt =
+         fn NONE => NONE
+          | SOME i => SOME (fromInt i)
       val toIntOpt =
          fn NONE => NONE
           | SOME i => SOME (toInt i)

Added: mlton/trunk/lib/mlton-stubs-in-smlnj/socket.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/socket.sml	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/socket.sml	2006-03-24 23:33:21 UTC (rev 4380)
@@ -0,0 +1,83 @@
+structure Socket =
+   let
+      structure S = Socket
+      open OpenInt32
+   in
+      struct
+         open Socket
+            
+         structure Ctl =
+            struct
+               open Ctl
+
+               val getNREAD = fn z => (fromInt o getNREAD) z
+
+               val getRCVBUF = fn z => (fromInt o getRCVBUF) z
+
+               val getSNDBUF = fn z => (fromInt o getSNDBUF) z
+
+               val setRCVBUF =
+                  fn z => (setRCVBUF o (fn (s, i) => (s, toInt i))) z
+
+               val setSNDBUF =
+                  fn z => (setSNDBUF o (fn (s, i) => (s, toInt i))) z
+            end
+         
+         val listen = fn z => (listen o (fn (s, i) => (s, toInt i))) z
+
+         val recvArr = fn z => (fromInt o recvArr) z
+
+         val recvArr' = fn z => (fromInt o recvArr') z
+
+         val recvArrFrom =
+            fn z => ((fn (i, a) => (fromInt i, a)) o recvArrFrom) z
+
+         val recvArrFrom' =
+            fn z => ((fn (i, a) => (fromInt i, a)) o recvArrFrom') z
+
+         val recvArrFromNB =
+            fn z => ((fn NONE => NONE | SOME (i, a) => SOME (fromInt i, a))
+                     o recvArrFromNB) z
+
+         val recvArrFromNB' =
+            fn z => ((fn NONE => NONE | SOME (i, a) => SOME (fromInt i, a))
+                     o recvArrFromNB') z
+
+         val recvArrNB = fn z => (fromIntOpt o recvArrNB) z
+
+         val recvArrNB' = fn z => (fromIntOpt o recvArrNB') z
+
+         val recvVec = fn z => (recvVec o (fn (s, i) => (s, toInt i))) z
+
+         val recvVec' = fn z => (recvVec' o (fn (s, i, f) => (s, toInt i, f))) z
+
+         val recvVecFrom = fn z => (recvVecFrom o (fn (s, i) => (s, toInt i))) z
+
+         val recvVecFrom' =
+            fn z => (recvVecFrom' o (fn (s, i, f) => (s, toInt i, f))) z
+
+         val recvVecFromNB =
+            fn z => (recvVecFromNB o (fn (s, i) => (s, toInt i))) z
+
+         val recvVecFromNB' =
+            fn z => (recvVecFromNB' o (fn (s, i, f) => (s, toInt i, f))) z
+
+         val recvVecNB = fn z => (recvVecNB o (fn (s, i) => (s, toInt i))) z
+
+         val sendArr = fn z => (fromInt o sendArr) z
+
+         val sendArr' = fn z => (fromInt o sendArr') z
+
+         val sendArrNB = fn z => (fromIntOpt o sendArrNB) z
+
+         val sendArrNB' = fn z => (fromIntOpt o sendArrNB') z
+
+         val sendVec = fn z => (fromInt o sendVec) z
+
+         val sendVec' = fn z => (fromInt o sendVec') z
+
+         val sendVecNB = fn z => (fromIntOpt o sendVecNB) z
+
+         val sendVecNB' = fn z => (fromIntOpt o sendVecNB') z
+      end
+   end

Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm	2006-03-13 22:27:22 UTC (rev 4379)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm	2006-03-24 23:33:21 UTC (rev 4380)
@@ -31,6 +31,7 @@
 structure Int32
 structure Int64
 structure IntInf
+structure INetSock
 structure IO
 structure LargeInt
 structure LargeReal
@@ -68,6 +69,7 @@
 structure Word32
 structure Word64
 structure Word8Array
+structure Word8ArraySlice
 structure Word8Vector
 
 is
@@ -92,6 +94,7 @@
 other.sml
 posix.sml
 real.sml
+socket.sml
 string-cvt.sml
 string.sml
 substring.sml

[MLton-commit] r4379

[Stephen W. <sw...@ml...>]

Made Int.{fmt,toString} thread safe.

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

U   mlton/trunk/basis-library/integer/int.sml
U   mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb
A   mlton/trunk/basis-library/misc/one.sml

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

Modified: mlton/trunk/basis-library/integer/int.sml
===================================================================
--- mlton/trunk/basis-library/integer/int.sml	2006-03-13 00:42:43 UTC (rev 4378)
+++ mlton/trunk/basis-library/integer/int.sml	2006-03-13 22:27:22 UTC (rev 4379)
@@ -119,40 +119,42 @@
     * The most that will be required is for minInt in binary.
     *)
    val maxNumDigits = PI.+ (precision', 1)
-   val buf = CharArray.array (maxNumDigits, #"\000")
+   val one = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
 in
    fun fmt radix (n: int): string =
-      let
-         val radix = fromInt (StringCvt.radixToInt radix)
-         fun loop (q, i: Int.int) =
-            let
-               val _ =
-                  CharArray.update
-                  (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix)))))
-               val q = quot (q, radix)
-            in
-               if q = zero
-                  then
-                     let
-                        val start =
-                           if n < zero
-                              then
-                                 let
-                                    val i = PI.- (i, 1)
-                                    val () = CharArray.update (buf, i, #"~")
-                                 in
-                                    i
-                                 end
-                           else i
-                     in
-                        CharArraySlice.vector
-                        (CharArraySlice.slice (buf, start, NONE))
-                     end
-               else loop (q, PI.- (i, 1))
-            end
-      in
-         loop (if n < zero then n else ~? n, PI.- (maxNumDigits, 1))
-      end
+      One.use
+      (one, fn buf =>
+       let
+          val radix = fromInt (StringCvt.radixToInt radix)
+          fun loop (q, i: Int.int) =
+             let
+                val _ =
+                   CharArray.update
+                   (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix)))))
+                val q = quot (q, radix)
+             in
+                if q = zero
+                   then
+                      let
+                         val start =
+                            if n < zero
+                               then
+                                  let
+                                     val i = PI.- (i, 1)
+                                     val () = CharArray.update (buf, i, #"~")
+                                  in
+                                     i
+                                  end
+                            else i
+                      in
+                         CharArraySlice.vector
+                         (CharArraySlice.slice (buf, start, NONE))
+                      end
+                else loop (q, PI.- (i, 1))
+             end
+       in
+          loop (if n < zero then n else ~? n, PI.- (maxNumDigits, 1))
+       end)
 end      
 
 val toString = fmt StringCvt.DEC

Modified: mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb	2006-03-13 00:42:43 UTC (rev 4378)
+++ mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb	2006-03-13 22:27:22 UTC (rev 4379)
@@ -20,6 +20,7 @@
       ../../misc/dynamic-wind.sml
       ../../general/general.sig
       ../../general/general.sml
+      ../../misc/one.sml
       ../../misc/util.sml
       ../../general/option.sig
       ../../general/option.sml

Added: mlton/trunk/basis-library/misc/one.sml
===================================================================
--- mlton/trunk/basis-library/misc/one.sml	2006-03-13 00:42:43 UTC (rev 4378)
+++ mlton/trunk/basis-library/misc/one.sml	2006-03-13 22:27:22 UTC (rev 4379)
@@ -0,0 +1,35 @@
+structure One:
+   sig
+      type 'a t
+
+      val make: (unit -> 'a) -> 'a t
+      val use: 'a t * ('a -> 'b) -> 'b
+   end =
+   struct
+      datatype 'a t = T of {more: unit -> 'a,
+                            static: 'a,
+                            staticIsInUse: bool ref}
+
+      fun make f = T {more = f,
+                      static = f (),
+                      staticIsInUse = ref false}
+
+      fun use (T {more, static, staticIsInUse}, f) =
+         let
+            val () = Primitive.Thread.atomicBegin ()
+            val b = ! staticIsInUse
+            val d =
+               if b then
+                  (Primitive.Thread.atomicEnd ();
+                   more ())
+               else
+                  (staticIsInUse := true;
+                   Primitive.Thread.atomicEnd ();
+                   static)
+        in
+           DynamicWind.wind (fn () => f d,
+                             fn () => if b then () else staticIsInUse := false)
+        end
+
+   end
+  

[MLton-commit] r4378

[Matthew F. <fl...@ml...>]

A little more work on Real
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real-global.sml
U   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
U   mlton/branches/on-20050822-x86_64-branch/runtime/basis/Int/Word.c

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

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-03-06 01:54:59 UTC (rev 4377)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb	2006-03-13 00:42:43 UTC (rev 4378)
@@ -159,11 +159,17 @@
    (* ../../misc/C.sml *)
    ../real/math.sig
    ../real/real.sig
-   (* ../../real/real.fun *)
+   ../real/real.fun
    ../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
 
 (*
    local 

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml	2006-03-06 01:54:59 UTC (rev 4377)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml	2006-03-13 00:42:43 UTC (rev 4378)
@@ -18,7 +18,7 @@
 
       structure Class :
          sig
-            type t
+            eqtype t
             val inf: t
             val nan: t
             val normal: t
@@ -74,21 +74,21 @@
       val strto: Primitive.NullString8.t -> real
       val ~ : real -> real
 
-      val fromInt8: Primitive.Int8.int -> real
-      val fromInt16: Primitive.Int16.int -> real
-      val fromInt32: Primitive.Int32.int -> real
-      val fromInt64: Primitive.Int64.int -> real
+      val fromInt8Unsafe: Primitive.Int8.int -> real
+      val fromInt16Unsafe: Primitive.Int16.int -> real
+      val fromInt32Unsafe: Primitive.Int32.int -> real
+      val fromInt64Unsafe: Primitive.Int64.int -> real
 
-      val fromReal32: Primitive.Real32.real -> real
-      val fromReal64: Primitive.Real64.real -> real
+      val fromReal32Unsafe: Primitive.Real32.real -> real
+      val fromReal64Unsafe: Primitive.Real64.real -> real
 
-      val toInt8: real -> Primitive.Int8.int
-      val toInt16: real -> Primitive.Int16.int
-      val toInt32: real -> Primitive.Int32.int
-      val toInt64: real -> Primitive.Int64.int
+      val toInt8Unsafe: real -> Primitive.Int8.int
+      val toInt16Unsafe: real -> Primitive.Int16.int
+      val toInt32Unsafe: real -> Primitive.Int32.int
+      val toInt64Unsafe: real -> Primitive.Int64.int
 
-      val toReal32: real -> Primitive.Real32.real
-      val toReal64: real -> Primitive.Real64.real
+      val toReal32Unsafe: real -> Primitive.Real32.real
+      val toReal64Unsafe: real -> Primitive.Real64.real
    end
 
 structure Primitive = struct
@@ -161,27 +161,27 @@
       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 nextAfter = _import "Real64_nextAfter": real * real -> real;
-      val round = _prim "Real64_round": real -> real;
+      val nextAfter = _import "Real32_nextAfter": real * real -> real;
+      val round = _prim "Real32_round": real -> real;
       val signBit = _import "Real32_signBit": real -> C_Int.int;
       val strto = _import "Real32_strto": NullString8.t -> real;
       val ~ = _prim "Real32_neg": real -> real;
 
-      val fromInt8 = _prim "WordS8_toReal32": Int8.int -> real;
-      val fromInt16 = _prim "WordS16_toReal32": Int16.int -> real;
-      val fromInt32 = _prim "WordS32_toReal32": Int32.int -> real;
-      val fromInt64 = _prim "WordS64_toReal32": Int64.int -> real;
+      val fromInt8Unsafe = _prim "WordS8_toReal32": Int8.int -> real;
+      val fromInt16Unsafe = _prim "WordS16_toReal32": Int16.int -> real;
+      val fromInt32Unsafe = _prim "WordS32_toReal32": Int32.int -> real;
+      val fromInt64Unsafe = _prim "WordS64_toReal32": Int64.int -> real;
 
-      val fromReal32 = _prim "Real32_toReal32": Real32.real -> real;
-      val fromReal64 = _prim "Real64_toReal32": Real64.real -> real;
+      val fromReal32Unsafe = _prim "Real32_toReal32": Real32.real -> real;
+      val fromReal64Unsafe = _prim "Real64_toReal32": Real64.real -> real;
 
-      val toInt8 = _prim "Real32_toWordS8": real -> Int8.int;
-      val toInt16 = _prim "Real32_toWordS16": real -> Int16.int;
-      val toInt32 = _prim "Real32_toWordS32": real -> Int32.int;
-      val toInt64 = _prim "Real32_toWordS64": real -> Int64.int;
+      val toInt8Unsafe = _prim "Real32_toWordS8": real -> Int8.int;
+      val toInt16Unsafe = _prim "Real32_toWordS16": real -> Int16.int;
+      val toInt32Unsafe = _prim "Real32_toWordS32": real -> Int32.int;
+      val toInt64Unsafe = _prim "Real32_toWordS64": real -> Int64.int;
 
-      val toReal32 = _prim "Real32_toReal32": real -> Real32.real;
-      val toReal64 = _prim "Real32_toReal64": real -> Real64.real;
+      val toReal32Unsafe = _prim "Real32_toReal32": real -> Real32.real;
+      val toReal64Unsafe = _prim "Real32_toReal64": real -> Real64.real;
    end
 structure Real32 =
    struct
@@ -250,21 +250,21 @@
       val strto = _import "Real64_strto": NullString8.t -> real;
       val ~ = _prim "Real64_neg": real -> real;
 
-      val fromInt8 = _prim "WordS8_toReal64": Int8.int -> real;
-      val fromInt16 = _prim "WordS16_toReal64": Int16.int -> real;
-      val fromInt32 = _prim "WordS32_toReal64": Int32.int -> real;
-      val fromInt64 = _prim "WordS64_toReal64": Int64.int -> real;
+      val fromInt8Unsafe = _prim "WordS8_toReal64": Int8.int -> real;
+      val fromInt16Unsafe = _prim "WordS16_toReal64": Int16.int -> real;
+      val fromInt32Unsafe = _prim "WordS32_toReal64": Int32.int -> real;
+      val fromInt64Unsafe = _prim "WordS64_toReal64": Int64.int -> real;
 
-      val fromReal32 = _prim "Real32_toReal64": Real32.real -> real;
-      val fromReal64 = _prim "Real64_toReal64": Real64.real -> real;
+      val fromReal32Unsafe = _prim "Real32_toReal64": Real32.real -> real;
+      val fromReal64Unsafe = _prim "Real64_toReal64": Real64.real -> real;
 
-      val toInt8 = _prim "Real64_toWordS8": real -> Int8.int;
-      val toInt16 = _prim "Real64_toWordS16": real -> Int16.int;
-      val toInt32 = _prim "Real64_toWordS32": real -> Int32.int;
-      val toInt64 = _prim "Real64_toWordS64": real -> Int64.int;
+      val toInt8Unsafe = _prim "Real64_toWordS8": real -> Int8.int;
+      val toInt16Unsafe = _prim "Real64_toWordS16": real -> Int16.int;
+      val toInt32Unsafe = _prim "Real64_toWordS32": real -> Int32.int;
+      val toInt64Unsafe = _prim "Real64_toWordS64": real -> Int64.int;
 
-      val toReal32 = _prim "Real64_toReal32": real -> Real32.real;
-      val toReal64 = _prim "Real64_toReal64": real -> Real64.real;
+      val toReal32Unsafe = _prim "Real64_toReal32": real -> Real32.real;
+      val toReal64Unsafe = _prim "Real64_toReal64": real -> Real64.real;
    end
 structure Real64 =
    struct

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real-global.sml (from rev 4377, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-global.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-global.sml	2006-03-06 01:54:59 UTC (rev 4377)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real-global.sml	2006-03-13 00:42:43 UTC (rev 4378)
@@ -0,0 +1,10 @@
+(* 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 RealGlobal: REAL_GLOBAL = Real
+open RealGlobal

Modified: 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-03-06 01:54:59 UTC (rev 4377)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun	2006-03-13 00:42:43 UTC (rev 4378)
@@ -5,7 +5,7 @@
  * See the file MLton-LICENSE for details.
  *)
 
-functor Real (R: PRE_REAL): REAL =
+functor Real (R: PRE_REAL)(*: REAL*) =
    struct
       structure MLton = Primitive.MLton
       structure Prim = R
@@ -16,7 +16,7 @@
          datatype rounding_mode = datatype rounding_mode
       end
       infix 4 == != ?=
-      type real = Prim.real
+      type real = R.real
 
       local
          open Prim
@@ -41,21 +41,22 @@
          val op >= = op >=
          val ~ = ~
          val abs = abs
-         val fromInt = fromInt
-         val fromLarge = fromLarge
+
          val maxFinite = maxFinite
          val minNormalPos = minNormalPos
          val minPos = minPos
-         val precision = precision
-         val radix = radix
+
+         val precision = Primitive.Int32.toInt precision
+         val radix = Primitive.Int32.toInt radix
+
          val signBit = fn r => signBit r <> 0
-         val toLarge = toLarge
       end
 
-      val zero = fromLarge TO_NEAREST 0.0
-      val one = fromLarge TO_NEAREST 1.0
+      val zero = R.fromInt32Unsafe 0
+      val one = R.fromInt32Unsafe 1
+      val two = R.fromInt32Unsafe 2
+
       val negOne = ~ one
-      val two = fromLarge TO_NEAREST 2.0
       val half = one / two
 
       val posInf = one / zero
@@ -66,10 +67,10 @@
       local
          val classes =
             let
-               open Primitive.Real64.Class
+               open R.Class
             in
-               (* order here is chosen based on putting the more commonly used
-                * classes at the front.
+               (* order here is chosen based on putting the more
+                * commonly used classes at the front.  
                 *)
                [(normal, NORMAL),
                 (zero, ZERO),
@@ -80,7 +81,7 @@
       in
          fun class x =
             let
-               val i = Prim.class x
+               val i = R.class x
             in
                case List.find (fn (i', _) => i = i') classes of
                   NONE => raise Fail "Real_class returned bogus integer"
@@ -114,20 +115,20 @@
             (NAN, _) => false
           | (_, NAN) => false
           | (ZERO, ZERO) => true
-          | _ => Prim.== (x, y)
+          | _ => R.== (x, y)
 
       val op != = not o op ==
 
       val op ?= =
          if MLton.Codegen.isNative
-            then Prim.?=
+            then R.?=
          else
             fn (x, y) =>
             case (class x, class y) of
                (NAN, _) => true
              | (_, NAN) => true
              | (ZERO, ZERO) => true
-             | _ => Prim.== (x, y)
+             | _ => R.== (x, y)
 
       fun min (x, y) =
          if isNan x
@@ -200,32 +201,31 @@
                         if r == maxFinite andalso t == posInf
                            then posInf
                         else if r > t
-                                then R.nextAfterDown r
-                             else R.nextAfterUp r
+                                then R.nextAfter (r, negInf)
+                             else R.nextAfter (r, posInf)
                   in
                      if r > zero
                         then doit (r, t)
                      else ~ (doit (~r, ~t))
                   end
                          
-      val toManExp =
-         let
-            val r: int ref = ref 0
-         in
-            fn x =>
-            case class x of
-               INF => {exp = 0, man = x}
-             | NAN => {exp = 0, man = nan}
-             | ZERO => {exp = 0, man = x}
-             | _ => 
-                  let
-                     val man = Prim.frexp (x, r)
-                  in
-                     {exp = !r, man = man}
-                  end
-         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} = Prim.ldexp (man, exp)
+      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
@@ -238,31 +238,28 @@
              | ZERO => man
              | _ => fromManExp {exp = exp, man = man}
 
-      local
-         val int = 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}
-             | _ => 
-                  let
-                     val frac = Prim.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
+      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
-      end
-
+               in
+                  {frac = fix frac,
+                   whole = fix whole}
+               end
+            
       val realMod = #frac o split
          
       fun checkFloat x =
@@ -270,47 +267,123 @@
             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
 
-      val maxInt = fromInt Int.maxInt'
-      val minInt = fromInt Int.minInt'
+      fun roundReal (x: real, m: rounding_mode): real =
+         IEEEReal.withRoundingMode (m, fn () => R.round x)
 
-      fun roundReal (x: real, m: rounding_mode): real =
-         fromLarge
-         TO_NEAREST
-         (IEEEReal.withRoundingMode (m, fn () =>
-                                     (Primitive.Real64.round (toLarge x))))
-         
-      fun toInt mode x =
-         case class x of
-            INF => raise Overflow
-          | NAN => raise Domain
-          | _ =>
-               if minInt <= x
-                  then if x <= maxInt
-                          then Prim.toInt (roundReal (x, mode))
-                       else if x < maxInt + one
-                               then (case mode of
-                                        TO_NEGINF => Int.maxInt'
-                                      | TO_POSINF => raise Overflow
-                                      | TO_ZERO => Int.maxInt'
-                                      | TO_NEAREST =>
-                                           (* Depends on maxInt being odd. *)
-                                           if x - maxInt >= half
-                                              then raise Overflow
-                                           else Int.maxInt')
-                            else raise Overflow
-               else if x > minInt - one
-                       then (case mode of
-                                TO_NEGINF => raise Overflow
-                              | TO_POSINF => Int.minInt'
-                              | TO_ZERO => Int.minInt'
-                              | TO_NEAREST =>
-                                   (* Depends on minInt being even. *)
-                                   if x - minInt < ~half
-                                      then raise Overflow
-                                   else Int.minInt')
-                    else raise Overflow
-      
+      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
@@ -779,4 +852,8 @@
                 | 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-03-06 01:54:59 UTC (rev 4377)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig	2006-03-13 00:42:43 UTC (rev 4378)
@@ -8,6 +8,16 @@
   sig
       include PRE_REAL_GLOBAL
 
+      structure Class :
+         sig
+            eqtype t
+            val inf: t
+            val nan: t
+            val normal: t
+            val subnormal: t
+            val zero: t
+         end
+
       val * : real * real -> real
       val *+ : real * real * real -> real
       val *- : real * real * real -> real
@@ -22,24 +32,47 @@
       val ?= : real * real -> bool
       val ~ : real -> real
       val abs: real -> real
-      val class: real -> int
-      val frexp: real * int ref -> real
-      val gdtoa: real * int * int * int ref -> C_String.t
-      val fromInt: int -> real
-      val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
-      val ldexp: real * int -> real
+
       val maxFinite: real
       val minNormalPos: real
       val minPos: real
+
+      val precision: Primitive.Int32.int
+      val radix: Primitive.Int32.int
+
+      val signBit: real -> C_Int.t
+
+      val class: real -> Class.t
+
+      val nextAfter: real * real -> real
+
+      val frexp: real * C_Int.int ref -> real
+      val ldexp: real * C_Int.int -> real
       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 precision: int
-      val radix: int
-      val signBit: real -> int
       val strto: NullString.t -> real
-      val toInt: real -> int
-      val toLarge: real -> LargeReal.real        
+*)
+
+      val fromInt8Unsafe: Primitive.Int8.int -> real
+      val fromInt16Unsafe: Primitive.Int16.int -> real
+      val fromInt32Unsafe: Primitive.Int32.int -> real
+      val fromInt64Unsafe: Primitive.Int64.int -> real
+
+      val fromReal32Unsafe: Primitive.Real32.real -> real
+      val fromReal64Unsafe: Primitive.Real64.real -> real
+
+      val toInt8Unsafe: real -> Primitive.Int8.int
+      val toInt16Unsafe: real -> Primitive.Int16.int
+      val toInt32Unsafe: real -> Primitive.Int32.int
+      val toInt64Unsafe: real -> Primitive.Int64.int
+
+      val toReal32Unsafe: real -> Primitive.Real32.real
+      val toReal64Unsafe: real -> Primitive.Real64.real
   end
 
 signature REAL_GLOBAL =

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/basis/Int/Word.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/basis/Int/Word.c	2006-03-06 01:54:59 UTC (rev 4377)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/basis/Int/Word.c	2006-03-13 00:42:43 UTC (rev 4378)
@@ -139,8 +139,8 @@
         }
 
 #define shift(kind, name, op)                                           \
-        Word##kind Word##kind##_##name (Word##kind w1, Word w2);        \
-        Word##kind Word##kind##_##name (Word##kind w1, Word w2) {       \
+        Word##kind Word##kind##_##name (Word##kind w1, Word32 w2);      \
+        Word##kind Word##kind##_##name (Word##kind w1, Word32 w2) {     \
                 return w1 op w2;                                        \
         }
 
@@ -163,12 +163,12 @@
         bothBinary (size, quot, /)                              \
         SmulCheckOverflows (size)                               \
         bothBinary (size, rem, %)                               \
-        Word##size Word##size##_rol (Word##size w1, Word w2);   \
-        Word##size Word##size##_rol (Word##size w1, Word w2) {  \
+        Word##size Word##size##_rol (Word##size w1, Word32 w2); \
+        Word##size Word##size##_rol (Word##size w1, Word32 w2) {\
                 return (w1 >> (size - w2)) | (w1 << w2);        \
         }                                                       \
-        Word##size Word##size##_ror (Word##size w1, Word w2);   \
-        Word##size Word##size##_ror (Word##size w1, Word w2) {  \
+        Word##size Word##size##_ror (Word##size w1, Word32 w2); \
+        Word##size Word##size##_ror (Word##size w1, Word32 w2) {\
                 return (w1 >> w2) | (w1 << (size - w2));        \
         }                                                       \
         shift (S##size, rshift, >>)                             \

[MLton-commit] r4377

[Matthew F. <fl...@ml...>]

License for MLRISC Library
----------------------------------------------------------------------

U   mlton/trunk/doc/license/README

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

Modified: mlton/trunk/doc/license/README
===================================================================
--- mlton/trunk/doc/license/README	2006-03-04 19:37:37 UTC (rev 4376)
+++ mlton/trunk/doc/license/README	2006-03-06 01:54:59 UTC (rev 4377)
@@ -12,6 +12,7 @@
                                                 Concurrent ML Library
                                                 CKit Library
                                                 mlnlffigen and MLNLFFI Library
+                                                MLRISC Library
 
 SML/NJ Lib	SMLNJ-LIB-LICENSE (BSD-style) 	SML/NJ Library
 

[MLton-commit] r4376

[Matthew F. <fl...@ml...>]

Preliminary work on real
----------------------------------------------------------------------

A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.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/util/real-comparisons.sml

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

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml (from rev 4371, 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-03-03 22:10:55 UTC (rev 4371)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml	2006-03-04 19:37:37 UTC (rev 4376)
@@ -0,0 +1,281 @@
+(* 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. *)
+
+signature PRIM_REAL =
+   sig
+      type real
+      type t = real
+
+      val precision: Primitive.Int32.int
+      val radix: Primitive.Int32.int
+
+      structure Class :
+         sig
+            type t
+            val inf: t
+            val nan: t
+            val normal: t
+            val subnormal: t
+            val zero: t
+         end
+
+      structure Math :
+         sig
+            type real
+
+            val acos: real -> real
+            val asin: real -> real
+            val atan: real -> real
+            val atan2: real * real -> real
+            val cos: real -> real
+            val cosh: real -> real
+            val e: real
+            val exp: real -> real
+            val ln: real -> real
+            val log10: real -> real
+            val pi: real
+            val pow: real * real -> real
+            val sin: real -> real
+            val sinh: real -> real
+            val sqrt: real -> real
+            val tan: real -> real
+            val tanh: real -> real
+         end
+
+      val * : real * real -> real
+      val *+ : real * real * real -> real
+      val *- : real * real * real -> real
+      val + : real * real -> real
+      val - : real * real -> real
+      val / : real * real -> real
+      val < : real * real -> bool
+      val <= : real * real -> bool
+      val == : real * real -> bool
+      val ?= : real * real -> bool
+      val abs: real -> real
+      val class: real -> Class.t
+      val frexp: real * C_Int.int ref -> real
+      val gdtoa: real * C_Int.int * C_Int.int * C_Int.int ref -> C_String.t
+      val ldexp: real * C_Int.int -> real
+      val maxFinite: real
+      val minNormalPos: real
+      val minPos: real
+      val modf: real * real ref -> real
+      val nextAfter: real * real -> real
+      val round: real -> real
+      val signBit: real -> C_Int.int
+      val strto: Primitive.NullString8.t -> real
+      val ~ : real -> real
+
+      val fromInt8: Primitive.Int8.int -> real
+      val fromInt16: Primitive.Int16.int -> real
+      val fromInt32: Primitive.Int32.int -> real
+      val fromInt64: Primitive.Int64.int -> real
+
+      val fromReal32: Primitive.Real32.real -> real
+      val fromReal64: Primitive.Real64.real -> real
+
+      val toInt8: real -> Primitive.Int8.int
+      val toInt16: real -> Primitive.Int16.int
+      val toInt32: real -> Primitive.Int32.int
+      val toInt64: real -> Primitive.Int64.int
+
+      val toReal32: real -> Primitive.Real32.real
+      val toReal64: real -> Primitive.Real64.real
+   end
+
+structure Primitive = struct
+
+open Primitive
+
+local
+
+   structure Class =
+      struct
+         type t = C_Int.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
+
+in
+
+structure Real32 =
+   struct
+      open Real32
+         
+      val precision : Int32.int = 24
+      val radix : Int32.int = 2
+
+      structure Class = Class
+         
+      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 = _import "coshf": real -> real;
+            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 = _import "powf": real * real -> real;
+            val sin = _prim "Real32_Math_sin": real -> real;
+            val sinh = _import "sinhf": real -> real;
+            val sqrt = _prim "Real32_Math_sqrt": real -> real;
+            val tan = _prim "Real32_Math_tan": real -> real;
+            val tanh = _import "tanhf": real -> real;
+         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 -> Class.t;
+      val frexp = _import "Real32_frexp": real * C_Int.int ref -> real;
+      val gdtoa = _import "Real32_gdtoa": real * C_Int.int * C_Int.int * C_Int.int ref -> C_String.t;
+      val ldexp = _prim "Real32_ldexp": real * C_Int.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 nextAfter = _import "Real64_nextAfter": real * real -> real;
+      val round = _prim "Real64_round": real -> real;
+      val signBit = _import "Real32_signBit": real -> C_Int.int;
+      val strto = _import "Real32_strto": NullString8.t -> real;
+      val ~ = _prim "Real32_neg": real -> real;
+
+      val fromInt8 = _prim "WordS8_toReal32": Int8.int -> real;
+      val fromInt16 = _prim "WordS16_toReal32": Int16.int -> real;
+      val fromInt32 = _prim "WordS32_toReal32": Int32.int -> real;
+      val fromInt64 = _prim "WordS64_toReal32": Int64.int -> real;
+
+      val fromReal32 = _prim "Real32_toReal32": Real32.real -> real;
+      val fromReal64 = _prim "Real64_toReal32": Real64.real -> real;
+
+      val toInt8 = _prim "Real32_toWordS8": real -> Int8.int;
+      val toInt16 = _prim "Real32_toWordS16": real -> Int16.int;
+      val toInt32 = _prim "Real32_toWordS32": real -> Int32.int;
+      val toInt64 = _prim "Real32_toWordS64": real -> Int64.int;
+
+      val toReal32 = _prim "Real32_toReal32": real -> Real32.real;
+      val toReal64 = _prim "Real32_toReal64": real -> Real64.real;
+   end
+structure Real32 =
+   struct
+      open Real32
+      local
+         structure S = RealComparisons (Real32)
+      in
+         open S
+      end
+   end
+
+structure Real64 =
+   struct
+      open Real64
+
+      val precision : Int32.int = 53
+      val radix : Int32.int = 2
+         
+      structure Class = Class
+            
+      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 -> Class.t;
+      val frexp = _import "Real64_frexp": real * C_Int.int ref -> real;
+      val gdtoa = _import "Real64_gdtoa": real * C_Int.int * C_Int.int * C_Int.int ref -> C_String.t;
+      val ldexp = _prim "Real64_ldexp": real * C_Int.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 -> C_Int.int;
+      val strto = _import "Real64_strto": NullString8.t -> real;
+      val ~ = _prim "Real64_neg": real -> real;
+
+      val fromInt8 = _prim "WordS8_toReal64": Int8.int -> real;
+      val fromInt16 = _prim "WordS16_toReal64": Int16.int -> real;
+      val fromInt32 = _prim "WordS32_toReal64": Int32.int -> real;
+      val fromInt64 = _prim "WordS64_toReal64": Int64.int -> real;
+
+      val fromReal32 = _prim "Real32_toReal64": Real32.real -> real;
+      val fromReal64 = _prim "Real64_toReal64": Real64.real -> real;
+
+      val toInt8 = _prim "Real64_toWordS8": real -> Int8.int;
+      val toInt16 = _prim "Real64_toWordS16": real -> Int16.int;
+      val toInt32 = _prim "Real64_toWordS32": real -> Int32.int;
+      val toInt64 = _prim "Real64_toWordS64": real -> Int64.int;
+
+      val toReal32 = _prim "Real64_toReal32": real -> Real32.real;
+      val toReal64 = _prim "Real64_toReal64": real -> Real64.real;
+   end
+structure Real64 =
+   struct
+      open Real64
+      local
+         structure S = RealComparisons (Real64)
+      in
+         open S
+      end
+   end
+
+end
+
+end

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-03-04 18:39:11 UTC (rev 4375)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb	2006-03-04 19:37:37 UTC (rev 4376)
@@ -21,9 +21,7 @@
    end 
    ../util/integral-comparisons.sml
    ../util/string-comparisons.sml
-   prim-char.sml
-   prim-word.sml
-   prim-int.sml
+   ../util/real-comparisons.sml
    local 
       ../config/bind/char-prim.sml 
       ../config/bind/int-prim.sml 
@@ -34,6 +32,10 @@
    in ann "forceUsed" in
       ../config/choose.sml
    end end
+
+   prim-word.sml
+   prim-int.sml
+
    local 
       ../config/bind/int-prim.sml 
       ../config/bind/pointer-prim.sml 
@@ -45,11 +47,18 @@
       ../config/seq/$(SEQ_INDEX)
       ../config/c/misc/$(CTYPES)
    end end
+   prim-seq.sml
+   prim-nullstring.sml
+
    prim-intinf.sml
-   prim-seq.sml
+
+   prim-char.sml
    prim-string.sml
-   prim-nullstring.sml
+
+   prim-real.sml
+
    prim-mlton.sml
+
    basis-ffi.sml
    prim2.sml
 end

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/real-comparisons.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/real-comparisons.sml	2006-03-04 18:39:11 UTC (rev 4375)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/real-comparisons.sml	2006-03-04 19:37:37 UTC (rev 4376)
@@ -5,21 +5,6 @@
  * See the file MLton-LICENSE for details.
  *)
 
-functor Comparisons (type t
-                     val < : t * t -> bool) =
-   struct
-      val < = <
-      fun <= (a, b) = not (< (b, a))
-      fun > (a, b) = < (b, a)
-      fun >= (a, b) = <= (b, a)
-
-      fun compare (i, j) =
-         if i < j then LESS
-         else if j < i then GREATER
-         else EQUAL
-      fun min (x, y) = if x < y then x else y
-      fun max (x, y) = if x < y then y else x
-   end
 functor RealComparisons (type t
                          val < : t * t -> bool
                          val <= : t * t -> bool) =
@@ -27,19 +12,3 @@
       fun > (a, b) = < (b, a)
       fun >= (a, b) = <= (b, a)
    end
-functor UnsignedComparisons (type int
-                             type word
-                             val fromInt : int -> word
-                             val < : word * word -> bool) =
-   struct
-      local
-         fun ltu (i: int, i': int) = < (fromInt i, fromInt i')
-         structure S = Comparisons (type t = int 
-                                    val < = ltu)
-      in
-         val ltu = S.<
-         val leu = S.<=
-         val gtu = S.>
-         val geu = S.>=
-      end
-   end

[MLton-commit] r4375

[Matthew F. <fl...@ml...>]

Report exception history for debugging
----------------------------------------------------------------------

A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/exn.sml

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

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/exn.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/exn.sml	2006-03-04 18:30:37 UTC (rev 4374)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/exn.sml	2006-03-04 18:39:11 UTC (rev 4375)
@@ -0,0 +1,160 @@
+structure COld =
+   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 = Primitive.Array.arrayUnsafe n
+            fun loop i =
+               if i >= n
+                  then ()
+               else (Array.update (a, i, sub (s, i))
+                     ; loop (i + 1))
+         in loop 0;
+            a
+         end
+
+      structure CS =
+         struct
+            type t = Primitive.MLton.Pointer.t
+
+            fun sub (cs, i) =
+               Primitive.Char8.fromWord8Unsafe (Primitive.MLton.Pointer.getWord8 (cs, i))
+
+            fun update (cs, i, c) =
+               Primitive.MLton.Pointer.setWord8 (cs, 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
+      
+   end
+
+structure MLtonCallStack =
+   struct
+      open Primitive.MLton.CallStack
+
+      val gcState = Primitive.MLton.GCState.gcState
+      structure Pointer = Primitive.MLton.Pointer
+         
+      val current: unit -> t =
+         fn () =>
+         if not keep
+            then T (Array.array (0, 0w0))
+         else
+            let
+               val a = Array.array (Word32.toInt (numStackFrames gcState), 0w0)
+               val () = callStack (gcState, a)
+            in
+               T a
+            end
+
+      val toStrings: t -> string list =
+         fn T a =>
+         if not keep
+            then []
+         else
+            let
+               val skip = Array.length a - 2
+            in
+               Array.foldri
+               (fn (i, frameIndex, ac) =>
+                if i >= skip
+                   then ac
+                else
+                   let
+                      val p = frameIndexSourceSeq (gcState, frameIndex)
+                      val max = Pointer.getInt32 (p, 0)
+                      fun loop (j, ac) =
+                         if j > max
+                            then ac
+                         else loop (j + 1,
+                                    COld.CS.toString (sourceName
+                                                      (gcState, Pointer.getWord32 (p, j)))
+                                    :: ac)
+                   in
+                      loop (1, ac)
+                   end)
+               [] a
+            end
+   end
+
+structure MLtonExn =
+   struct
+      open Primitive.MLton.Exn
+
+      type t = exn
+         
+      val addExnMessager = General.addExnMessager
+
+      val history: t -> string list =
+         if keepHistory then
+            (setInitExtra (NONE: extra)
+             ; setExtendExtra (fn e =>
+                               case e of
+                                  NONE => SOME (MLtonCallStack.current ())
+                                | SOME _ => e)
+             ; (fn e =>
+                case extra e of
+                   NONE => []
+                 | SOME cs =>
+                      let
+                         (* Gets rid of the anonymous function passed to
+                          * setExtendExtra above.
+                          *)
+                         fun loop xs =
+                            case xs of
+                               [] => []
+                             | x :: xs =>
+                                  if String.isPrefix "MLtonExn.fn " x then
+                                     xs
+                                  else
+                                     loop xs
+                      in
+                         loop (MLtonCallStack.toStrings cs)
+                      end))
+         else fn _ => []
+
+      local
+         val message = PrimitiveFFI.Stdio.print
+      in
+         fun 'a topLevelHandler (exn: exn): 'a =
+            (message (concat ["unhandled exception: ", exnMessage exn, "\n"])
+             ; (case history exn of
+                   [] => ()
+                 | l =>
+                      (message "with history:\n"
+                       ; (List.app (fn s => message (concat ["\t", s, "\n"]))
+                          l)))
+             ; Primitive.MLton.bug (Primitive.NullString8.fromString 
+                                    "unhandled exception in Basis Library\000")
+             ; raise Fail "bug")
+            handle _ => (message "Toplevel handler raised exception.\n"
+                         ; Primitive.MLton.bug (Primitive.NullString8.fromString 
+                                                "unhandled exception in Basis Library\000")
+                         (* The following raise is unreachable, but must be there
+                          * so that the expression is of type 'a.
+                          *)
+                         ; raise Fail "bug")
+      end
+   end
+
+val _ = 
+   Primitive.TopLevel.setHandler MLtonExn.topLevelHandler

[MLton-commit] r4374

[Matthew F. <fl...@ml...>]

Bug in fixed-width integer conversions
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int0.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.mlb
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml

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

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int0.sml	2006-03-04 17:09:22 UTC (rev 4373)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int0.sml	2006-03-04 18:30:37 UTC (rev 4374)
@@ -184,12 +184,12 @@
             if detectOverflow andalso
                precision' <> #precision' other
                then if Primitive.Int32.< (precision', #precision' other)
-                       then (fn i =>
+                       then (fn (i : 'a) =>
                              if ((#lte other) (toIntUnsafe minInt', i)
-                                 andalso (#lte other) (toIntUnsafe maxInt', i))
+                                 andalso (#lte other) (i, toIntUnsafe maxInt'))
                                 then fromIntUnsafe i
                                 else raise Overflow, 
-                                   toIntUnsafe)
+                             toIntUnsafe)
                        else (fromIntUnsafe, 
                              fn i =>
                              if (fromIntUnsafe (#minInt' other) <= i

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-03-04 17:09:22 UTC (rev 4373)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/Makefile	2006-03-04 18:30:37 UTC (rev 4374)
@@ -39,6 +39,10 @@
 		-mlb-path-map "../maps/default-int32.map" \
 		-mlb-path-map "../maps/default-real64.map" \
 		-mlb-path-map "../maps/default-word32.map" \
+		-const 'Exn.keepHistory true' \
+		-profile-include '<basis>' \
+		-profile-branch true \
+		-profile-raise true \
 		test.mlb print.o
 
 print.o: print.c

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.mlb	2006-03-04 17:09:22 UTC (rev 4373)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.mlb	2006-03-04 18:30:37 UTC (rev 4374)
@@ -1,5 +1,6 @@
 
 ../build/sources.mlb
 ann "allowFFI true" in
+   exn.sml
    test.sml
 end

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-03-04 17:09:22 UTC (rev 4373)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml	2006-03-04 18:30:37 UTC (rev 4374)
@@ -1,26 +1,96 @@
-open Primitive
 
-val printInt8 = _import "printInt8" : Int8.int -> unit;
-val printInt16 = _import "printInt16" : Int16.int -> unit;
-val printInt32 = _import "printInt32" : Int32.int -> unit;
-val printInt64 = _import "printInt64" : Int64.int -> unit;
-
-val printWord8 = _import "printWord8" : Word8.word -> unit;
-val printWord16 = _import "printWord16" : Word16.word -> unit;
-val printWord32 = _import "printWord32" : Word32.word -> unit;
-val printWord64 = _import "printWord64" : Word64.word -> unit;
-
 fun printString s =
    PrimitiveFFI.Stdio.printStdout s
 
 fun printIntInf i =
    let
-      val s = IntInf.toString8 i
+      val s = IntInf.toString i
    in
       printString s
       ; printString "\n"
    end
 
+fun printInt8 i = 
+   let
+      val s = Int8.toString i
+   in
+      printString s
+      ; printString "\n"
+   end
+fun printInt16 i = 
+   let
+      val s = Int16.toString i
+   in
+      printString s
+      ; printString "\n"
+   end
+fun printInt32 i = 
+   let
+      val s = Int32.toString i
+   in
+      printString s
+      ; printString "\n"
+   end
+fun printInt64 i = 
+   let
+      val s = Int64.toString i
+   in
+      printString s
+      ; printString "\n"
+   end
+
+fun printWord8 w = 
+   let
+      val s = Word8.toString w
+   in
+      printString s
+      ; printString "\n"
+   end
+fun printWord16 w = 
+   let
+      val s = Word16.toString w
+   in
+      printString s
+      ; printString "\n"
+   end
+fun printWord32 w = 
+   let
+      val s = Word32.toString w
+   in
+      printString s
+      ; printString "\n"
+   end
+fun printWord64 w = 
+   let
+      val s = Word64.toString w
+   in
+      printString s
+      ; printString "\n"
+   end
+
+
+
+structure Int8 = struct
+   open Int8
+   val zero : int = 0
+   val one : int = 1
+end
+structure Int16 = struct
+   open Int16
+   val zero : int = 0
+   val one : int = 1
+end
+structure Int32 = struct
+   open Int32
+   val zero : int = 0
+   val one : int = 1
+end
+structure Int64 = struct
+   open Int64
+   val zero : int = 0
+   val one : int = 1
+end
+
 local
    open IntInf
 in
@@ -30,375 +100,375 @@
 
 val _ = (printString "Int8.maxInt' = \n"
           ; printInt8 Int8.maxInt')
-val _ = (printString "IntInf.fromInt8 Int8.maxInt' = \n"
-         ; printIntInf (IntInf.fromInt8 Int8.maxInt'))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 Int8.maxInt') = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 Int8.maxInt')))
+val _ = (printString "Int8.toLarge Int8.maxInt' = \n"
+         ; printIntInf (Int8.toLarge Int8.maxInt'))
+val _ = (printString "Int8.fromLarge (Int8.toLarge Int8.maxInt') = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge Int8.maxInt')))
 val _ = (printString "Int16.maxInt' = \n"
           ; printInt16 Int16.maxInt')
-val _ = (printString "IntInf.fromInt16 Int16.maxInt' = \n"
-         ; printIntInf (IntInf.fromInt16 Int16.maxInt'))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 Int16.maxInt') = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 Int16.maxInt')))
+val _ = (printString "Int16.toLarge Int16.maxInt' = \n"
+         ; printIntInf (Int16.toLarge Int16.maxInt'))
+val _ = (printString "Int16.fromLarge (Int16.toLarge Int16.maxInt') = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge Int16.maxInt')))
 val _ = (printString "Int32.maxInt' = \n"
           ; printInt32 Int32.maxInt')
-val _ = (printString "IntInf.fromInt32 Int32.maxInt' = \n"
-         ; printIntInf (IntInf.fromInt32 Int32.maxInt'))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 Int32.maxInt') = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 Int32.maxInt')))
+val _ = (printString "Int32.toLarge Int32.maxInt' = \n"
+         ; printIntInf (Int32.toLarge Int32.maxInt'))
+val _ = (printString "Int32.fromLarge (Int32.toLarge Int32.maxInt') = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge Int32.maxInt')))
 val _ = (printString "Int64.maxInt' = \n"
           ; printInt64 Int64.maxInt')
-val _ = (printString "IntInf.fromInt64 Int64.maxInt' = \n"
-         ; printIntInf (IntInf.fromInt64 Int64.maxInt'))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 Int64.maxInt') = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 Int64.maxInt')))
+val _ = (printString "Int64.toLarge Int64.maxInt' = \n"
+         ; printIntInf (Int64.toLarge Int64.maxInt'))
+val _ = (printString "Int64.fromLarge (Int64.toLarge Int64.maxInt') = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge Int64.maxInt')))
 
 val _ = (printString "Int8.minInt' = \n"
           ; printInt8 Int8.minInt')
-val _ = (printString "IntInf.fromInt8 Int8.minInt' = \n"
-         ; printIntInf (IntInf.fromInt8 Int8.minInt'))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 Int8.minInt') = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 Int8.minInt')))
+val _ = (printString "Int8.toLarge Int8.minInt' = \n"
+         ; printIntInf (Int8.toLarge Int8.minInt'))
+val _ = (printString "Int8.fromLarge (Int8.toLarge Int8.minInt') = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge Int8.minInt')))
 val _ = (printString "Int16.minInt' = \n"
           ; printInt16 Int16.minInt')
-val _ = (printString "IntInf.fromInt16 Int16.minInt' = \n"
-         ; printIntInf (IntInf.fromInt16 Int16.minInt'))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 Int16.minInt') = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 Int16.minInt')))
+val _ = (printString "Int16.toLarge Int16.minInt' = \n"
+         ; printIntInf (Int16.toLarge Int16.minInt'))
+val _ = (printString "Int16.fromLarge (Int16.toLarge Int16.minInt') = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge Int16.minInt')))
 val _ = (printString "Int32.minInt' = \n"
           ; printInt32 Int32.minInt')
-val _ = (printString "IntInf.fromInt32 Int32.minInt' = \n"
-         ; printIntInf (IntInf.fromInt32 Int32.minInt'))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 Int32.minInt') = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 Int32.minInt')))
+val _ = (printString "Int32.toLarge Int32.minInt' = \n"
+         ; printIntInf (Int32.toLarge Int32.minInt'))
+val _ = (printString "Int32.fromLarge (Int32.toLarge Int32.minInt') = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge Int32.minInt')))
 val _ = (printString "Int64.minInt' = \n"
           ; printInt64 Int64.minInt')
-val _ = (printString "IntInf.fromInt64 Int64.minInt' = \n"
-         ; printIntInf (IntInf.fromInt64 Int64.minInt'))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 Int64.minInt') = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 Int64.minInt')))
+val _ = (printString "Int64.toLarge Int64.minInt' = \n"
+         ; printIntInf (Int64.toLarge Int64.minInt'))
+val _ = (printString "Int64.fromLarge (Int64.toLarge Int64.minInt') = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge Int64.minInt')))
 
 val _ = (printString "(Int8.div (Int8.minInt', 2)) = \n"
           ; printInt8 (Int8.div (Int8.minInt', 2)))
-val _ = (printString "IntInf.fromInt8 (Int8.div (Int8.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.div (Int8.minInt', 2))))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.div (Int8.minInt', 2))) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.div (Int8.minInt', 2)))))
+val _ = (printString "Int8.toLarge (Int8.div (Int8.minInt', 2)) = \n"
+         ; printIntInf (Int8.toLarge (Int8.div (Int8.minInt', 2))))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.div (Int8.minInt', 2))) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.div (Int8.minInt', 2)))))
 val _ = (printString "(Int16.div (Int16.minInt', 2)) = \n"
           ; printInt16 (Int16.div (Int16.minInt', 2)))
-val _ = (printString "IntInf.fromInt16 (Int16.div (Int16.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.div (Int16.minInt', 2))))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.div (Int16.minInt', 2))) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.div (Int16.minInt', 2)))))
+val _ = (printString "Int16.toLarge (Int16.div (Int16.minInt', 2)) = \n"
+         ; printIntInf (Int16.toLarge (Int16.div (Int16.minInt', 2))))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.div (Int16.minInt', 2))) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.div (Int16.minInt', 2)))))
 val _ = (printString "(Int32.div (Int32.minInt', 2)) = \n"
           ; printInt32 (Int32.div (Int32.minInt', 2)))
-val _ = (printString "IntInf.fromInt32 (Int32.div (Int32.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.div (Int32.minInt', 2))))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.div (Int32.minInt', 2))) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.div (Int32.minInt', 2)))))
+val _ = (printString "Int32.toLarge (Int32.div (Int32.minInt', 2)) = \n"
+         ; printIntInf (Int32.toLarge (Int32.div (Int32.minInt', 2))))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.div (Int32.minInt', 2))) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.div (Int32.minInt', 2)))))
 val _ = (printString "(Int64.div (Int64.minInt', 2)) = \n"
           ; printInt64 (Int64.div (Int64.minInt', 2)))
-val _ = (printString "IntInf.fromInt64 (Int64.div (Int64.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.div (Int64.minInt', 2))))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.div (Int64.minInt', 2))) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.div (Int64.minInt', 2)))))
+val _ = (printString "Int64.toLarge (Int64.div (Int64.minInt', 2)) = \n"
+         ; printIntInf (Int64.toLarge (Int64.div (Int64.minInt', 2))))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.div (Int64.minInt', 2))) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.div (Int64.minInt', 2)))))
 
 val _ = (printString "(Int8.div (Int8.minInt', 4)) = \n"
           ; printInt8 (Int8.div (Int8.minInt', 4)))
-val _ = (printString "IntInf.fromInt8 (Int8.div (Int8.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.div (Int8.minInt', 4))))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.div (Int8.minInt', 4))) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.div (Int8.minInt', 4)))))
+val _ = (printString "Int8.toLarge (Int8.div (Int8.minInt', 4)) = \n"
+         ; printIntInf (Int8.toLarge (Int8.div (Int8.minInt', 4))))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.div (Int8.minInt', 4))) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.div (Int8.minInt', 4)))))
 val _ = (printString "(Int16.div (Int16.minInt', 4)) = \n"
           ; printInt16 (Int16.div (Int16.minInt', 4)))
-val _ = (printString "IntInf.fromInt16 (Int16.div (Int16.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.div (Int16.minInt', 4))))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.div (Int16.minInt', 4))) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.div (Int16.minInt', 4)))))
+val _ = (printString "Int16.toLarge (Int16.div (Int16.minInt', 4)) = \n"
+         ; printIntInf (Int16.toLarge (Int16.div (Int16.minInt', 4))))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.div (Int16.minInt', 4))) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.div (Int16.minInt', 4)))))
 val _ = (printString "(Int32.div (Int32.minInt', 4)) = \n"
           ; printInt32 (Int32.div (Int32.minInt', 4)))
-val _ = (printString "IntInf.fromInt32 (Int32.div (Int32.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.div (Int32.minInt', 4))))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.div (Int32.minInt', 4))) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.div (Int32.minInt', 4)))))
+val _ = (printString "Int32.toLarge (Int32.div (Int32.minInt', 4)) = \n"
+         ; printIntInf (Int32.toLarge (Int32.div (Int32.minInt', 4))))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.div (Int32.minInt', 4))) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.div (Int32.minInt', 4)))))
 val _ = (printString "(Int64.div (Int64.minInt', 4)) = \n"
           ; printInt64 (Int64.div (Int64.minInt', 4)))
-val _ = (printString "IntInf.fromInt64 (Int64.div (Int64.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.div (Int64.minInt', 4))))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.div (Int64.minInt', 4))) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.div (Int64.minInt', 4)))))
+val _ = (printString "Int64.toLarge (Int64.div (Int64.minInt', 4)) = \n"
+         ; printIntInf (Int64.toLarge (Int64.div (Int64.minInt', 4))))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.div (Int64.minInt', 4))) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.div (Int64.minInt', 4)))))
 
 val _ = (printString "(Int8.- (Int8.maxInt', 2)) = \n"
           ; printInt8 (Int8.- (Int8.maxInt', 2)))
-val _ = (printString "IntInf.fromInt8 (Int8.- (Int8.maxInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.- (Int8.maxInt', 2))))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.- (Int8.maxInt', 2))) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.- (Int8.maxInt', 2)))))
+val _ = (printString "Int8.toLarge (Int8.- (Int8.maxInt', 2)) = \n"
+         ; printIntInf (Int8.toLarge (Int8.- (Int8.maxInt', 2))))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.- (Int8.maxInt', 2))) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.- (Int8.maxInt', 2)))))
 val _ = (printString "(Int16.- (Int16.maxInt', 2)) = \n"
           ; printInt16 (Int16.- (Int16.maxInt', 2)))
-val _ = (printString "IntInf.fromInt16 (Int16.- (Int16.maxInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.- (Int16.maxInt', 2))))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.- (Int16.maxInt', 2))) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.- (Int16.maxInt', 2)))))
+val _ = (printString "Int16.toLarge (Int16.- (Int16.maxInt', 2)) = \n"
+         ; printIntInf (Int16.toLarge (Int16.- (Int16.maxInt', 2))))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.- (Int16.maxInt', 2))) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.- (Int16.maxInt', 2)))))
 val _ = (printString "(Int32.- (Int32.maxInt', 2)) = \n"
           ; printInt32 (Int32.- (Int32.maxInt', 2)))
-val _ = (printString "IntInf.fromInt32 (Int32.- (Int32.maxInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.- (Int32.maxInt', 2))))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.- (Int32.maxInt', 2))) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.- (Int32.maxInt', 2)))))
+val _ = (printString "Int32.toLarge (Int32.- (Int32.maxInt', 2)) = \n"
+         ; printIntInf (Int32.toLarge (Int32.- (Int32.maxInt', 2))))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.- (Int32.maxInt', 2))) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.- (Int32.maxInt', 2)))))
 val _ = (printString "(Int64.- (Int64.maxInt', 2)) = \n"
           ; printInt64 (Int64.- (Int64.maxInt', 2)))
-val _ = (printString "IntInf.fromInt64 (Int64.- (Int64.maxInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.- (Int64.maxInt', 2))))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.- (Int64.maxInt', 2))) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.- (Int64.maxInt', 2)))))
+val _ = (printString "Int64.toLarge (Int64.- (Int64.maxInt', 2)) = \n"
+         ; printIntInf (Int64.toLarge (Int64.- (Int64.maxInt', 2))))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.- (Int64.maxInt', 2))) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.- (Int64.maxInt', 2)))))
 
 val _ = (printString "(Int8.- (Int8.maxInt', 4)) = \n"
           ; printInt8 (Int8.- (Int8.maxInt', 4)))
-val _ = (printString "IntInf.fromInt8 (Int8.- (Int8.maxInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.- (Int8.maxInt', 4))))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.- (Int8.maxInt', 4))) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.- (Int8.maxInt', 4)))))
+val _ = (printString "Int8.toLarge (Int8.- (Int8.maxInt', 4)) = \n"
+         ; printIntInf (Int8.toLarge (Int8.- (Int8.maxInt', 4))))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.- (Int8.maxInt', 4))) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.- (Int8.maxInt', 4)))))
 val _ = (printString "(Int16.- (Int16.maxInt', 4)) = \n"
           ; printInt16 (Int16.- (Int16.maxInt', 4)))
-val _ = (printString "IntInf.fromInt16 (Int16.- (Int16.maxInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.- (Int16.maxInt', 4))))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.- (Int16.maxInt', 4))) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.- (Int16.maxInt', 4)))))
+val _ = (printString "Int16.toLarge (Int16.- (Int16.maxInt', 4)) = \n"
+         ; printIntInf (Int16.toLarge (Int16.- (Int16.maxInt', 4))))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.- (Int16.maxInt', 4))) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.- (Int16.maxInt', 4)))))
 val _ = (printString "(Int32.- (Int32.maxInt', 4)) = \n"
           ; printInt32 (Int32.- (Int32.maxInt', 4)))
-val _ = (printString "IntInf.fromInt32 (Int32.- (Int32.maxInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.- (Int32.maxInt', 4))))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.- (Int32.maxInt', 4))) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.- (Int32.maxInt', 4)))))
+val _ = (printString "Int32.toLarge (Int32.- (Int32.maxInt', 4)) = \n"
+         ; printIntInf (Int32.toLarge (Int32.- (Int32.maxInt', 4))))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.- (Int32.maxInt', 4))) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.- (Int32.maxInt', 4)))))
 val _ = (printString "(Int64.- (Int64.maxInt', 4)) = \n"
           ; printInt64 (Int64.- (Int64.maxInt', 4)))
-val _ = (printString "IntInf.fromInt64 (Int64.- (Int64.maxInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.- (Int64.maxInt', 4))))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.- (Int64.maxInt', 4))) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.- (Int64.maxInt', 4)))))
+val _ = (printString "Int64.toLarge (Int64.- (Int64.maxInt', 4)) = \n"
+         ; printIntInf (Int64.toLarge (Int64.- (Int64.maxInt', 4))))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.- (Int64.maxInt', 4))) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.- (Int64.maxInt', 4)))))
 
 val _ = (printString "(Int8.+ (Int8.minInt', 2)) = \n"
           ; printInt8 (Int8.+ (Int8.minInt', 2)))
-val _ = (printString "IntInf.fromInt8 (Int8.+ (Int8.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.+ (Int8.minInt', 2))))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.+ (Int8.minInt', 2))) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.+ (Int8.minInt', 2)))))
+val _ = (printString "Int8.toLarge (Int8.+ (Int8.minInt', 2)) = \n"
+         ; printIntInf (Int8.toLarge (Int8.+ (Int8.minInt', 2))))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.+ (Int8.minInt', 2))) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.+ (Int8.minInt', 2)))))
 val _ = (printString "(Int16.+ (Int16.minInt', 2)) = \n"
           ; printInt16 (Int16.+ (Int16.minInt', 2)))
-val _ = (printString "IntInf.fromInt16 (Int16.+ (Int16.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.+ (Int16.minInt', 2))))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.+ (Int16.minInt', 2))) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.+ (Int16.minInt', 2)))))
+val _ = (printString "Int16.toLarge (Int16.+ (Int16.minInt', 2)) = \n"
+         ; printIntInf (Int16.toLarge (Int16.+ (Int16.minInt', 2))))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.+ (Int16.minInt', 2))) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.+ (Int16.minInt', 2)))))
 val _ = (printString "(Int32.+ (Int32.minInt', 2)) = \n"
           ; printInt32 (Int32.+ (Int32.minInt', 2)))
-val _ = (printString "IntInf.fromInt32 (Int32.+ (Int32.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.+ (Int32.minInt', 2))))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.+ (Int32.minInt', 2))) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.+ (Int32.minInt', 2)))))
+val _ = (printString "Int32.toLarge (Int32.+ (Int32.minInt', 2)) = \n"
+         ; printIntInf (Int32.toLarge (Int32.+ (Int32.minInt', 2))))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.+ (Int32.minInt', 2))) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.+ (Int32.minInt', 2)))))
 val _ = (printString "(Int64.+ (Int64.minInt', 2)) = \n"
           ; printInt64 (Int64.+ (Int64.minInt', 2)))
-val _ = (printString "IntInf.fromInt64 (Int64.+ (Int64.minInt', 2)) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.+ (Int64.minInt', 2))))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.+ (Int64.minInt', 2))) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.+ (Int64.minInt', 2)))))
+val _ = (printString "Int64.toLarge (Int64.+ (Int64.minInt', 2)) = \n"
+         ; printIntInf (Int64.toLarge (Int64.+ (Int64.minInt', 2))))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.+ (Int64.minInt', 2))) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.+ (Int64.minInt', 2)))))
 
 val _ = (printString "(Int8.+ (Int8.minInt', 4)) = \n"
           ; printInt8 (Int8.+ (Int8.minInt', 4)))
-val _ = (printString "IntInf.fromInt8 (Int8.+ (Int8.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.+ (Int8.minInt', 4))))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.+ (Int8.minInt', 4))) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.+ (Int8.minInt', 4)))))
+val _ = (printString "Int8.toLarge (Int8.+ (Int8.minInt', 4)) = \n"
+         ; printIntInf (Int8.toLarge (Int8.+ (Int8.minInt', 4))))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.+ (Int8.minInt', 4))) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.+ (Int8.minInt', 4)))))
 val _ = (printString "(Int16.+ (Int16.minInt', 4)) = \n"
           ; printInt16 (Int16.+ (Int16.minInt', 4)))
-val _ = (printString "IntInf.fromInt16 (Int16.+ (Int16.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.+ (Int16.minInt', 4))))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.+ (Int16.minInt', 4))) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.+ (Int16.minInt', 4)))))
+val _ = (printString "Int16.toLarge (Int16.+ (Int16.minInt', 4)) = \n"
+         ; printIntInf (Int16.toLarge (Int16.+ (Int16.minInt', 4))))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.+ (Int16.minInt', 4))) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.+ (Int16.minInt', 4)))))
 val _ = (printString "(Int32.+ (Int32.minInt', 4)) = \n"
           ; printInt32 (Int32.+ (Int32.minInt', 4)))
-val _ = (printString "IntInf.fromInt32 (Int32.+ (Int32.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.+ (Int32.minInt', 4))))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.+ (Int32.minInt', 4))) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.+ (Int32.minInt', 4)))))
+val _ = (printString "Int32.toLarge (Int32.+ (Int32.minInt', 4)) = \n"
+         ; printIntInf (Int32.toLarge (Int32.+ (Int32.minInt', 4))))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.+ (Int32.minInt', 4))) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.+ (Int32.minInt', 4)))))
 val _ = (printString "(Int64.+ (Int64.minInt', 4)) = \n"
           ; printInt64 (Int64.+ (Int64.minInt', 4)))
-val _ = (printString "IntInf.fromInt64 (Int64.+ (Int64.minInt', 4)) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.+ (Int64.minInt', 4))))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.+ (Int64.minInt', 4))) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.+ (Int64.minInt', 4)))))
+val _ = (printString "Int64.toLarge (Int64.+ (Int64.minInt', 4)) = \n"
+         ; printIntInf (Int64.toLarge (Int64.+ (Int64.minInt', 4))))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.+ (Int64.minInt', 4))) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.+ (Int64.minInt', 4)))))
 
 val _ = (printString "Int8.zero = \n"
           ; printInt8 Int8.zero)
-val _ = (printString "IntInf.fromInt8 Int8.zero = \n"
-         ; printIntInf (IntInf.fromInt8 Int8.zero))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 Int8.zero) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 Int8.zero)))
+val _ = (printString "Int8.toLarge Int8.zero = \n"
+         ; printIntInf (Int8.toLarge Int8.zero))
+val _ = (printString "Int8.fromLarge (Int8.toLarge Int8.zero) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge Int8.zero)))
 val _ = (printString "Int16.zero = \n"
           ; printInt16 Int16.zero)
-val _ = (printString "IntInf.fromInt16 Int16.zero = \n"
-         ; printIntInf (IntInf.fromInt16 Int16.zero))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 Int16.zero) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 Int16.zero)))
+val _ = (printString "Int16.toLarge Int16.zero = \n"
+         ; printIntInf (Int16.toLarge Int16.zero))
+val _ = (printString "Int16.fromLarge (Int16.toLarge Int16.zero) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge Int16.zero)))
 val _ = (printString "Int32.zero = \n"
           ; printInt32 Int32.zero)
-val _ = (printString "IntInf.fromInt32 Int32.zero = \n"
-         ; printIntInf (IntInf.fromInt32 Int32.zero))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 Int32.zero) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 Int32.zero)))
+val _ = (printString "Int32.toLarge Int32.zero = \n"
+         ; printIntInf (Int32.toLarge Int32.zero))
+val _ = (printString "Int32.fromLarge (Int32.toLarge Int32.zero) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge Int32.zero)))
 val _ = (printString "Int64.zero = \n"
           ; printInt64 Int64.zero)
-val _ = (printString "IntInf.fromInt64 Int64.zero = \n"
-         ; printIntInf (IntInf.fromInt64 Int64.zero))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 Int64.zero) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 Int64.zero)))
+val _ = (printString "Int64.toLarge Int64.zero = \n"
+         ; printIntInf (Int64.toLarge Int64.zero))
+val _ = (printString "Int64.fromLarge (Int64.toLarge Int64.zero) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge Int64.zero)))
 
 val _ = (printString "Int8.one = \n"
           ; printInt8 Int8.one)
-val _ = (printString "IntInf.fromInt8 Int8.one = \n"
-         ; printIntInf (IntInf.fromInt8 Int8.one))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 Int8.one) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 Int8.one)))
+val _ = (printString "Int8.toLarge Int8.one = \n"
+         ; printIntInf (Int8.toLarge Int8.one))
+val _ = (printString "Int8.fromLarge (Int8.toLarge Int8.one) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge Int8.one)))
 val _ = (printString "Int16.one = \n"
           ; printInt16 Int16.one)
-val _ = (printString "IntInf.fromInt16 Int16.one = \n"
-         ; printIntInf (IntInf.fromInt16 Int16.one))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 Int16.one) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 Int16.one)))
+val _ = (printString "Int16.toLarge Int16.one = \n"
+         ; printIntInf (Int16.toLarge Int16.one))
+val _ = (printString "Int16.fromLarge (Int16.toLarge Int16.one) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge Int16.one)))
 val _ = (printString "Int32.one = \n"
           ; printInt32 Int32.one)
-val _ = (printString "IntInf.fromInt32 Int32.one = \n"
-         ; printIntInf (IntInf.fromInt32 Int32.one))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 Int32.one) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 Int32.one)))
+val _ = (printString "Int32.toLarge Int32.one = \n"
+         ; printIntInf (Int32.toLarge Int32.one))
+val _ = (printString "Int32.fromLarge (Int32.toLarge Int32.one) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge Int32.one)))
 val _ = (printString "Int64.one = \n"
           ; printInt64 Int64.one)
-val _ = (printString "IntInf.fromInt64 Int64.one = \n"
-         ; printIntInf (IntInf.fromInt64 Int64.one))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 Int64.one) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 Int64.one)))
+val _ = (printString "Int64.toLarge Int64.one = \n"
+         ; printIntInf (Int64.toLarge Int64.one))
+val _ = (printString "Int64.fromLarge (Int64.toLarge Int64.one) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge Int64.one)))
 
 val _ = (printString "(Int8.~ Int8.one) = \n"
           ; printInt8 (Int8.~ Int8.one))
-val _ = (printString "IntInf.fromInt8 (Int8.~ Int8.one) = \n"
-         ; printIntInf (IntInf.fromInt8 (Int8.~ Int8.one)))
-val _ = (printString "IntInf.toInt8 (IntInf.fromInt8 (Int8.~ Int8.one)) = \n"
-         ; printInt8 (IntInf.toInt8 (IntInf.fromInt8 (Int8.~ Int8.one))))
+val _ = (printString "Int8.toLarge (Int8.~ Int8.one) = \n"
+         ; printIntInf (Int8.toLarge (Int8.~ Int8.one)))
+val _ = (printString "Int8.fromLarge (Int8.toLarge (Int8.~ Int8.one)) = \n"
+         ; printInt8 (Int8.fromLarge (Int8.toLarge (Int8.~ Int8.one))))
 val _ = (printString "(Int16.~ Int16.one) = \n"
           ; printInt16 (Int16.~ Int16.one))
-val _ = (printString "IntInf.fromInt16 (Int16.~ Int16.one) = \n"
-         ; printIntInf (IntInf.fromInt16 (Int16.~ Int16.one)))
-val _ = (printString "IntInf.toInt16 (IntInf.fromInt16 (Int16.~ Int16.one)) = \n"
-         ; printInt16 (IntInf.toInt16 (IntInf.fromInt16 (Int16.~ Int16.one))))
+val _ = (printString "Int16.toLarge (Int16.~ Int16.one) = \n"
+         ; printIntInf (Int16.toLarge (Int16.~ Int16.one)))
+val _ = (printString "Int16.fromLarge (Int16.toLarge (Int16.~ Int16.one)) = \n"
+         ; printInt16 (Int16.fromLarge (Int16.toLarge (Int16.~ Int16.one))))
 val _ = (printString "(Int32.~ Int32.one) = \n"
           ; printInt32 (Int32.~ Int32.one))
-val _ = (printString "IntInf.fromInt32 (Int32.~ Int32.one) = \n"
-         ; printIntInf (IntInf.fromInt32 (Int32.~ Int32.one)))
-val _ = (printString "IntInf.toInt32 (IntInf.fromInt32 (Int32.~ Int32.one)) = \n"
-         ; printInt32 (IntInf.toInt32 (IntInf.fromInt32 (Int32.~ Int32.one))))
+val _ = (printString "Int32.toLarge (Int32.~ Int32.one) = \n"
+         ; printIntInf (Int32.toLarge (Int32.~ Int32.one)))
+val _ = (printString "Int32.fromLarge (Int32.toLarge (Int32.~ Int32.one)) = \n"
+         ; printInt32 (Int32.fromLarge (Int32.toLarge (Int32.~ Int32.one))))
 val _ = (printString "(Int64.~ Int64.one) = \n"
           ; printInt64 (Int64.~ Int64.one))
-val _ = (printString "IntInf.fromInt64 (Int64.~ Int64.one) = \n"
-         ; printIntInf (IntInf.fromInt64 (Int64.~ Int64.one)))
-val _ = (printString "IntInf.toInt64 (IntInf.fromInt64 (Int64.~ Int64.one)) = \n"
-         ; printInt64 (IntInf.toInt64 (IntInf.fromInt64 (Int64.~ Int64.one))))
+val _ = (printString "Int64.toLarge (Int64.~ Int64.one) = \n"
+         ; printIntInf (Int64.toLarge (Int64.~ Int64.one)))
+val _ = (printString "Int64.fromLarge (Int64.toLarge (Int64.~ Int64.one)) = \n"
+         ; printInt64 (Int64.fromLarge (Int64.toLarge (Int64.~ Int64.one))))
 
-val _ = (printString "IntInf.toWord8 0 = \n"
-         ; printWord8 (IntInf.toWord8 0))
-val _ = (printString "IntInf.toWord16 0 = \n"
-         ; printWord16 (IntInf.toWord16 0))
-val _ = (printString "IntInf.toWord32 0 = \n"
-         ; printWord32 (IntInf.toWord32 0))
-val _ = (printString "IntInf.toWord64 0 = \n"
-         ; printWord64 (IntInf.toWord64 0))
+val _ = (printString "Word8.fromLargeInt 0 = \n"
+         ; printWord8 (Word8.fromLargeInt 0))
+val _ = (printString "Word16.fromLargeInt 0 = \n"
+         ; printWord16 (Word16.fromLargeInt 0))
+val _ = (printString "Word32.fromLargeInt 0 = \n"
+         ; printWord32 (Word32.fromLargeInt 0))
+val _ = (printString "Word64.fromLargeInt 0 = \n"
+         ; printWord64 (Word64.fromLargeInt 0))
 
-val _ = (printString "IntInf.toWord8 1 = \n"
-         ; printWord8 (IntInf.toWord8 1))
-val _ = (printString "IntInf.toWord16 1 = \n"
-         ; printWord16 (IntInf.toWord16 1))
-val _ = (printString "IntInf.toWord32 1 = \n"
-         ; printWord32 (IntInf.toWord32 1))
-val _ = (printString "IntInf.toWord64 1 = \n"
-         ; printWord64 (IntInf.toWord64 1))
+val _ = (printString "Word8.fromLargeInt 1 = \n"
+         ; printWord8 (Word8.fromLargeInt 1))
+val _ = (printString "Word16.fromLargeInt 1 = \n"
+         ; printWord16 (Word16.fromLargeInt 1))
+val _ = (printString "Word32.fromLargeInt 1 = \n"
+         ; printWord32 (Word32.fromLargeInt 1))
+val _ = (printString "Word64.fromLargeInt 1 = \n"
+         ; printWord64 (Word64.fromLargeInt 1))
 
-val _ = (printString "IntInf.toWord8 ~1 = \n"
-         ; printWord8 (IntInf.toWord8 ~1))
-val _ = (printString "IntInf.toWord16 ~1 = \n"
-         ; printWord16 (IntInf.toWord16 ~1))
-val _ = (printString "IntInf.toWord32 ~1 = \n"
-         ; printWord32 (IntInf.toWord32 ~1))
-val _ = (printString "IntInf.toWord64 ~1 = \n"
-         ; printWord64 (IntInf.toWord64 ~1))
+val _ = (printString "Word8.fromLargeInt ~1 = \n"
+         ; printWord8 (Word8.fromLargeInt ~1))
+val _ = (printString "Word16.fromLargeInt ~1 = \n"
+         ; printWord16 (Word16.fromLargeInt ~1))
+val _ = (printString "Word32.fromLargeInt ~1 = \n"
+         ; printWord32 (Word32.fromLargeInt ~1))
+val _ = (printString "Word64.fromLargeInt ~1 = \n"
+         ; printWord64 (Word64.fromLargeInt ~1))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt8 Int8.minInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt8 Int8.minInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt8 Int8.minInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt8 Int8.minInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt8 Int8.minInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt8 Int8.minInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt8 Int8.minInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt8 Int8.minInt')))
+val _ = (printString "Word8.fromLargeInt (Int8.toLarge Int8.minInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int8.toLarge Int8.minInt')))
+val _ = (printString "Word16.fromLargeInt (Int8.toLarge Int8.minInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int8.toLarge Int8.minInt')))
+val _ = (printString "Word32.fromLargeInt (Int8.toLarge Int8.minInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int8.toLarge Int8.minInt')))
+val _ = (printString "Word64.fromLargeInt (Int8.toLarge Int8.minInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int8.toLarge Int8.minInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt16 Int16.minInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt16 Int16.minInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt16 Int16.minInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt16 Int16.minInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt16 Int16.minInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt16 Int16.minInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt16 Int16.minInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt16 Int16.minInt')))
+val _ = (printString "Word8.fromLargeInt (Int16.toLarge Int16.minInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int16.toLarge Int16.minInt')))
+val _ = (printString "Word16.fromLargeInt (Int16.toLarge Int16.minInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int16.toLarge Int16.minInt')))
+val _ = (printString "Word32.fromLargeInt (Int16.toLarge Int16.minInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int16.toLarge Int16.minInt')))
+val _ = (printString "Word64.fromLargeInt (Int16.toLarge Int16.minInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int16.toLarge Int16.minInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt32 Int32.minInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt32 Int32.minInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt32 Int32.minInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt32 Int32.minInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt32 Int32.minInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt32 Int32.minInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt32 Int32.minInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt32 Int32.minInt')))
+val _ = (printString "Word8.fromLargeInt (Int32.toLarge Int32.minInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int32.toLarge Int32.minInt')))
+val _ = (printString "Word16.fromLargeInt (Int32.toLarge Int32.minInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int32.toLarge Int32.minInt')))
+val _ = (printString "Word32.fromLargeInt (Int32.toLarge Int32.minInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int32.toLarge Int32.minInt')))
+val _ = (printString "Word64.fromLargeInt (Int32.toLarge Int32.minInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int32.toLarge Int32.minInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt64 Int64.minInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt64 Int64.minInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt64 Int64.minInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt64 Int64.minInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt64 Int64.minInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt64 Int64.minInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt64 Int64.minInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt64 Int64.minInt')))
+val _ = (printString "Word8.fromLargeInt (Int64.toLarge Int64.minInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int64.toLarge Int64.minInt')))
+val _ = (printString "Word16.fromLargeInt (Int64.toLarge Int64.minInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int64.toLarge Int64.minInt')))
+val _ = (printString "Word32.fromLargeInt (Int64.toLarge Int64.minInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int64.toLarge Int64.minInt')))
+val _ = (printString "Word64.fromLargeInt (Int64.toLarge Int64.minInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int64.toLarge Int64.minInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt8 Int8.maxInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt8 Int8.maxInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt8 Int8.maxInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt8 Int8.maxInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt8 Int8.maxInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt8 Int8.maxInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt8 Int8.maxInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt8 Int8.maxInt')))
+val _ = (printString "Word8.fromLargeInt (Int8.toLarge Int8.maxInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int8.toLarge Int8.maxInt')))
+val _ = (printString "Word16.fromLargeInt (Int8.toLarge Int8.maxInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int8.toLarge Int8.maxInt')))
+val _ = (printString "Word32.fromLargeInt (Int8.toLarge Int8.maxInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int8.toLarge Int8.maxInt')))
+val _ = (printString "Word64.fromLargeInt (Int8.toLarge Int8.maxInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int8.toLarge Int8.maxInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt16 Int16.maxInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt16 Int16.maxInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt16 Int16.maxInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt16 Int16.maxInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt16 Int16.maxInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt16 Int16.maxInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt16 Int16.maxInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt16 Int16.maxInt')))
+val _ = (printString "Word8.fromLargeInt (Int16.toLarge Int16.maxInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int16.toLarge Int16.maxInt')))
+val _ = (printString "Word16.fromLargeInt (Int16.toLarge Int16.maxInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int16.toLarge Int16.maxInt')))
+val _ = (printString "Word32.fromLargeInt (Int16.toLarge Int16.maxInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int16.toLarge Int16.maxInt')))
+val _ = (printString "Word64.fromLargeInt (Int16.toLarge Int16.maxInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int16.toLarge Int16.maxInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt32 Int32.maxInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt32 Int32.maxInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt32 Int32.maxInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt32 Int32.maxInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt32 Int32.maxInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt32 Int32.maxInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt32 Int32.maxInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt32 Int32.maxInt')))
+val _ = (printString "Word8.fromLargeInt (Int32.toLarge Int32.maxInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int32.toLarge Int32.maxInt')))
+val _ = (printString "Word16.fromLargeInt (Int32.toLarge Int32.maxInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int32.toLarge Int32.maxInt')))
+val _ = (printString "Word32.fromLargeInt (Int32.toLarge Int32.maxInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int32.toLarge Int32.maxInt')))
+val _ = (printString "Word64.fromLargeInt (Int32.toLarge Int32.maxInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int32.toLarge Int32.maxInt')))
 
-val _ = (printString "IntInf.toWord8 (IntInf.fromInt64 Int64.maxInt') = \n"
-         ; printWord8 (IntInf.toWord8 (IntInf.fromInt64 Int64.maxInt')))
-val _ = (printString "IntInf.toWord16 (IntInf.fromInt64 Int64.maxInt') = \n"
-         ; printWord16 (IntInf.toWord16 (IntInf.fromInt64 Int64.maxInt')))
-val _ = (printString "IntInf.toWord32 (IntInf.fromInt64 Int64.maxInt') = \n"
-         ; printWord32 (IntInf.toWord32 (IntInf.fromInt64 Int64.maxInt')))
-val _ = (printString "IntInf.toWord64 (IntInf.fromInt64 Int64.maxInt') = \n"
-         ; printWord64 (IntInf.toWord64 (IntInf.fromInt64 Int64.maxInt')))
+val _ = (printString "Word8.fromLargeInt (Int64.toLarge Int64.maxInt') = \n"
+         ; printWord8 (Word8.fromLargeInt (Int64.toLarge Int64.maxInt')))
+val _ = (printString "Word16.fromLargeInt (Int64.toLarge Int64.maxInt') = \n"
+         ; printWord16 (Word16.fromLargeInt (Int64.toLarge Int64.maxInt')))
+val _ = (printString "Word32.fromLargeInt (Int64.toLarge Int64.maxInt') = \n"
+         ; printWord32 (Word32.fromLargeInt (Int64.toLarge Int64.maxInt')))
+val _ = (printString "Word64.fromLargeInt (Int64.toLarge Int64.maxInt') = \n"
+         ; printWord64 (Word64.fromLargeInt (Int64.toLarge Int64.maxInt')))
 

[MLton-commit] r4373

[Matthew F. <fl...@ml...>]

Initial port of the MLRISC Library
----------------------------------------------------------------------

U   mlton/trunk/Makefile
A   mlton/trunk/lib/mlrisc-lib/
A   mlton/trunk/lib/mlrisc-lib/.ignore
A   mlton/trunk/lib/mlrisc-lib/MLRISC.patch
A   mlton/trunk/lib/mlrisc-lib/MLRISC.tgz
A   mlton/trunk/lib/mlrisc-lib/Makefile
U   mlton/trunk/util/cm2mlb/cm2mlb-map

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

Modified: mlton/trunk/Makefile
===================================================================
--- mlton/trunk/Makefile	2006-03-04 14:35:22 UTC (rev 4372)
+++ mlton/trunk/Makefile	2006-03-04 17:09:22 UTC (rev 4373)
@@ -169,17 +169,19 @@
         # do not change "make" to "$(MAKE)" in the following line
 	cd $(BSDSRC)/package/freebsd && MAINTAINER_MODE=yes make build-package  
 
-LIBRARIES = ckit-lib cml mlnlffi-lib mlyacc-lib smlnj-lib
+LIBRARIES = ckit-lib cml mlnlffi-lib mlrisc-lib mlyacc-lib smlnj-lib
 
 .PHONY: libraries-no-check
 libraries-no-check:
 	mkdir -p $(LIB)/sml
 	cd $(LIB)/sml && rm -rf $(LIBRARIES)
 	$(MAKE) -C $(SRC)/lib/ckit-lib
+	$(MAKE) -C $(SRC)/lib/mlrisc-lib
 	$(MAKE) -C $(SRC)/lib/smlnj-lib
 	$(CP) $(SRC)/lib/cml/. $(LIB)/sml/cml
 	$(CP) $(SRC)/lib/ckit-lib/ckit/. $(LIB)/sml/ckit-lib
 	$(CP) $(SRC)/lib/mlnlffi/. $(LIB)/sml/mlnlffi-lib
+	$(CP) $(SRC)/lib/mlrisc-lib/MLRISC/. $(LIB)/sml/mlrisc-lib
 	$(CP) $(SRC)/lib/mlyacc/. $(LIB)/sml/mlyacc-lib
 	$(CP) $(SRC)/lib/smlnj-lib/smlnj-lib/. $(LIB)/sml/smlnj-lib
 	find $(LIB)/sml -type d -name .svn | xargs rm -rf


Property changes on: mlton/trunk/lib/mlrisc-lib
___________________________________________________________________
Name: svn:ignore
   + MLRISC


Added: mlton/trunk/lib/mlrisc-lib/.ignore
===================================================================
--- mlton/trunk/lib/mlrisc-lib/.ignore	2006-03-04 14:35:22 UTC (rev 4372)
+++ mlton/trunk/lib/mlrisc-lib/.ignore	2006-03-04 17:09:22 UTC (rev 4373)
@@ -0,0 +1 @@
+MLRISC

Added: mlton/trunk/lib/mlrisc-lib/MLRISC.patch
===================================================================
--- mlton/trunk/lib/mlrisc-lib/MLRISC.patch	2006-03-04 14:35:22 UTC (rev 4372)
+++ mlton/trunk/lib/mlrisc-lib/MLRISC.patch	2006-03-04 17:09:22 UTC (rev 4373)
@@ -0,0 +1,13603 @@
+diff -Naur MLRISC/aliasing/pointsTo.sig MLRISC-mlton/aliasing/pointsTo.sig
+--- MLRISC/aliasing/pointsTo.sig	2000-12-07 23:11:33.000000000 -0500
++++ MLRISC-mlton/aliasing/pointsTo.sig	2006-03-04 11:14:21.000000000 -0500
+@@ -7,18 +7,27 @@
+ sig
+ 
+    eqtype edgekind 
+-   structure C : CELLS_BASIS = CellsBasis
++   structure C : CELLS_BASIS (* = CellsBasis *)
++                 where type CellSet.cellset = CellsBasis.CellSet.cellset
++                   and type 'a ColorTable.hash_table = 'a CellsBasis.ColorTable.hash_table
++                   and type 'a HashTable.hash_table = 'a CellsBasis.HashTable.hash_table
++                   and type SortedCells.sorted_cells = CellsBasis.SortedCells.sorted_cells
++                   and type cell = CellsBasis.cell
++                   and type cellColor = CellsBasis.cellColor
++                   and type cellkind = CellsBasis.cellkind
++                   and type cellkindDesc = CellsBasis.cellkindDesc
++                   and type cellkindInfo = CellsBasis.cellkindInfo
+ 
+    datatype cell = 
+-     LINK  of region                             
+-   | SREF  of C.cell * edges ref
+-   | WREF  of C.cell * edges ref
+-   | SCELL of C.cell * edges ref
+-   | WCELL of C.cell * edges ref
++     LINK  of cell ref
++   | SREF  of C.cell * (edgekind * int * cell ref) list ref
++   | WREF  of C.cell * (edgekind * int * cell ref) list ref
++   | SCELL of C.cell * (edgekind * int * cell ref) list ref
++   | WCELL of C.cell * (edgekind * int * cell ref) list ref
+    | TOP   of {mutable:bool, id:C.cell, name:string}
+       (* a collapsed node *)
+-   withtype region = cell ref
+-   and      edges  = (edgekind * int * region) list
++   type region = cell ref
++   type edges  = (edgekind * int * region) list
+ 
+    val reset    : (unit -> C.cell) -> unit
+ 
+diff -Naur MLRISC/aliasing/pointsTo.sml MLRISC-mlton/aliasing/pointsTo.sml
+--- MLRISC/aliasing/pointsTo.sml	2002-03-07 16:16:23.000000000 -0500
++++ MLRISC-mlton/aliasing/pointsTo.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -10,25 +10,30 @@
+    structure C = CellsBasis
+ 
+    datatype cell = 
+-     LINK  of region
+-   | SREF  of C.cell * edges ref
+-   | WREF  of C.cell * edges ref
+-   | SCELL of C.cell * edges ref
+-   | WCELL of C.cell * edges ref
++     LINK  of cell ref
++   | SREF  of C.cell * (edgekind * int * cell ref) list ref
++   | WREF  of C.cell * (edgekind * int * cell ref) list ref
++   | SCELL of C.cell * (edgekind * int * cell ref) list ref
++   | WCELL of C.cell * (edgekind * int * cell ref) list ref
+    | TOP   of {mutable:bool, id:C.cell, name:string}
+       (* a collapsed node *)
+-
+-   withtype region = cell ref
+-   and      edges  = (edgekind * int * region) list
++   type region = cell ref
++   type edges  = (edgekind * int * region) list
+ 
+    fun error msg = MLRiscErrorMsg.error("PointsTo",msg)
+ 
+    (* PI > DOM > RAN > RECORD *)
+    fun greaterKind(PI,_) = false   
+      | greaterKind(DOM,PI) = false
+-     | greaterKind(RAN,(PI | DOM)) = false
+-     | greaterKind(RECORD,(PI | DOM | RAN)) = false
+-     | greaterKind(MARK,(PI | DOM | RAN | RECORD)) = false
++     | greaterKind(RAN,PI) = false
++     | greaterKind(RAN,DOM) = false
++     | greaterKind(RECORD,PI) = false
++     | greaterKind(RECORD,DOM) = false
++     | greaterKind(RECORD,RAN) = false
++     | greaterKind(MARK,PI) = false
++     | greaterKind(MARK,DOM) = false
++     | greaterKind(MARK,RAN) = false
++     | greaterKind(MARK,RECORD) = false
+      | greaterKind _ = true
+ 
+    fun less(k,i,k',i') = k=k' andalso i > i' orelse greaterKind(k,k')
+diff -Naur MLRISC/alpha/backpatch/alphaJumps.sml MLRISC-mlton/alpha/backpatch/alphaJumps.sml
+--- MLRISC/alpha/backpatch/alphaJumps.sml	2003-05-22 18:46:19.000000000 -0400
++++ MLRISC-mlton/alpha/backpatch/alphaJumps.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -5,10 +5,67 @@
+  *)
+ functor AlphaJumps
+   (structure Instr : ALPHAINSTR
+-   structure Shuffle : ALPHASHUFFLE 
+-			   where I = Instr
+-   structure MLTreeEval : MLTREE_EVAL 
+-			   where T = Instr.T
++   structure Shuffle : ALPHASHUFFLE (* where I = Instr *)
++                       where type I.Constant.const = Instr.Constant.const
++                         and type I.Region.region = Instr.Region.region
++                         and type I.T.Basis.cond = Instr.T.Basis.cond
++                         and type I.T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                         and type I.T.Basis.ext = Instr.T.Basis.ext
++                         and type I.T.Basis.fcond = Instr.T.Basis.fcond
++                         and type I.T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                         and type ('s,'r,'f,'c) I.T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                         and type ('s,'r,'f,'c) I.T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                         and type ('s,'r,'f,'c) I.T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                         and type ('s,'r,'f,'c) I.T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                         and type I.T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                         and type I.T.ccexp = Instr.T.ccexp
++                         and type I.T.fexp = Instr.T.fexp
++                         (* and type I.T.labexp = Instr.T.labexp *)
++                         and type I.T.mlrisc = Instr.T.mlrisc
++                         and type I.T.oper = Instr.T.oper
++                         and type I.T.rep = Instr.T.rep
++                         and type I.T.rexp = Instr.T.rexp
++                         and type I.T.stm = Instr.T.stm
++                         and type I.branch = Instr.branch
++                         and type I.cmove = Instr.cmove
++                         and type I.ea = Instr.ea
++                         and type I.fbranch = Instr.fbranch
++                         and type I.fcmove = Instr.fcmove
++                         and type I.fload = Instr.fload
++                         and type I.foperate = Instr.foperate
++                         and type I.foperateV = Instr.foperateV
++                         and type I.fstore = Instr.fstore
++                         and type I.funary = Instr.funary
++                         and type I.instr = Instr.instr
++                         and type I.instruction = Instr.instruction
++                         and type I.load = Instr.load
++                         and type I.operand = Instr.operand
++                         and type I.operate = Instr.operate
++                         and type I.operateV = Instr.operateV
++                         and type I.osf_user_palcode = Instr.osf_user_palcode
++                         and type I.pseudo_op = Instr.pseudo_op
++                         and type I.store = Instr.store
++   structure MLTreeEval : MLTREE_EVAL (* where T = Instr.T *)
++                          where type T.Basis.cond = Instr.T.Basis.cond
++                            and type T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                            and type T.Basis.ext = Instr.T.Basis.ext
++                            and type T.Basis.fcond = Instr.T.Basis.fcond
++                            and type T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                            and type T.Constant.const = Instr.T.Constant.const
++                            and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                            and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                            and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                            and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                            and type T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                            and type T.Region.region = Instr.T.Region.region
++                            and type T.ccexp = Instr.T.ccexp
++                            and type T.fexp = Instr.T.fexp
++                            (* and type T.labexp = Instr.T.labexp *)
++                            and type T.mlrisc = Instr.T.mlrisc
++                            and type T.oper = Instr.T.oper
++                            and type T.rep = Instr.T.rep
++                            and type T.rexp = Instr.T.rexp
++                            and type T.stm = Instr.T.stm
+   ) : SDI_JUMPS = 
+ struct
+   structure I = Instr
+diff -Naur MLRISC/alpha/emit/alphaAsm.sml MLRISC-mlton/alpha/emit/alphaAsm.sml
+--- MLRISC/alpha/emit/alphaAsm.sml	2002-03-07 16:16:24.000000000 -0500
++++ MLRISC-mlton/alpha/emit/alphaAsm.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -6,12 +6,88 @@
+ 
+ 
+ functor AlphaAsmEmitter(structure S : INSTRUCTION_STREAM
+-                        structure Instr : ALPHAINSTR
+-                           where T = S.P.T
+-                        structure Shuffle : ALPHASHUFFLE
+-                           where I = Instr
+-                        structure MLTreeEval : MLTREE_EVAL
+-                           where T = Instr.T
++                        structure Instr : ALPHAINSTR (* where T = S.P.T *)
++                                          where type T.Basis.cond = S.P.T.Basis.cond
++                                            and type T.Basis.div_rounding_mode = S.P.T.Basis.div_rounding_mode
++                                            and type T.Basis.ext = S.P.T.Basis.ext
++                                            and type T.Basis.fcond = S.P.T.Basis.fcond
++                                            and type T.Basis.rounding_mode = S.P.T.Basis.rounding_mode
++                                            and type T.Constant.const = S.P.T.Constant.const
++                                            and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) S.P.T.Extension.ccx
++                                            and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) S.P.T.Extension.fx
++                                            and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) S.P.T.Extension.rx
++                                            and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) S.P.T.Extension.sx
++                                            and type T.I.div_rounding_mode = S.P.T.I.div_rounding_mode
++                                            and type T.Region.region = S.P.T.Region.region
++                                            and type T.ccexp = S.P.T.ccexp
++                                            and type T.fexp = S.P.T.fexp
++                                            (* and type T.labexp = S.P.T.labexp *)
++                                            and type T.mlrisc = S.P.T.mlrisc
++                                            and type T.oper = S.P.T.oper
++                                            and type T.rep = S.P.T.rep
++                                            and type T.rexp = S.P.T.rexp
++                                            and type T.stm = S.P.T.stm
++                        structure Shuffle : ALPHASHUFFLE (* where I = Instr *)
++                                            where type I.Constant.const = Instr.Constant.const
++                                              and type I.Region.region = Instr.Region.region
++                                              and type I.T.Basis.cond = Instr.T.Basis.cond
++                                              and type I.T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                                              and type I.T.Basis.ext = Instr.T.Basis.ext
++                                              and type I.T.Basis.fcond = Instr.T.Basis.fcond
++                                              and type I.T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                                              and type ('s,'r,'f,'c) I.T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                                              and type ('s,'r,'f,'c) I.T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                                              and type ('s,'r,'f,'c) I.T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                                              and type ('s,'r,'f,'c) I.T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                                              and type I.T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                                              and type I.T.ccexp = Instr.T.ccexp
++                                              and type I.T.fexp = Instr.T.fexp
++                                              (* and type I.T.labexp = Instr.T.labexp *)
++                                              and type I.T.mlrisc = Instr.T.mlrisc
++                                              and type I.T.oper = Instr.T.oper
++                                              and type I.T.rep = Instr.T.rep
++                                              and type I.T.rexp = Instr.T.rexp
++                                              and type I.T.stm = Instr.T.stm
++                                              and type I.branch = Instr.branch
++                                              and type I.cmove = Instr.cmove
++                                              and type I.ea = Instr.ea
++                                              and type I.fbranch = Instr.fbranch
++                                              and type I.fcmove = Instr.fcmove
++                                              and type I.fload = Instr.fload
++                                              and type I.foperate = Instr.foperate
++                                              and type I.foperateV = Instr.foperateV
++                                              and type I.fstore = Instr.fstore
++                                              and type I.funary = Instr.funary
++                                              and type I.instr = Instr.instr
++                                              and type I.instruction = Instr.instruction
++                                              and type I.load = Instr.load
++                                              and type I.operand = Instr.operand
++                                              and type I.operate = Instr.operate
++                                              and type I.operateV = Instr.operateV
++                                              and type I.osf_user_palcode = Instr.osf_user_palcode
++                                              and type I.pseudo_op = Instr.pseudo_op
++                                              and type I.store = Instr.store
++                        structure MLTreeEval : MLTREE_EVAL (* where T = Instr.T *)
++                                               where type T.Basis.cond = Instr.T.Basis.cond
++                                                 and type T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                                                 and type T.Basis.ext = Instr.T.Basis.ext
++                                                 and type T.Basis.fcond = Instr.T.Basis.fcond
++                                                 and type T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                                                 and type T.Constant.const = Instr.T.Constant.const
++                                                 and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                                                 and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                                                 and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                                                 and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                                                 and type T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                                                 and type T.Region.region = Instr.T.Region.region
++                                                 and type T.ccexp = Instr.T.ccexp
++                                                 and type T.fexp = Instr.T.fexp
++                                                 (* and type T.labexp = Instr.T.labexp *)
++                                                 and type T.mlrisc = Instr.T.mlrisc
++                                                 and type T.oper = Instr.T.oper
++                                                 and type T.rep = Instr.T.rep
++                                                 and type T.rexp = Instr.T.rexp
++                                                 and type T.stm = Instr.T.stm
+                        ) : INSTRUCTION_EMITTER =
+ struct
+    structure I  = Instr
+diff -Naur MLRISC/alpha/emit/alphaMC.sml MLRISC-mlton/alpha/emit/alphaMC.sml
+--- MLRISC/alpha/emit/alphaMC.sml	2002-01-09 14:44:18.000000000 -0500
++++ MLRISC-mlton/alpha/emit/alphaMC.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -6,7 +6,27 @@
+ 
+ 
+ functor AlphaMCEmitter(structure Instr : ALPHAINSTR
+-                       structure MLTreeEval : MLTREE_EVAL where T = Instr.T
++                       structure MLTreeEval : MLTREE_EVAL (* where T = Instr.T *)
++                                              where type T.Basis.cond = Instr.T.Basis.cond
++                                                and type T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                                                and type T.Basis.ext = Instr.T.Basis.ext
++                                                and type T.Basis.fcond = Instr.T.Basis.fcond
++                                                and type T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                                                and type T.Constant.const = Instr.T.Constant.const
++                                                and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                                                and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                                                and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                                                and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                                                and type T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                                                and type T.Region.region = Instr.T.Region.region
++                                                and type T.ccexp = Instr.T.ccexp
++                                                and type T.fexp = Instr.T.fexp
++                                                (* and type T.labexp = Instr.T.labexp *)
++                                                and type T.mlrisc = Instr.T.mlrisc
++                                                and type T.oper = Instr.T.oper
++                                                and type T.rep = Instr.T.rep
++                                                and type T.rexp = Instr.T.rexp
++                                                and type T.stm = Instr.T.stm
+                        structure Stream : INSTRUCTION_STREAM 
+                        structure CodeString : CODE_STRING
+                       ) : INSTRUCTION_EMITTER =
+@@ -47,6 +67,7 @@
+        (* note: fromLargeWord strips the high order bits! *)
+        fun eByteW w =
+        let val i = !loc
++           val w = W.toLargeWord w
+        in loc := i + 1; CodeString.update(i,Word8.fromLargeWord w) end
+    
+        fun doNothing _ = ()
+diff -Naur MLRISC/alpha/flowgraph/alphaGasPseudoOps.sml MLRISC-mlton/alpha/flowgraph/alphaGasPseudoOps.sml
+--- MLRISC/alpha/flowgraph/alphaGasPseudoOps.sml	2001-11-21 13:39:55.000000000 -0500
++++ MLRISC-mlton/alpha/flowgraph/alphaGasPseudoOps.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -1,6 +1,26 @@
+ functor AlphaGasPseudoOps 
+    ( structure T : MLTREE
+-     structure MLTreeEval : MLTREE_EVAL  where T = T
++     structure MLTreeEval : MLTREE_EVAL (* where T = T *)
++                            where type T.Basis.cond = T.Basis.cond
++                              and type T.Basis.div_rounding_mode = T.Basis.div_rounding_mode
++                              and type T.Basis.ext = T.Basis.ext
++                              and type T.Basis.fcond = T.Basis.fcond
++                              and type T.Basis.rounding_mode = T.Basis.rounding_mode
++                              and type T.Constant.const = T.Constant.const
++                              and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) T.Extension.ccx
++                              and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) T.Extension.fx
++                              and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) T.Extension.rx
++                              and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) T.Extension.sx
++                              and type T.I.div_rounding_mode = T.I.div_rounding_mode
++                              and type T.Region.region = T.Region.region
++                              and type T.ccexp = T.ccexp
++                              and type T.fexp = T.fexp
++                              (* and type T.labexp = T.labexp *)
++                              and type T.mlrisc = T.mlrisc
++                              and type T.oper = T.oper
++                              and type T.rep = T.rep
++                              and type T.rexp = T.rexp
++                              and type T.stm = T.stm
+     ) : PSEUDO_OPS_BASIS = 
+ 
+ struct
+diff -Naur MLRISC/alpha/instructions/alphaInstr.sml MLRISC-mlton/alpha/instructions/alphaInstr.sml
+--- MLRISC/alpha/instructions/alphaInstr.sml	2002-01-24 00:45:15.000000000 -0500
++++ MLRISC-mlton/alpha/instructions/alphaInstr.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -8,7 +8,16 @@
+ signature ALPHAINSTR =
+ sig
+    structure C : ALPHACELLS
+-   structure CB : CELLS_BASIS = CellsBasis
++   structure CB : CELLS_BASIS (* = CellsBasis *)
++                  where type CellSet.cellset = CellsBasis.CellSet.cellset
++                    and type 'a ColorTable.hash_table = 'a CellsBasis.ColorTable.hash_table
++                    and type 'a HashTable.hash_table = 'a CellsBasis.HashTable.hash_table
++                    and type SortedCells.sorted_cells = CellsBasis.SortedCells.sorted_cells
++                    and type cell = CellsBasis.cell
++                    and type cellColor = CellsBasis.cellColor
++                    and type cellkind = CellsBasis.cellkind
++                    and type cellkindDesc = CellsBasis.cellkindDesc
++                    and type cellkindInfo = CellsBasis.cellkindInfo
+    structure T : MLTREE
+    structure Constant: CONSTANT
+    structure Region : REGION
+diff -Naur MLRISC/alpha/instructions/alphaProps.sml MLRISC-mlton/alpha/instructions/alphaProps.sml
+--- MLRISC/alpha/instructions/alphaProps.sml	2002-03-11 22:56:22.000000000 -0500
++++ MLRISC-mlton/alpha/instructions/alphaProps.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -6,8 +6,48 @@
+ 
+ functor AlphaProps
+    (structure Instr : ALPHAINSTR
+-    structure MLTreeHash :  MLTREE_HASH where T = Instr.T
+-    structure MLTreeEval : MLTREE_EVAL where T = Instr.T
++    structure MLTreeHash : MLTREE_HASH (* where T = Instr.T *)
++                           where type T.Basis.cond = Instr.T.Basis.cond
++                             and type T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                             and type T.Basis.ext = Instr.T.Basis.ext
++                             and type T.Basis.fcond = Instr.T.Basis.fcond
++                             and type T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                             and type T.Constant.const = Instr.T.Constant.const
++                             and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                             and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                             and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                             and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                             and type T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                             and type T.Region.region = Instr.T.Region.region
++                             and type T.ccexp = Instr.T.ccexp
++                             and type T.fexp = Instr.T.fexp
++                             (* and type T.labexp = Instr.T.labexp *)
++                             and type T.mlrisc = Instr.T.mlrisc
++                             and type T.oper = Instr.T.oper
++                             and type T.rep = Instr.T.rep
++                             and type T.rexp = Instr.T.rexp
++                             and type T.stm = Instr.T.stm
++    structure MLTreeEval : MLTREE_EVAL (* where T = Instr.T *)
++                           where type T.Basis.cond = Instr.T.Basis.cond
++                             and type T.Basis.div_rounding_mode = Instr.T.Basis.div_rounding_mode
++                             and type T.Basis.ext = Instr.T.Basis.ext
++                             and type T.Basis.fcond = Instr.T.Basis.fcond
++                             and type T.Basis.rounding_mode = Instr.T.Basis.rounding_mode
++                             and type T.Constant.const = Instr.T.Constant.const
++                             and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) Instr.T.Extension.ccx
++                             and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) Instr.T.Extension.fx
++                             and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) Instr.T.Extension.rx
++                             and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) Instr.T.Extension.sx
++                             and type T.I.div_rounding_mode = Instr.T.I.div_rounding_mode
++                             and type T.Region.region = Instr.T.Region.region
++                             and type T.ccexp = Instr.T.ccexp
++                             and type T.fexp = Instr.T.fexp
++                             (* and type T.labexp = Instr.T.labexp *)
++                             and type T.mlrisc = Instr.T.mlrisc
++                             and type T.oper = Instr.T.oper
++                             and type T.rep = Instr.T.rep
++                             and type T.rexp = Instr.T.rexp
++                             and type T.stm = Instr.T.stm
+     ):INSN_PROPERTIES =
+ struct
+     structure I = Instr
+diff -Naur MLRISC/alpha/mltree/alphaPseudoInstr.sig MLRISC-mlton/alpha/mltree/alphaPseudoInstr.sig
+--- MLRISC/alpha/mltree/alphaPseudoInstr.sig	2001-07-19 16:35:13.000000000 -0400
++++ MLRISC-mlton/alpha/mltree/alphaPseudoInstr.sig	2006-03-04 11:14:21.000000000 -0500
+@@ -4,10 +4,39 @@
+ sig
+    structure I : ALPHAINSTR
+    structure T : MLTREE
++                 where type Basis.cond = I.T.Basis.cond
++                   and type Basis.div_rounding_mode = I.T.Basis.div_rounding_mode
++                   and type Basis.ext = I.T.Basis.ext
++                   and type Basis.fcond = I.T.Basis.fcond
++                   and type Basis.rounding_mode = I.T.Basis.rounding_mode
++                   and type Constant.const = I.T.Constant.const
++                   and type ('s,'r,'f,'c) Extension.ccx = ('s,'r,'f,'c) I.T.Extension.ccx
++                   and type ('s,'r,'f,'c) Extension.fx = ('s,'r,'f,'c) I.T.Extension.fx
++                   and type ('s,'r,'f,'c) Extension.rx = ('s,'r,'f,'c) I.T.Extension.rx
++                   and type ('s,'r,'f,'c) Extension.sx = ('s,'r,'f,'c) I.T.Extension.sx
++                   and type I.div_rounding_mode = I.T.I.div_rounding_mode
++                   and type Region.region = I.T.Region.region
++                   and type ccexp = I.T.ccexp
++                   and type fexp = I.T.fexp
++                   (* and type labexp = I.T.labexp *)
++                   and type mlrisc = I.T.mlrisc
++                   and type oper = I.T.oper
++                   and type rep = I.T.rep
++                   and type rexp = I.T.rexp
++                   and type stm = I.T.stm
+    structure C : ALPHACELLS
+-     sharing C = I.C
+-     sharing I.T = T
+-   structure CB: CELLS_BASIS = CellsBasis
++     (* sharing C = I.C *)
++     (* sharing I.T = T *)
++   structure CB: CELLS_BASIS (* = CellsBasis *)
++                 where type CellSet.cellset = CellsBasis.CellSet.cellset
++                   and type 'a ColorTable.hash_table = 'a CellsBasis.ColorTable.hash_table
++                   and type 'a HashTable.hash_table = 'a CellsBasis.HashTable.hash_table
++                   and type SortedCells.sorted_cells = CellsBasis.SortedCells.sorted_cells
++                   and type cell = CellsBasis.cell
++                   and type cellColor = CellsBasis.cellColor
++                   and type cellkind = CellsBasis.cellkind
++                   and type cellkindDesc = CellsBasis.cellkindDesc
++                   and type cellkindInfo = CellsBasis.cellkindInfo
+   
+    type reduceOpnd = I.operand -> CB.cell
+ 
+diff -Naur MLRISC/alpha/mltree/alpha.sml MLRISC-mlton/alpha/mltree/alpha.sml
+--- MLRISC/alpha/mltree/alpha.sml	2003-08-28 17:58:42.000000000 -0400
++++ MLRISC-mlton/alpha/mltree/alpha.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -11,11 +11,72 @@
+ 
+ functor Alpha
+    (structure AlphaInstr : ALPHAINSTR 
+-    structure PseudoInstrs : ALPHA_PSEUDO_INSTR
+-    			where I = AlphaInstr
+-    structure ExtensionComp : MLTREE_EXTENSION_COMP
+-    			where I = AlphaInstr
+-			  and T = AlphaInstr.T
++    structure PseudoInstrs : ALPHA_PSEUDO_INSTR (* where I = AlphaInstr *)
++                             where type I.Constant.const = AlphaInstr.Constant.const
++                               and type I.Region.region = AlphaInstr.Region.region
++                               and type I.T.Basis.cond = AlphaInstr.T.Basis.cond
++                               and type I.T.Basis.div_rounding_mode = AlphaInstr.T.Basis.div_rounding_mode
++                               and type I.T.Basis.ext = AlphaInstr.T.Basis.ext
++                               and type I.T.Basis.fcond = AlphaInstr.T.Basis.fcond
++                               and type I.T.Basis.rounding_mode = AlphaInstr.T.Basis.rounding_mode
++                               and type ('s,'r,'f,'c) I.T.Extension.ccx = ('s,'r,'f,'c) AlphaInstr.T.Extension.ccx
++                               and type ('s,'r,'f,'c) I.T.Extension.fx = ('s,'r,'f,'c) AlphaInstr.T.Extension.fx
++                               and type ('s,'r,'f,'c) I.T.Extension.rx = ('s,'r,'f,'c) AlphaInstr.T.Extension.rx
++                               and type ('s,'r,'f,'c) I.T.Extension.sx = ('s,'r,'f,'c) AlphaInstr.T.Extension.sx
++                               and type I.T.I.div_rounding_mode = AlphaInstr.T.I.div_rounding_mode
++                               and type I.T.ccexp = AlphaInstr.T.ccexp
++                               and type I.T.fexp = AlphaInstr.T.fexp
++                               (* and type I.T.labexp = AlphaInstr.T.labexp *)
++                               and type I.T.mlrisc = AlphaInstr.T.mlrisc
++                               and type I.T.oper = AlphaInstr.T.oper
++                               and type I.T.rep = AlphaInstr.T.rep
++                               and type I.T.rexp = AlphaInstr.T.rexp
++                               and type I.T.stm = AlphaInstr.T.stm
++                               and type I.branch = AlphaInstr.branch
++                               and type I.cmove = AlphaInstr.cmove
++                               and type I.ea = AlphaInstr.ea
++                               and type I.fbranch = AlphaInstr.fbranch
++                               and type I.fcmove = AlphaInstr.fcmove
++                               and type I.fload = AlphaInstr.fload
++                               and type I.foperate = AlphaInstr.foperate
++                               and type I.foperateV = AlphaInstr.foperateV
++                               and type I.fstore = AlphaInstr.fstore
++                               and type I.funary = AlphaInstr.funary
++                               and type I.instr = AlphaInstr.instr
++                               and type I.instruction = AlphaInstr.instruction
++                               and type I.load = AlphaInstr.load
++                               and type I.operand = AlphaInstr.operand
++                               and type I.operate = AlphaInstr.operate
++                               and type I.operateV = AlphaInstr.operateV
++                               and type I.osf_user_palcode = AlphaInstr.osf_user_palcode
++                               and type I.pseudo_op = AlphaInstr.pseudo_op
++                               and type I.store = AlphaInstr.store
++    structure ExtensionComp : MLTREE_EXTENSION_COMP (* where I = AlphaInstr and T = AlphaInstr.T *)
++                              where type I.addressing_mode = AlphaInstr.addressing_mode
++                                and type I.ea = AlphaInstr.ea
++                                and type I.instr = AlphaInstr.instr
++                                and type I.instruction = AlphaInstr.instruction
++                                and type I.operand = AlphaInstr.operand
++                              where type T.Basis.cond = AlphaInstr.T.Basis.cond
++                                and type T.Basis.div_rounding_mode = AlphaInstr.T.Basis.div_rounding_mode
++                                and type T.Basis.ext = AlphaInstr.T.Basis.ext
++                                and type T.Basis.fcond = AlphaInstr.T.Basis.fcond
++                                and type T.Basis.rounding_mode = AlphaInstr.T.Basis.rounding_mode
++                                and type T.Constant.const = AlphaInstr.T.Constant.const
++                                and type ('s,'r,'f,'c) T.Extension.ccx = ('s,'r,'f,'c) AlphaInstr.T.Extension.ccx
++                                and type ('s,'r,'f,'c) T.Extension.fx = ('s,'r,'f,'c) AlphaInstr.T.Extension.fx
++                                and type ('s,'r,'f,'c) T.Extension.rx = ('s,'r,'f,'c) AlphaInstr.T.Extension.rx
++                                and type ('s,'r,'f,'c) T.Extension.sx = ('s,'r,'f,'c) AlphaInstr.T.Extension.sx
++                                and type T.I.div_rounding_mode = AlphaInstr.T.I.div_rounding_mode
++                                and type T.Region.region = AlphaInstr.T.Region.region
++                                and type T.ccexp = AlphaInstr.T.ccexp
++                                and type T.fexp = AlphaInstr.T.fexp
++                                (* and type T.labexp = AlphaInstr.T.labexp *)
++                                and type T.mlrisc = AlphaInstr.T.mlrisc
++                                and type T.oper = AlphaInstr.T.oper
++                                and type T.rep = AlphaInstr.T.rep
++                                and type T.rexp = AlphaInstr.T.rexp
++                                and type T.stm = AlphaInstr.T.stm
+ 
+       (* Cost of multiplication in cycles *)
+     val multCost : int ref
+@@ -215,7 +276,9 @@
+    * Specialize the modules for multiplication/division 
+    * by constant optimizations.
+    *)
+-  functor Multiply32 = MLTreeMult
++
++  (* signed, trapping version of multiply and divide *)
++  structure Mult32 = MLTreeMult
+     (structure I = I
+      structure T = T
+      structure CB = CellsBasis
+@@ -256,40 +319,115 @@
+          in  [I.operate{oper=I.ADDL,ra=r,rb=zeroOpn,rc=tmp},
+               I.operate{oper=I.SRA,ra=tmp,rb=I.IMMop i,rc=d}]
+          end 
+-    )
++     
++     val trapping = true
++     val multCost = multCost
++     fun addv{r1,r2,d} = [I.operatev{oper=I.ADDLV,ra=r1,rb=I.REGop r2,rc=d}]
++     fun subv{r1,r2,d} = [I.operatev{oper=I.SUBLV,ra=r1,rb=I.REGop r2,rc=d}]
++     val sh1addv = NONE
++     val sh2addv = NONE
++     val sh3addv = NONE
++     
++     val signed = true)
+ 
+-  functor Multiply64 = MLTreeMult
++  (* unsigned, non-trapping version of multiply and divide *)
++  structure Mulu32 = MLTreeMult
+     (structure I = I
+      structure T = T
+      structure CB = CellsBasis
+-   
+-     val intTy = 64
+ 
+-     type arg  = {r1:CB.cell, r2:CB.cell, d:CB.cell}
+-     type argi = {r:CB.cell, i:int, d:CB.cell}
++     val intTy = 32
++   
++     type arg  = {r1:CB.cell,r2:CB.cell,d:CB.cell}
++     type argi = {r:CB.cell,i:int,d:CB.cell}
+ 
+      fun mov{r,d}    = I.COPY{k=CB.GP, sz=intTy, dst=[d],src=[r],tmp=NONE}
+-     fun add{r1,r2,d}= I.operate{oper=I.ADDQ,ra=r1,rb=I.REGop r2,rc=d}
+-     fun slli{r,i,d} = [I.operate{oper=I.SLL,ra=r,rb=I.IMMop i,rc=d}]
+-     fun srli{r,i,d} = [I.operate{oper=I.SRL,ra=r,rb=I.IMMop i,rc=d}]
+-     fun srai{r,i,d} = [I.operate{oper=I.SRA,ra=r,rb=I.IMMop i,rc=d}]
+-    )
++     fun add{r1,r2,d} = I.operate{oper=I.ADDL,ra=r1,rb=I.REGop r2,rc=d}
++     (*
++      * How to left shift by a constant (32bits)
++      *)
++     fun slli{r,i=1,d} = [I.operate{oper=I.ADDL,ra=r,rb=I.REGop r,rc=d}]
++       | slli{r,i=2,d} = [I.operate{oper=I.S4ADDL,ra=r,rb=zeroOpn,rc=d}]
++       | slli{r,i=3,d} = [I.operate{oper=I.S8ADDL,ra=r,rb=zeroOpn,rc=d}]
++       | slli{r,i,d}   = 
++          let val tmp = C.newReg()
++          in  [I.operate{oper=I.SLL,ra=r,rb=I.IMMop i,rc=tmp},
++               I.operate{oper=I.ADDL,ra=tmp,rb=zeroOpn,rc=d}]
++          end
+ 
+-  (* signed, trapping version of multiply and divide *)
+-  structure Mult32 = Multiply32
+-    (val trapping = true
++     (* 
++      * How to right shift (unsigned) by a constant (32bits)
++      *)
++     fun srli{r,i,d} =
++         let val tmp = C.newReg()
++         in  [I.operate{oper=I.ZAP,ra=r,rb=I.IMMop 0xf0,rc=tmp},
++              I.operate{oper=I.SRL,ra=tmp,rb=I.IMMop i,rc=d}]
++         end
++
++     (* 
++      * How to right shift (signed) by a constant (32bits)
++      *)
++     fun srai{r,i,d} = 
++         let val tmp = C.newReg()
++         in  [I.operate{oper=I.ADDL,ra=r,rb=zeroOpn,rc=tmp},
++              I.operate{oper=I.SRA,ra=tmp,rb=I.IMMop i,rc=d}]
++         end 
++     
++     val trapping = false
+      val multCost = multCost
+-     fun addv{r1,r2,d} = [I.operatev{oper=I.ADDLV,ra=r1,rb=I.REGop r2,rc=d}]
+-     fun subv{r1,r2,d} = [I.operatev{oper=I.SUBLV,ra=r1,rb=I.REGop r2,rc=d}]
++     fun addv{r1,r2,d} = [I.operate{oper=I.ADDL,ra=r1,rb=I.REGop r2,rc=d}]
++     fun subv{r1,r2,d} = [I.operate{oper=I.SUBL,ra=r1,rb=I.REGop r2,rc=d}]
+      val sh1addv = NONE
+-     val sh2addv = NONE
+-     val sh3addv = NONE
+-    )
+-    (val signed = true)
++     val sh2addv = SOME(fn {r1,r2,d} => 
++                    [I.operate{oper=I.S4ADDL,ra=r1,rb=I.REGop r2,rc=d}])
++     val sh3addv = SOME(fn {r1,r2,d} => 
++                    [I.operate{oper=I.S8ADDL,ra=r1,rb=I.REGop r2,rc=d}])
++     
++     val signed = false)
++  (* signed, non-trapping version of multiply and divide *)
++  structure Muls32 = MLTreeMult
++    (structure I = I
++     structure T = T
++     structure CB = CellsBasis
+ 
+-  (* non-trapping version of multiply and divide *)
+-  functor Mul32 = Multiply32
+-    (val trapping = false
++     val intTy = 32
++   
++     type arg  = {r1:CB.cell,r2:CB.cell,d:CB.cell}
++     type argi = {r:CB.cell,i:int,d:CB.cell}
++
++     fun mov{r,d}    = I.COPY{k=CB.GP, sz=intTy, dst=[d],src=[r],tmp=NONE}
++     fun add{r1,r2,d} = I.operate{oper=I.ADDL,ra=r1,rb=I.REGop r2,rc=d}
++     (*
++      * How to left shift by a constant (32bits)
++      *)
++     fun slli{r,i=1,d} = [I.operate{oper=I.ADDL,ra=r,rb=I.REGop r,rc=d}]
++       | slli{r,i=2,d} = [I.operate{oper=I.S4ADDL,ra=r,rb=zeroOpn,rc=d}]
++       | slli{r,i=3,d} = [I.operate{oper=I.S8ADDL,ra=r,rb=zeroOpn,rc=d}]
++       | slli{r,i,d}   = 
++          let val tmp = C.newReg()
++          in  [I.operate{oper=I.SLL,ra=r,rb=I.IMMop i,rc=tmp},
++               I.operate{oper=I.ADDL,ra=tmp,rb=zeroOpn,rc=d}]
++          end
++
++     (* 
++      * How to right shift (unsigned) by a constant (32bits)
++      *)
++     fun srli{r,i,d} =
++         let val tmp = C.newReg()
++         in  [I.operate{oper=I.ZAP,ra=r,rb=I.IMMop 0xf0,rc=tmp},
++              I.operate{oper=I.SRL,ra=tmp,rb=I.IMMop i,rc=d}]
++         end
++
++     (* 
++      * How to right shift (signed) by a constant (32bits)
++      *)
++     fun srai{r,i,d} = 
++         let val tmp = C.newReg()
++         in  [I.operate{oper=I.ADDL,ra=r,rb=zeroOpn,rc=tmp},
++              I.operate{oper=I.SRA,ra=tmp,rb=I.IMMop i,rc=d}]
++         end 
++     
++     val trapping = false
+      val multCost = multCost
+      fun addv{r1,r2,d} = [I.operate{oper=I.ADDL,ra=r1,rb=I.REGop r2,rc=d}]
+      fun subv{r1,r2,d} = [I.operate{oper=I.SUBL,ra=r1,rb=I.REGop r2,rc=d}]
+@@ -298,25 +436,82 @@
+                     [I.operate{oper=I.S4ADDL,ra=r1,rb=I.REGop r2,rc=d}])
+      val sh3addv = SOME(fn {r1,r2,d} => 
+                     [I.operate{oper=I.S8ADDL,ra=r1,rb=I.REGop r2,rc=d}])
+-    )
+-  structure Mulu32 = Mul32(val signed = false)
+-  structure Muls32 = Mul32(val signed = true)
++     
++     val signed = true)
+ 
+   (* signed, trapping version of multiply and divide *)
+-  structure Mult64 = Multiply64
+-    (val trapping = true
++  structure Mult64 = MLTreeMult
++    (structure I = I
++     structure T = T
++     structure CB = CellsBasis
++   
++     val intTy = 64
++
++     type arg  = {r1:CB.cell, r2:CB.cell, d:CB.cell}
++     type argi = {r:CB.cell, i:int, d:CB.cell}
++
++     fun mov{r,d}    = I.COPY{k=CB.GP, sz=intTy, dst=[d],src=[r],tmp=NONE}
++     fun add{r1,r2,d}= I.operate{oper=I.ADDQ,ra=r1,rb=I.REGop r2,rc=d}
++     fun slli{r,i,d} = [I.operate{oper=I.SLL,ra=r,rb=I.IMMop i,rc=d}]
++     fun srli{r,i,d} = [I.operate{oper=I.SRL,ra=r,rb=I.IMMop i,rc=d}]
++     fun srai{r,i,d} = [I.operate{oper=I.SRA,ra=r,rb=I.IMMop i,rc=d}]
++     
++     val trapping = true
+      val multCost = multCost
+      fun addv{r1,r2,d} = [I.operatev{oper=I.ADDQV,ra=r1,rb=I.REGop r2,rc=d}]
+      fun subv{r1,r2,d} = [I.operatev{oper=I.SUBQV,ra=r1,rb=I.REGop r2,rc=d}]
+      val sh1addv = NONE
+      val sh2addv = NONE
+      val sh3addv = NONE
+-    )
+-    (val signed = true)
++     
++     val signed = true)
+ 
+   (* unsigned, non-trapping version of multiply and divide *)
+-  functor Mul64 = Multiply64
+-    (val trapping = false
++  structure Mulu64 = MLTreeMult
++    (structure I = I
++     structure T = T
++     structure CB = CellsBasis
++   
++     val intTy = 64
++
++     type arg  = {r1:CB.cell, r2:CB.cell, d:CB.cell}
++     type argi = {r:CB.cell, i:int, d:CB.cell}
++
++     fun mov{r,d}    = I.COPY{k=CB.GP, sz=intTy, dst=[d],src=[r],tmp=NONE}
++     fun add{r1,r2,d}= I.operate{oper=I.ADDQ,ra=r1,rb=I.REGop r2,rc=d}
++     fun slli{r,i,d} = [I.operate{oper=I.SLL,ra=r,rb=I.IMMop i,rc=d}]
++     fun srli{r,i,d} = [I.operate{oper=I.SRL,ra=r,rb=I.IMMop i,rc=d}]
++     fun srai{r,i,d} = [I.operate{oper=I.SRA,ra=r,rb=I.IMMop i,rc=d}]
++    
++     val trapping = false
++     val multCost = multCost
++     fun addv{r1,r2,d} = [I.operate{oper=I.ADDQ,ra=r1,rb=I.REGop r2,rc=d}]
++     fun subv{r1,r2,d} = [I.operate{oper=I.SUBQ,ra=r1,rb=I.REGop r2,rc=d}]
++     val sh1addv = NONE
++     val sh2addv = SOME(fn {r1,r2,d} => 
++                    [I.operate{oper=I.S4ADDQ,ra=r1,rb=I.REGop r2,rc=d}])
++     val sh3addv = SOME(fn {r1,r2,d} => 
++                    [I.operate{oper=I.S8ADDQ,ra=r1,rb=I.REGop r2,rc=d}])
++     
++     val signed = false)
++  (* signed, non-trapping version of multiply and divide *)
++  structure Muls64 = MLTreeMult
++    (structure I = I
++     structure T = T
++     structure CB = CellsBasis
++   
++     val intTy = 64
++
++     type arg  = {r1:CB.cell, r2:CB.cell, d:CB.cell}
++     type argi = {r:CB.cell, i:int, d:CB.cell}
++
++     fun mov{r,d}    = I.COPY{k=CB.GP, sz=intTy, dst=[d],src=[r],tmp=NONE}
++     fun add{r1,r2,d}= I.operate{oper=I.ADDQ,ra=r1,rb=I.REGop r2,rc=d}
++     fun slli{r,i,d} = [I.operate{oper=I.SLL,ra=r,rb=I.IMMop i,rc=d}]
++     fun srli{r,i,d} = [I.operate{oper=I.SRL,ra=r,rb=I.IMMop i,rc=d}]
++     fun srai{r,i,d} = [I.operate{oper=I.SRA,ra=r,rb=I.IMMop i,rc=d}]
++     
++     val trapping = false
+      val multCost = multCost
+      fun addv{r1,r2,d} = [I.operate{oper=I.ADDQ,ra=r1,rb=I.REGop r2,rc=d}]
+      fun subv{r1,r2,d} = [I.operate{oper=I.SUBQ,ra=r1,rb=I.REGop r2,rc=d}]
+@@ -325,9 +520,8 @@
+                     [I.operate{oper=I.S4ADDQ,ra=r1,rb=I.REGop r2,rc=d}])
+      val sh3addv = SOME(fn {r1,r2,d} => 
+                     [I.operate{oper=I.S8ADDQ,ra=r1,rb=I.REGop r2,rc=d}])
+-    )
+-  structure Mulu64 = Mul64(val signed = false)
+-  structure Muls64 = Mul64(val signed = true)
++     
++     val signed = true)
+ 
+   (* 
+    * The main stuff
+@@ -971,10 +1165,10 @@
+              *)
+           | T.ADD(64,e,T.LABEXP le) => mark(I.LDA{r=d,b=expr e,d=I.LABop le},an)
+           | T.ADD(64,T.LABEXP le,e) => mark(I.LDA{r=d,b=expr e,d=I.LABop le},an)
+-          | T.ADD(64,e,x as (T.CONST _ | T.LABEL _))  => 
+-               mark(I.LDA{r=d,b=expr e,d=I.LABop x},an)
+-          | T.ADD(64,x as (T.CONST _ | T.LABEL _),e)  => 
+-               mark(I.LDA{r=d,b=expr e,d=I.LABop x},an)
++          | T.ADD(64,e,x as T.CONST _) => mark(I.LDA{r=d,b=expr e,d=I.LABop x},an)
++          | T.ADD(64,e,x as T.LABEL _) => mark(I.LDA{r=d,b=expr e,d=I.LABop x},an)
++          | T.ADD(64,x as T.CONST _,e) => mark(I.LDA{r=d,b=expr e,d=I.LABop x},an)
++          | T.ADD(64,x as T.LABEL _,e) => mark(I.LDA{r=d,b=expr e,d=I.LABop x},an)
+           | T.ADD(64,e,T.LI i)     => loadImmed(i, expr e, d, an)
+           | T.ADD(64,T.LI i,e)     => loadImmed(i, expr e, d, an)
+ 	  | T.SUB(sz, a, b as T.LI z)    =>
+@@ -1067,8 +1261,13 @@
+           | T.SX(_,_,T.LOAD(8,ea,mem)) => load8s(ea,d,mem,an)
+           | T.SX(_,_,T.LOAD(16,ea,mem))=> load16s(ea,d,mem,an)
+           | T.SX(_,_,T.LOAD(32,ea,mem))=> load32s(ea,d,mem,an)
+-          | T.ZX((8|16|32|64),_,T.LOAD(8,ea,mem)) => load8(ea,d,mem,an)
+-          | T.ZX((16|32|64),_,T.LOAD(16,ea,mem))=> load16(ea,d,mem,an)
++          | T.ZX(8,_,T.LOAD(8,ea,mem)) => load8(ea,d,mem,an)
++          | T.ZX(16,_,T.LOAD(8,ea,mem)) => load8(ea,d,mem,an)
++          | T.ZX(32,_,T.LOAD(8,ea,mem)) => load8(ea,d,mem,an)
++          | T.ZX(64,_,T.LOAD(8,ea,mem)) => load8(ea,d,mem,an)
++          | T.ZX(16,_,T.LOAD(16,ea,mem))=> load16(ea,d,mem,an)
++          | T.ZX(32,_,T.LOAD(16,ea,mem))=> load16(ea,d,mem,an)
++          | T.ZX(64,_,T.LOAD(16,ea,mem))=> load16(ea,d,mem,an)
+           | T.ZX(64,_,T.LOAD(64,ea,mem)) => load(I.LDQ,ea,d,mem,an)
+           | T.LOAD(8,ea,mem) => load8(ea,d,mem,an)
+           | T.LOAD(16,ea,mem) => load16(ea,d,mem,an)
+@@ -1391,8 +1590,10 @@
+               val (cond,a,b) = 
+                 (* move the immed operand to b *)
+                 case a of
+-                  (T.LI _ | T.CONST _ | T.LABEL _ | T.LABEXP _) => 
+-                    (T.Basis.swapCond cond,b,a)
++                  T.LI _ => (T.Basis.swapCond cond,b,a)
++                | T.CONST _ => (T.Basis.swapCond cond,b,a)
++                | T.LABEL _ => (T.Basis.swapCond cond,b,a)
++                | T.LABEXP _ => (T.Basis.swapCond cond,b,a)
+                 | _ => (cond,a,b)
+ 
+               fun sub(a, T.LI z) = 
+@@ -1455,8 +1656,10 @@
+                   end
+               val (cond,e1,e2) =
+ 		  case e1 of
+-                    (T.LI _ | T.CONST _ | T.LABEL _ | T.LABEXP _) => 
+-                       (T.Basis.swapCond cond,e2,e1)
++                    T.LI _ => (T.Basis.swapCond cond,e2,e1)
++                  | T.CONST _ => (T.Basis.swapCond cond,e2,e1)
++                  | T.LABEL _ => (T.Basis.swapCond cond,e2,e1)
++                  | T.LABEXP _ => (T.Basis.swapCond cond,e2,e1)
+                   | _ => (cond,e1,e2)
+           in  case cond of
+                 T.EQ  => eq(e1,e2,d)
+diff -Naur MLRISC/backpatch/backpatch.sml MLRISC-mlton/backpatch/backpatch.sml
+--- MLRISC/backpatch/backpatch.sml	2002-03-11 22:56:22.000000000 -0500
++++ MLRISC-mlton/backpatch/backpatch.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -8,13 +8,45 @@
+ 
+ functor BBSched2
+     (structure Emitter : INSTRUCTION_EMITTER
+-     structure CFG     : CONTROL_FLOW_GRAPH
+-			where I = Emitter.I
+-		          and P = Emitter.S.P
+-     structure Jumps   : SDI_JUMPS
+-     			where I = CFG.I
+-     structure Props   : INSN_PROPERTIES
+-			where I = CFG.I
++     structure CFG     : CONTROL_FLOW_GRAPH (* where I = Emitter.I and P = Emitter.S.P *)
++                         where type I.addressing_mode = Emitter.I.addressing_mode
++                           and type I.ea = Emitter.I.ea
++                           and type I.instr = Emitter.I.instr
++                           and type I.instruction = Emitter.I.instruction
++                           and type I.operand = Emitter.I.operand
++                         where type P.Client.pseudo_op = Emitter.S.P.Client.pseudo_op
++                           and type P.T.Basis.cond = Emitter.S.P.T.Basis.cond
++                           and type P.T.Basis.div_rounding_mode = Emitter.S.P.T.Basis.div_rounding_mode
++                           and type P.T.Basis.ext = Emitter.S.P.T.Basis.ext
++                           and type P.T.Basis.fcond = Emitter.S.P.T.Basis.fcond
++                           and type P.T.Basis.rounding_mode = Emitter.S.P.T.Basis.rounding_mode
++                           and type P.T.Constant.const = Emitter.S.P.T.Constant.const
++                           and type ('s,'r,'f,'c) P.T.Extension.ccx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.ccx
++                           and type ('s,'r,'f,'c) P.T.Extension.fx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.fx
++                           and type ('s,'r,'f,'c) P.T.Extension.rx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.rx
++                           and type ('s,'r,'f,'c) P.T.Extension.sx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.sx
++                           and type P.T.I.div_rounding_mode = Emitter.S.P.T.I.div_rounding_mode
++                           and type P.T.Region.region = Emitter.S.P.T.Region.region
++                           and type P.T.ccexp = Emitter.S.P.T.ccexp
++                           and type P.T.fexp = Emitter.S.P.T.fexp
++                           (* and type P.T.labexp = Emitter.S.P.T.labexp *)
++                           and type P.T.mlrisc = Emitter.S.P.T.mlrisc
++                           and type P.T.oper = Emitter.S.P.T.oper
++                           and type P.T.rep = Emitter.S.P.T.rep
++                           and type P.T.rexp = Emitter.S.P.T.rexp
++                           and type P.T.stm = Emitter.S.P.T.stm
++     structure Jumps   : SDI_JUMPS (* where I = CFG.I *)
++                         where type I.addressing_mode = CFG.I.addressing_mode
++                           and type I.ea = CFG.I.ea
++                           and type I.instr = CFG.I.instr
++                           and type I.instruction = CFG.I.instruction
++                           and type I.operand = CFG.I.operand
++     structure Props   : INSN_PROPERTIES (* where I = CFG.I *)
++                         where type I.addressing_mode = CFG.I.addressing_mode
++                           and type I.ea = CFG.I.ea
++                           and type I.instr = CFG.I.instr
++                           and type I.instruction = CFG.I.instruction
++                           and type I.operand = CFG.I.operand
+     ) = 
+ struct
+ 
+diff -Naur MLRISC/backpatch/sdi-jumps.sig MLRISC-mlton/backpatch/sdi-jumps.sig
+--- MLRISC/backpatch/sdi-jumps.sig	2000-12-07 23:11:33.000000000 -0500
++++ MLRISC-mlton/backpatch/sdi-jumps.sig	2006-03-04 11:14:21.000000000 -0500
+@@ -7,7 +7,7 @@
+ signature SDI_JUMPS = sig
+   structure I : INSTRUCTIONS
+   structure C : CELLS
+-    sharing I.C = C
++    (* sharing I.C = C *)
+ 
+   val branchDelayedArch : bool
+ 
+diff -Naur MLRISC/backpatch/spanDep.sml MLRISC-mlton/backpatch/spanDep.sml
+--- MLRISC/backpatch/spanDep.sml	2002-10-10 10:48:47.000000000 -0400
++++ MLRISC-mlton/backpatch/spanDep.sml	2006-03-04 11:14:21.000000000 -0500
+@@ -9,18 +9,79 @@
+ 
+ functor SpanDependencyResolution
+     (structure Emitter   : INSTRUCTION_EMITTER
+-     structure CFG       : CONTROL_FLOW_GRAPH
+-                             where I = Emitter.I
+-                          and P = Emitter.S.P
+-     structure Jumps     : SDI_JUMPS
+-                             where I = CFG.I
+-     structure DelaySlot : DELAY_SLOT_PROPERTIES
+-                             where I = CFG.I
+-     structure Props     : INSN_PROPERTIES
+-                             where I = CFG.I
+-     structure Asm        : INSTRUCTION_EMITTER
+-                             where I = CFG.I
+-                             and   S = Emitter.S
++     structure CFG       : CONTROL_FLOW_GRAPH (* where I = Emitter.I and P = Emitter.S.P *)
++                           where type I.addressing_mode = Emitter.I.addressing_mode
++                             and type I.ea = Emitter.I.ea
++                             and type I.instr = Emitter.I.instr
++                             and type I.instruction = Emitter.I.instruction
++                             and type I.operand = Emitter.I.operand
++                           where type P.Client.pseudo_op = Emitter.S.P.Client.pseudo_op
++                             and type P.T.Basis.cond = Emitter.S.P.T.Basis.cond
++                             and type P.T.Basis.div_rounding_mode = Emitter.S.P.T.Basis.div_rounding_mode
++                             and type P.T.Basis.ext = Emitter.S.P.T.Basis.ext
++                             and type P.T.Basis.fcond = Emitter.S.P.T.Basis.fcond
++                             and type P.T.Basis.rounding_mode = Emitter.S.P.T.Basis.rounding_mode
++                             and type P.T.Constant.const = Emitter.S.P.T.Constant.const
++                             and type ('s,'r,'f,'c) P.T.Extension.ccx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.ccx
++                             and type ('s,'r,'f,'c) P.T.Extension.fx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.fx
++                             and type ('s,'r,'f,'c) P.T.Extension.rx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.rx
++                             and type ('s,'r,'f,'c) P.T.Extension.sx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.sx
++                             and type P.T.I.div_rounding_mode = Emitter.S.P.T.I.div_rounding_mode
++                             and type P.T.Region.region = Emitter.S.P.T.Region.region
++                             and type P.T.ccexp = Emitter.S.P.T.ccexp
++                             and type P.T.fexp = Emitter.S.P.T.fexp
++                             (* and type P.T.labexp = Emitter.S.P.T.labexp *)
++                             and type P.T.mlrisc = Emitter.S.P.T.mlrisc
++                             and type P.T.oper = Emitter.S.P.T.oper
++                             and type P.T.rep = Emitter.S.P.T.rep
++                             and type P.T.rexp = Emitter.S.P.T.rexp
++                             and type P.T.stm = Emitter.S.P.T.stm
++     structure Jumps     : SDI_JUMPS (* where I = CFG.I *)
++                           where type I.addressing_mode = CFG.I.addressing_mode
++                             and type I.ea = CFG.I.ea
++                             and type I.instr = CFG.I.instr
++                             and type I.instruction = CFG.I.instruction
++                             and type I.operand = CFG.I.operand
++     structure DelaySlot : DELAY_SLOT_PROPERTIES (* where I = CFG.I *)
++                           where type I.addressing_mode = CFG.I.addressing_mode
++                             and type I.ea = CFG.I.ea
++                             and type I.instr = CFG.I.instr
++                             and type I.instruction = CFG.I.instruction
++                             and type I.operand = CFG.I.operand
++     structure Props     : INSN_PROPERTIES (* where I = CFG.I *)
++                           where type I.addressing_mode = CFG.I.addressing_mode
++                             and type I.ea = CFG.I.ea
++                             and type I.instr = CFG.I.instr
++                             and type I.instruction = CFG.I.instruction
++                             and type I.operand = CFG.I.operand
++     structure Asm       : INSTRUCTION_EMITTER (* where I = CFG.I and S = Emitter.S *)
++                           where type I.addressing_mode = CFG.I.addressing_mode
++                             and type I.ea = CFG.I.ea
++                             and type I.instr = CFG.I.instr
++                             and type I.instruction = CFG.I.instruction
++                             and type I.operand = CFG.I.operand
++                           where type S.P.Client.pseudo_op = Emitter.S.P.Client.pseudo_op
++                             and type S.P.T.Basis.cond = Emitter.S.P.T.Basis.cond
++                             and type S.P.T.Basis.div_rounding_mode = Emitter.S.P.T.Basis.div_rounding_mode
++                             and type S.P.T.Basis.ext = Emitter.S.P.T.Basis.ext
++                             and type S.P.T.Basis.fcond = Emitter.S.P.T.Basis.fcond
++                             and type S.P.T.Basis.rounding_mode = Emitter.S.P.T.Basis.rounding_mode
++                             and type S.P.T.Constant.const = Emitter.S.P.T.Constant.const
++                             and type ('s,'r,'f,'c) S.P.T.Extension.ccx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.ccx
++                             and type ('s,'r,'f,'c) S.P.T.Extension.fx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.fx
++                             and type ('s,'r,'f,'c) S.P.T.Extension.rx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.rx
++                             and type ('s,'r,'f,'c) S.P.T.Extension.sx = ('s,'r,'f,'c) Emitter.S.P.T.Extension.sx
++                             and type S.P.T.I.div_rounding_mode = Emitter.S.P.T.I.div_rounding_mode
++                           ...
 
[truncated message content]

[MLton-commit] r4372

[Matthew F. <fl...@ml...>]

Canonicalize re-anchored paths for conversion
----------------------------------------------------------------------

U   mlton/trunk/util/cm2mlb/cm2mlb-map
U   mlton/trunk/util/cm2mlb/cm2mlb.sml

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

Modified: mlton/trunk/util/cm2mlb/cm2mlb-map
===================================================================
--- mlton/trunk/util/cm2mlb/cm2mlb-map	2006-03-03 22:10:55 UTC (rev 4371)
+++ mlton/trunk/util/cm2mlb/cm2mlb-map	2006-03-04 14:35:22 UTC (rev 4372)
@@ -1,8 +1,11 @@
+$SMLNJ-BASIS           $(SML_LIB)/basis
 $basis.cm              $(SML_LIB)/basis
 $basis.cm/basis.cm     $(SML_LIB)/basis/basis.mlb
 
-$ml-yacc-lib.cm                    $(SML_LIB)/mlyacc-lib
-$ml-yacc-lib.cm/ml-yacc-lib.cm     $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
+$SMLNJ-ML-YACC-LIB                    $(SML_LIB)/mlyacc-lib
+$SMLNJ-ML-YACC-LIB/ml-yacc-lib.cm     $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
+$ml-yacc-lib.cm                       $(SML_LIB)/mlyacc-lib
+$ml-yacc-lib.cm/ml-yacc-lib.cm        $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
 
 $cml            $(SML_LIB)/cml
 $cml/cml.cm     $(SML_LIB)/cml/cml.mlb
@@ -10,6 +13,7 @@
 $c          $(SML_LIB)/mlnlffi-lib
 $c/c.cm     $(SML_LIB)/mlnlffi-lib/mlnlffi-lib.mlb
 
+$SMLNJ-LIB            $(SML_LIB)/smlnj-lib
 $smlnj-lib.cm         $(SML_LIB)/smlnj-lib/Util
 $controls-lib.cm      $(SML_LIB)/smlnj-lib/Controls
 $hash-cons-lib.cm     $(SML_LIB)/smlnj-lib/HashCons

Modified: mlton/trunk/util/cm2mlb/cm2mlb.sml
===================================================================
--- mlton/trunk/util/cm2mlb/cm2mlb.sml	2006-03-03 22:10:55 UTC (rev 4371)
+++ mlton/trunk/util/cm2mlb/cm2mlb.sml	2006-03-04 14:35:22 UTC (rev 4372)
@@ -175,6 +175,16 @@
                                then case String.fields (fn #"/" => true | _ => false) cmLibDescr of
                                        "$" :: (arcs as (arc0 :: _)) => 
                                           doitAnchoredPath (("$" ^ arc0) :: arcs)
+                                     | arc0 :: arcs =>
+                                          let
+                                             val arc0 =
+                                                case CharVector.findi (fn (_, #"(") => true | _ => false) arc0 of
+                                                   SOME (i, _) => 
+                                                      String.extract (arc0, i + 2, SOME (String.size arc0 - i - 3))
+                                                 | NONE => arc0
+                                          in 
+                                             doitAnchoredPath (arc0 :: arcs)
+                                          end
                                      | arcs => doitAnchoredPath arcs
                                else concat ["(* ", cmLibOSString, " ===> *) ", mlbLibDef ()]
                       in

[MLton-commit] r4371

[Matthew F. <fl...@ml...>]

Mostly refactored integer and text
----------------------------------------------------------------------

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/
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/char-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-top.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/pointer-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-top.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/string-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-prim.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-top.sml
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-choose.sml
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config0.sml
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config2.sml
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/position.sml
A   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/fixed-int.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/option.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-int.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-word.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/integer.sig
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sig
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sml
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.fun
D   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-string.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
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/byte.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char-global.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char0.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string-global.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string0.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring-global.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/cleaner.sig
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/cleaner.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/natural.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/string-comparisons.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/unique-id.fun
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/unique-id.sig

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

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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb	2006-03-03 22:10:55 UTC (rev 4371)
@@ -19,14 +19,42 @@
 
    ../integer/int0.sml
    ../integer/word0.sml
-   local ../config/bind-for-config0.sml in ann "forceUsed" in
+   local 
+      ../config/bind/int-prim.sml 
+      ../config/bind/pointer-prim.sml 
+      ../config/bind/real-prim.sml 
+      ../config/bind/word-prim.sml 
+   in ann "forceUsed" in
       ../config/objptr/$(OBJPTR_REP)
       ../config/header/$(HEADER_WORD)
       ../config/seq/$(SEQ_INDEX)
       ../config/c/misc/$(CTYPES)
    end end
    ../integer/int-inf0.sml
-   local ../config/bind-for-config0.sml in ann "forceUsed" in
+   local
+      local 
+         ../config/bind/int-prim.sml 
+         ../config/bind/intinf-prim.sml 
+         ../config/bind/word-prim.sml 
+      in ann "forceUsed" in
+         ../config/default/$(DEFAULT_INT)
+         ../config/default/$(DEFAULT_WORD)
+         ../config/default/large-int.sml
+         ../config/default/large-word.sml
+      end end
+   in
+      ../integer/int1.sml
+      ../integer/word1.sml
+   end
+
+   local 
+      ../config/bind/char-prim.sml 
+      ../config/bind/int-prim.sml 
+      ../config/bind/intinf-prim.sml 
+      ../config/bind/real-prim.sml 
+      ../config/bind/string-prim.sml 
+      ../config/bind/word-prim.sml 
+   in ann "forceUsed" in
       ../config/default/$(DEFAULT_CHAR)
       ../config/default/$(DEFAULT_INT)
       ../config/default/$(DEFAULT_REAL)
@@ -35,23 +63,6 @@
       ../config/default/large-real.sml
       ../config/default/large-word.sml
    end end
-   ../integer/int1.sml
-   ../integer/word1.sml
-   local ../config/bind-for-config0.sml in ann "forceUsed" in
-      ../config/default/$(DEFAULT_CHAR)
-      ../config/default/$(DEFAULT_INT)
-      ../config/default/$(DEFAULT_REAL)
-      ../config/default/$(DEFAULT_WORD)
-      ../config/default/large-int.sml
-      ../config/default/large-real.sml
-      ../config/default/large-word.sml
-   end end
-   local ../config/bind-for-config0.sml in ann "forceUsed" in
-      ../config/objptr/$(OBJPTR_REP)
-      ../config/header/$(HEADER_WORD)
-      ../config/seq/$(SEQ_INDEX)
-      ../config/c/misc/$(CTYPES)
-   end end
    ../general/general.sig
    ../general/general.sml
    ../general/option.sig
@@ -60,6 +71,11 @@
    ../list/list.sml
    ../list/list-pair.sig
    ../list/list-pair.sml
+   local 
+      ../config/bind/int-prim.sml 
+   in ann "forceUsed" in
+      ../config/seq/$(SEQ_INDEX)
+   end end
    ../arrays-and-vectors/slice.sig
    ../arrays-and-vectors/sequence.sig
    ../arrays-and-vectors/sequence.fun
@@ -92,63 +108,82 @@
    ../integer/int.sml
    ../integer/word.sig
    ../integer/word.sml
-   local ../config/bind-for-config1.sml in ann "forceUsed" in
+   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/objptr/$(OBJPTR_REP)
       ../config/c/misc/$(CTYPES)
    end end
    ../integer/int-inf.sig
    ../integer/int-inf.sml
-   local ../config/bind-for-config2.sml in ann "forceUsed" in
+   local 
+      ../config/bind/int-top.sml 
+      ../config/bind/intinf-top.sml 
+      ../config/bind/word-top.sml 
+   in ann "forceUsed" in
       ../config/default/$(DEFAULT_INT)
       ../config/default/$(DEFAULT_WORD)
+      ../config/default/fixed-int.sml
       ../config/default/large-int.sml
       ../config/default/large-word.sml
    end end
    ../integer/int-global.sml
    ../integer/word-global.sml
    ../top-level/arithmetic.sml
+   ../util/natural.sml
+   ../integer/embed-int.sml
+   ../integer/embed-word.sml
+   ../integer/pack-word.sig
+   (* ../integer/pack-word32.sml *)
 
-(*
    ../text/char.sig
    ../text/char.sml
+   ../text/string.sig
+   ../text/string.sml
    ../text/substring.sig
    ../text/substring.sml
-   ../text/string.sig
-   ../text/string.sml
-   local ../config/bind-for-config3.sml in ann "forceUsed" in
-      ../config/default/$(DEFAULT_CHAR)
-   end end
+   ../text/char-global.sml
+   ../text/string-global.sml
+   ../text/substring-global.sml
+   ../text/byte.sig
+   ../text/byte.sml
+   ../text/text.sig
+   ../text/text.sml
 
-      ../../misc/C.sig
-      ../../misc/C.sml
-      ../../real/IEEE-real.sig
-      ../../real/IEEE-real.sml
-      ../../real/math.sig
-      ../../real/real.sig
-      ../../real/real.fun
-      ../../integer/pack-word.sig
-      ../../integer/pack-word32.sml
-      ../../text/byte.sig
-      ../../text/byte.sml
-      ../../text/text.sig
-      ../../text/text.sml
-      ../../real/pack-real.sig
-      ../../real/pack-real.sml
-      ../../real/real32.sml
-      ../../real/real64.sml
-      ../../integer/patch.sml
-      ../../integer/embed-int.sml
-      ../../integer/embed-word.sml
-      ann "forceUsed" in
-         ../../config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
-      end
+   ../real/IEEE-real.sig
+   ../real/IEEE-real.sml
+   (* ../../misc/C.sig *)
+   (* ../../misc/C.sml *)
+   ../real/math.sig
+   ../real/real.sig
+   (* ../../real/real.fun *)
+   ../real/pack-real.sig
+   (* ../real/pack-real.sml *)
+   (* ../real/real32.sml *)
+   (* ../real/real64.sml *)
 
+(*
+   local 
+      ../config/bind/int-top.sml 
+      ../config/bind/pointer-prim.sml 
+      ../config/bind/real-top.sml 
+      ../config/bind/word-top.sml 
+   in ann "forceUsed" in
+      ../config/c/misc/$(CTYPES)
+      ../config/c/position.sml
+      ../config/c/sys-word.sml
+   end end
+*)
 
-      (* misc/unique-id.sig *)
-      (* misc/unique-id.fun *)
-      ../../misc/cleaner.sig
-      ../../misc/cleaner.sml
+   ../util/unique-id.sig
+   ../util/unique-id.fun
+   ../util/cleaner.sig
+   ../util/cleaner.sml
 
+(*
       ../../system/pre-os.sml
       ../../system/time.sig
       ../../system/time.sml

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/char-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/char-prim.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/char-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,10 @@
+(* 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 Char8 = Primitive.Char8
+structure Char16 = Primitive.Char16
+structure Char32 = Primitive.Char32

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-prim.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,11 @@
+(* 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 Int8 = Primitive.Int8
+structure Int16 = Primitive.Int16
+structure Int32 = Primitive.Int32
+structure Int64 = Primitive.Int64

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-top.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-top.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-top.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,11 @@
+(* 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 Int8 = Int8
+structure Int16 = Int16
+structure Int32 = Int32
+structure Int64 = Int64

Added: 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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,8 @@
+(* 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

Added: 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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,8 @@
+(* 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

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/pointer-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/pointer-prim.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/pointer-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,8 @@
+(* 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 Pointer = Primitive.Pointer

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-prim.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,9 @@
+(* 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 Real32 = Primitive.Real32
+structure Real64 = Primitive.Real64

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-top.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-top.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/real-top.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,9 @@
+(* 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 Real32 = Real32
+structure Real64 = Real64

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/string-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/string-prim.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/string-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,10 @@
+(* 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 String8 = Primitive.String8
+structure String16 = Primitive.String16
+structure String32 = Primitive.String32

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-prim.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-prim.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,11 @@
+(* 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 Word8 = Primitive.Word8
+structure Word16 = Primitive.Word16
+structure Word32 = Primitive.Word32
+structure Word64 = Primitive.Word64

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-top.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-top.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/word-top.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,11 @@
+(* 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 Word8 = Word8
+structure Word16 = Word16
+structure Word32 = Word32
+structure Word64 = Word64

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-choose.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-choose.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-choose.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,28 +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 Char8 = Primitive.Char8
-structure Char16 = Primitive.Char16
-structure Char32 = Primitive.Char32
-
-structure Int8 = Primitive.Int8
-structure Int16 = Primitive.Int16
-structure Int32 = Primitive.Int32
-structure Int64 = Primitive.Int64
-structure IntInf = Primitive.IntInf
-
-structure Real32 = Primitive.Real32
-structure Real64 = Primitive.Real64
-
-structure String8 = Primitive.String8
-structure String16 = Primitive.String16
-structure String32 = Primitive.String32
-
-structure Word8 = Primitive.Word8
-structure Word16 = Primitive.Word16
-structure Word32 = Primitive.Word32
-structure Word64 = Primitive.Word64

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config0.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config0.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,30 +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 Char8 = Primitive.Char8
-structure Char16 = Primitive.Char16
-structure Char32 = Primitive.Char32
-
-structure Int8 = Primitive.Int8
-structure Int16 = Primitive.Int16
-structure Int32 = Primitive.Int32
-structure Int64 = Primitive.Int64
-structure IntInf = Primitive.IntInf
-
-structure Pointer = Primitive.Pointer
-
-structure Real32 = Primitive.Real32
-structure Real64 = Primitive.Real64
-
-structure String8 = Primitive.String8
-structure String16 = Primitive.String16
-structure String32 = Primitive.String32
-
-structure Word8 = Primitive.Word8
-structure Word16 = Primitive.Word16
-structure Word32 = Primitive.Word32
-structure Word64 = Primitive.Word64

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,30 +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 Char8 = Primitive.Char8
-structure Char16 = Primitive.Char16
-structure Char32 = Primitive.Char32
-
-structure Int8 = Int8
-structure Int16 = Int16
-structure Int32 = Int32
-structure Int64 = Int64
-structure IntInf = Primitive.IntInf
-
-structure Pointer = Primitive.Pointer
-
-structure Real32 = Primitive.Real32
-structure Real64 = Primitive.Real64
-
-structure String8 = Primitive.String8
-structure String16 = Primitive.String16
-structure String32 = Primitive.String32
-
-structure Word8 = Word8
-structure Word16 = Word16
-structure Word32 = Word32
-structure Word64 = Word64

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config2.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config2.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config2.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,30 +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 Char8 = Primitive.Char8
-structure Char16 = Primitive.Char16
-structure Char32 = Primitive.Char32
-
-structure Int8 = Int8
-structure Int16 = Int16
-structure Int32 = Int32
-structure Int64 = Int64
-structure IntInf = IntInf
-
-structure Pointer = Primitive.Pointer
-
-structure Real32 = Primitive.Real32
-structure Real64 = Primitive.Real64
-
-structure String8 = Primitive.String8
-structure String16 = Primitive.String16
-structure String32 = Primitive.String32
-
-structure Word8 = Word8
-structure Word16 = Word16
-structure Word32 = Word32
-structure Word64 = Word64

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,30 +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 Char8 = Char8
-structure Char16 = Primitive.Char16
-structure Char32 = Primitive.Char32
-
-structure Int8 = Int8
-structure Int16 = Int16
-structure Int32 = Int32
-structure Int64 = Int64
-structure IntInf = IntInf
-
-structure Pointer = Primitive.Pointer
-
-structure Real32 = Primitive.Real32
-structure Real64 = Primitive.Real64
-
-structure String8 = String8
-structure String16 = Primitive.String16
-structure String32 = Primitive.String32
-
-structure Word8 = Word8
-structure Word16 = Word16
-structure Word32 = Word32
-structure Word64 = Word64

Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/position.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/position.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/position.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,12 @@
+(* 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 Position = C_Off
+
+functor Position_ChooseIntN (A: CHOOSE_INT_ARG) :
+   sig val f : Position.int A.t end =
+   C_Off_ChooseIntN (A)

Added: 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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,12 @@
+(* 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 SysWord = C_UIntmax
+
+functor SysWord_ChooseWordN (A: CHOOSE_WORD_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/fixed-int.sml (from rev 4352, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/large-int.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/large-int.sml	2006-02-10 03:21:00 UTC (rev 4352)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/fixed-int.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,12 @@
+(* 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 FixedInt = Int64
+
+functor FixedInt_ChooseIntN (A: CHOOSE_INT_ARG) :
+   sig val f : FixedInt.int A.t end =
+   ChooseIntN_Int64 (A)

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/option.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/option.sig	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/option.sig	2006-03-03 22:10:55 UTC (rev 4371)
@@ -15,8 +15,7 @@
       
       val app: ('a -> unit) -> 'a option -> unit
       val compose: ('a -> 'b) * ('c -> 'a option) -> 'c -> 'b option 
-      val composePartial:
-         ('a -> 'b option) * ('c -> 'a option) -> 'c -> 'b option 
+      val composePartial: ('a -> 'b option) * ('c -> 'a option) -> 'c -> 'b option 
       val filter: ('a -> bool) -> 'a -> 'a option 
       val join: 'a option option -> 'a option 
       val map: ('a -> 'b) -> 'a option -> 'b option 

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-int.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-int.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -10,7 +10,7 @@
       eqtype int
       type big
          
-      val precision': Int.int
+      val precision': Int32.int
       val fromBigUnsafe: big -> int
       val toBig: int -> big
    end
@@ -18,12 +18,18 @@
 functor EmbedInt (structure Big: INTEGER_EXTRA
                   structure Small: EMBED_INT where type big = Big.int): INTEGER =
    struct
-      val () = if Int.< (Small.precision', valOf Big.precision) then ()
+      structure Small =
+         struct
+            open Small
+            val precision': Int.int = Int32.toInt precision'
+         end
+
+      val () = if Int.< (Small.precision', Big.precision') then ()
                else raise Fail "EmbedWord"
 
       open Small
 
-      val shift = Word.fromInt (Int.- (valOf Big.precision, precision'))
+      val shift = Word.fromInt (Int.- (Big.precision', precision'))
 
       val extend: Big.int -> Big.int =
          fn i => Big.~>> (Big.<< (i, shift), shift)

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-word.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/embed-word.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -12,12 +12,18 @@
          
       val fromBigUnsafe: big -> word
       val toBig: word -> big
-      val wordSize: Int.int
+      val wordSize: Int32.int
    end
 
 functor EmbedWord (structure Big: WORD
                    structure Small: EMBED_WORD where type big = Big.word): WORD =
    struct
+      structure Small =
+         struct
+            open Small
+            val wordSize: Int.int = Int32.toInt wordSize
+         end
+
       val () = if Int.< (Small.wordSize, Big.wordSize) then ()
                else raise Fail "EmbedWord"
                   

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sig	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sig	2006-03-03 22:10:55 UTC (rev 4371)
@@ -28,4 +28,9 @@
          Big of BigWord.word Vector.vector
        | Small of SmallInt.int
       val rep: int -> rep
+
+      val +? : int * int -> int
+      val *? : int * int -> int
+      val -? : int * int -> int
+      val ~? : int -> int
    end

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/integer.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/integer.sig	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/integer.sig	2006-03-03 22:10:55 UTC (rev 4371)
@@ -75,12 +75,10 @@
 
       val fmt: StringCvt.radix -> int -> string
       val toString: int -> string
-(*
       val scan: (StringCvt.radix 
                  -> (char, 'a) StringCvt.reader 
                  -> (int, 'a) StringCvt.reader)
       val fromString: string -> int option
-*)
    end
 
 signature INTEGER_EXTRA =

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sig	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sig	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,18 +0,0 @@
-(* 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 CLEANER =
-   sig
-      type t
-
-      val addNew: t * (unit -> unit) -> unit
-      val atExit: t
-      val atLoadWorld: t
-      val clean: t -> unit
-      val new: unit -> t
-   end

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,24 +0,0 @@
-(* 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 Cleaner: CLEANER =
-struct
-
-type t = (unit -> unit) list ref
-
-fun new (): t = ref []
-
-fun addNew (cs, f) = cs := f :: (!cs)
-
-fun clean cs = app (fn c => c () handle _ => ()) (!cs)
-   
-val atExit = new ()
-   
-val atLoadWorld = new ()
-
-end

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.fun	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.fun	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,14 +0,0 @@
-(* 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.
- *)
-
-functor UniqueId () :> UNIQUE_ID =
-   struct
-      type t = unit ref
-
-      fun new (): t = ref ()
-   end

Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.sig	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.sig	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,14 +0,0 @@
-(* 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 UNIQUE_ID =
-   sig
-      type t
-         
-      val new: unit -> t
-   end

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -127,6 +127,7 @@
    struct
       open Int3
       type big = Int8.int
+      val fromBigUnsafe = _prim "WordU8_toWord3": big -> int;
       val precision' : Int32.int = 3
       val toBig = _prim "WordU3_toWord8": int -> big;
    end

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-string.sml (from rev 4348, 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-02-05 15:30:17 UTC (rev 4348)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-string.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,25 @@
+(* 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 String8 =
+   struct
+      open String8
+
+      val fromWord8Vector = 
+         _prim "Word8Vector_toString": Word8.word vector -> string;
+      val toWord8Vector = 
+         _prim "String_toWord8Vector": string -> Word8.word vector;
+   end
+                      
+end

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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb	2006-03-03 22:10:55 UTC (rev 4371)
@@ -20,13 +20,26 @@
       prim1.sml
    end 
    ../util/integral-comparisons.sml
+   ../util/string-comparisons.sml
    prim-char.sml
    prim-word.sml
    prim-int.sml
-   local ../config/bind-for-choose.sml in ann "forceUsed" in
+   local 
+      ../config/bind/char-prim.sml 
+      ../config/bind/int-prim.sml 
+      ../config/bind/intinf-prim.sml 
+      ../config/bind/real-prim.sml 
+      ../config/bind/string-prim.sml 
+      ../config/bind/word-prim.sml 
+   in ann "forceUsed" in
       ../config/choose.sml
    end end
-   local ../config/bind-for-config0.sml in ann "forceUsed" in
+   local 
+      ../config/bind/int-prim.sml 
+      ../config/bind/pointer-prim.sml 
+      ../config/bind/real-prim.sml 
+      ../config/bind/word-prim.sml 
+   in ann "forceUsed" in
       ../config/objptr/$(OBJPTR_REP)
       ../config/header/$(HEADER_WORD)
       ../config/seq/$(SEQ_INDEX)
@@ -34,6 +47,7 @@
    end end
    prim-intinf.sml
    prim-seq.sml
+   prim-string.sml
    prim-nullstring.sml
    prim-mlton.sml
    basis-ffi.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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -211,15 +211,6 @@
             end
          end
 
-
-      structure String =
-         struct
-            val fromWord8Vector =
-               _prim "Word8Vector_toString": Word8.word vector -> string;
-            val toWord8Vector =
-               _prim "String_toWord8Vector": string -> Word8.word vector;
-         end
-
       structure TextIO =
          struct
             val bufSize = _command_line_const "TextIO.bufSize": int = 4096;

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -43,13 +43,13 @@
                       (FE_TOWARDZERO, TO_ZERO)]
                   end
             in
-               val fromInt: int -> t =
+               val fromInt: C_Int.int -> t =
                   fn i =>
                   case List.find (fn (i', _) => i = i') modes of
                      NONE => raise Fail "IEEEReal.RoundingMode.fromInt"
                    | SOME (_, m) => m
                         
-               val toInt: t -> int =
+               val toInt: t -> C_Int.int =
                   fn m =>
                   let
                      open Prim.RoundingMode

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-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig	2006-03-03 22:10:55 UTC (rev 4371)
@@ -1,8 +1,3 @@
-structure LargeReal =
-   struct
-      type real = real
-   end
-
 signature PRE_REAL_GLOBAL =
   sig
       type real
@@ -29,7 +24,7 @@
       val abs: real -> real
       val class: real -> int
       val frexp: real * int ref -> real
-      val gdtoa: real * int * int * int ref -> Primitive.CString.t
+      val gdtoa: real * int * int * int ref -> C_String.t
       val fromInt: int -> real
       val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
       val ldexp: real * int -> real

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/byte.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/byte.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/byte.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -8,25 +8,24 @@
 
 structure Byte: BYTE =
    struct
-      val byteToChar = Primitive.Char.fromWord8
+      val byteToChar = Primitive.Char8.fromWord8Unsafe
 
-      val bytesToString = Primitive.String.fromWord8Vector o Word8Vector.toPoly
+      val bytesToString = Primitive.String8.fromWord8Vector o Word8Vector.toPoly
 
-      val charToByte = Primitive.Char.toWord8
+      val charToByte = Primitive.Char8.toWord8Unsafe
 
       fun packString (a: Word8Array.array, i: int, s: substring): unit =
-         Util.naturalForeach
+         Natural.foreach
          (Substring.size s, fn j =>
-          Word8Array.update (a, i +? j, charToByte (Substring.sub (s, j))))
+          Word8Array.update (a, i + j, charToByte (Substring.sub (s, j))))
 
-      val stringToBytes = Word8Vector.fromPoly o Primitive.String.toWord8Vector
+      val stringToBytes = Word8Vector.fromPoly o Primitive.String8.toWord8Vector
 
       local
          fun make (length, sub) s =
             String.tabulate (length s, fn i => byteToChar (sub (s, i)))
       in
          val unpackString = make (Word8ArraySlice.length, Word8ArraySlice.sub)
-         val unpackStringVec =
-            make (Word8VectorSlice.length, Word8VectorSlice.sub)
+         val unpackStringVec = make (Word8VectorSlice.length, Word8VectorSlice.sub)
       end
    end

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char-global.sml (from rev 4358, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char.sml	2006-02-15 03:30:28 UTC (rev 4358)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char-global.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,10 @@
+(* 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 CharGlobal: CHAR_GLOBAL = Char
+open CharGlobal

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -8,7 +8,7 @@
 
 structure Char: CHAR_EXTRA =
    struct
-      open Char0
+      open PreChar
                        
       fun control reader state =
          case reader state of
@@ -159,10 +159,10 @@
 
       fun padLeft (s: string, n: int): string =
          let
-            val m = String.size s
+            val m = PreString.size s
             val diff = Int.-? (n, m)
          in if Int.> (diff, 0)
-               then String.concat [String.new (diff, #"0"), s]
+               then PreString.concat [PreString.new (diff, #"0"), s]
             else if diff = 0
                     then s
                  else raise Fail "padLeft"
@@ -176,7 +176,7 @@
                 (case c of
                     #"\\" => "\\\\"
                   | #"\"" => "\\\""
-                  | _ => String0.str c)
+                  | _ => PreString.str c)
           else
              case c of
                 #"\a" => "\\a"
@@ -188,9 +188,9 @@
               | #"\r" => "\\r"
               | _ =>
                    if c < #" "
-                      then (String.concat
-                            ["\\^", String0.str (chr (Int.+? (ord c, ord #"@")))])
-                   else String.concat 
+                      then (PreString.concat
+                            ["\\^", PreString.str (chr (Int.+? (ord c, ord #"@")))])
+                   else PreString.concat 
                         ["\\", padLeft (Int.fmt StringCvt.DEC (ord c), 3)])
       
       val toCString =
@@ -203,7 +203,7 @@
                   | #"\"" => "\\\""
                   | #"?" => "\\?"
                   | #"'" => "\\'"
-                  | _ => String0.str c)
+                  | _ => PreString.str c)
           else
              case c of
                 #"\a" => "\\a"
@@ -214,10 +214,6 @@
               | #"\f" => "\\f"
               | #"\r" => "\\r"
               | _ =>
-                   String.concat
+                   PreString.concat
                    ["\\", padLeft (Int.fmt StringCvt.OCT (ord c), 3)])
    end
-
-structure CharGlobal: CHAR_GLOBAL = Char
-open CharGlobal
-

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char0.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char0.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -11,8 +11,8 @@
       structure Prim = Primitive.Char8
       open Primitive.Char8
          
-      type char = char
-      type string = string
+      type char = Primitive.Char8.char
+      type string = Primitive.String8.string
 
       local
          structure S =
@@ -65,15 +65,13 @@
             NONE => raise Chr
           | SOME c => c
 
-      structure PreString = PreString
-
       fun oneOf s =
          let
             val a = Array.array (numChars, false)
-            val n = PreString.size s
+            val n = PreString8.size s
             fun loop i =
                if Int.>= (i, n) then ()
-               else (Array.update (a, ord (PreString.sub (s, i)), true)
+               else (Array.update (a, ord (PreString8.sub (s, i)), true)
                      ; loop (Int.+ (i, 1)))
          in loop 0
             ; fn c => Array.sub (a, ord c)

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string-global.sml (from rev 4358, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string.sml	2006-02-15 03:30:28 UTC (rev 4358)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string-global.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,25 @@
+(* 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 StringGlobal: STRING_GLOBAL = String
+open StringGlobal
+
+(* Now that concat is defined, we can add the exnMessager for Fail. *)
+val _ =
+   General.addExnMessager
+   (fn e =>
+    case e of
+       Fail s => SOME (concat ["Fail: ", s])
+     | _ => NONE)
+
+structure NullString =
+   struct
+      open Primitive.NullString8
+
+      val nullTerm = fromString o String.nullTerm
+   end

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -8,7 +8,7 @@
 
 structure String: STRING_EXTRA =
    struct
-      open String0
+      open PreString
 
       val toLower = translate (str o Char.toLower)
 
@@ -20,7 +20,12 @@
         val isSuffix = make isSuffix
       end
       val compare = collate Char.compare
-      val {<, <=, >, >=} = Util.makeOrder compare
+      local
+         structure S = StringComparisons (type t = string
+                                          val compare = compare)
+      in
+         open S
+      end
 
       val toString = translate Char.toString
       val toCString = translate Char.toCString
@@ -49,21 +54,3 @@
 
       fun nullTerm s = s ^ "\000"
    end
-
-structure StringGlobal: STRING_GLOBAL = String
-open StringGlobal
-
-(* Now that concat is defined, we can add the exnMessager for Fail. *)
-val _ =
-   General.addExnMessager
-   (fn e =>
-    case e of
-       Fail s => SOME (concat ["Fail: ", s])
-     | _ => NONE)
-
-structure NullString =
-   struct
-      open Primitive.NullString8
-
-      val nullTerm = fromString o String.nullTerm
-   end

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string0.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string0.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -30,4 +30,3 @@
       val explode = toList
    end
 structure PreString = PreString8
-structure PreSubstring8 = PreString.PreSubstring

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring-global.sml (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring.sml	2006-02-05 14:22:33 UTC (rev 4347)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring-global.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,10 @@
+(* 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 SubstringGlobal: SUBSTRING_GLOBAL = Substring
+open SubstringGlobal

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring.sml	2006-03-03 19:16:18 UTC (rev 4370)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -9,14 +9,12 @@
 (* The :> is to hide the type substring.  We must add the where's to make char
  * and string the same as the toplevel types.
  *)
-structure Substring
-   :> SUBSTRING_EXTRA
-   where type char = char
-   where type string = string
-   where type substring = CharVectorSlice.slice
-   =
+structure Substring :> SUBSTRING_EXTRA 
+                       where type char = char
+                       where type string = string
+                       where type substring = CharVectorSlice.slice =
    struct
-      open Substring0
+      open PreString.PreSubstring
 
       val size = length
       val extract = slice
@@ -35,6 +33,7 @@
         val position = make position
       end
       val compare = collate Char.compare
+
 (*
       type cs = int
          

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/cleaner.sig (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sig)

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/cleaner.sml (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/cleaner.sml)

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/natural.sml (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/util.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/util.sml	2006-02-05 14:22:33 UTC (rev 4347)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/natural.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,26 @@
+(* 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.
+ *)
+
+structure Natural =
+   struct
+      fun foldStartStop (start, stop, b, f) =
+         if start > stop
+            then raise Subscript
+         else 
+            let
+               fun loop (i, b) =
+                  if i >= stop then b
+                  else loop (i + 1, f (i, b))
+            in loop (start, b)
+            end
+
+      fun foreachStartStop (start, stop, f) =
+         foldStartStop (start, stop, (), fn (i, ()) => f i)
+
+      fun foreach (n, f) = foreachStartStop (0, n, f)
+   end

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/string-comparisons.sml (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/util.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/util.sml	2006-02-05 14:22:33 UTC (rev 4347)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/string-comparisons.sml	2006-03-03 22:10:55 UTC (rev 4371)
@@ -0,0 +1,28 @@
+(* 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.
+ *)
+
+functor StringComparisons (type t
+                           val compare: t * t -> order) =
+   struct
+      fun < (x, y) = 
+         (case compare (x, y) of
+             LESS => true
+           | _ => false)
+      fun <= (x, y) = 
+         (case compare (x, y) of
+             GREATER => false
+           | _ => true)
+      fun > (x, y) =
+         (case compare (x, y) of
+             GREATER => true
+           | _ => false)
+      fun >= (x, y) = 
+         (case compare (x, y) of
+             LESS => false
+           | _ => true)
+   end

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/unique-id.fun (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.fun)

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/unique-id.sig (from rev 4347, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/unique-id.sig)

[MLton-commit] r4370

[Stephen W. <sw...@ml...>]

Fixed a bug in the SSA simplifier.  Redundant tests didn't count the
start label of a function as an occurrence, and hence the in-degree of
the start block could be too low.  This caused an incorrect
elimination of an irredundant test, in examples like the following.

fun f () = loop ()
  loop ()
    b: bool = WordR_equal (w1, w2)
    case b of
      true => loop | false => L_1
  L_1 ()
    return

The problem is that loop was marked as having in-degree one instead of
two, and hence the fact that w1=w2 was propagated to loop in the true
branch, which then causes the test to be redundant.


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

U   mlton/trunk/mlton/ssa/redundant-tests.fun

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

Modified: mlton/trunk/mlton/ssa/redundant-tests.fun
===================================================================
--- mlton/trunk/mlton/ssa/redundant-tests.fun	2006-03-03 18:51:40 UTC (rev 4369)
+++ mlton/trunk/mlton/ssa/redundant-tests.fun	2006-03-03 19:16:18 UTC (rev 4370)
@@ -192,11 +192,12 @@
                                                          facts = ref [],
                                                          inDeg = ref 0}))
              (* Set up inDeg. *)
+             fun inc l = Int.inc (#inDeg (labelInfo l))
+             val () = inc start
              val _ =
                 Vector.foreach
                 (blocks, fn Block.T {transfer, ...} =>
-                 Transfer.foreachLabel
-                 (transfer, Int.inc o #inDeg o labelInfo))
+                 Transfer.foreachLabel (transfer, inc))
              (* Perform analysis, set up facts, and set up ancestor. *)
              fun loop (Tree.T (Block.T {label, statements, transfer, ...},
                                children),

[MLton-commit] r4369

[Matthew F. <fl...@ml...>]

Refactored int/word/int-inf implementations to be robust against
changes in defaults and primitive sizes.

Doing the same thing for Char/String would be the "RightThing(tm)",
but since the Basis Library specifies that Char is necessarily Char8,
doesn't seem worth it.


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

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-for-choose.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config2.sml
A   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/general.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/integer.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word0.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word1.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim1.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/text/char0.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string-cvt.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string0.sml

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

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-03-03 02:19:52 UTC (rev 4368)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb	2006-03-03 18:51:40 UTC (rev 4369)
@@ -92,10 +92,13 @@
    ../integer/int.sml
    ../integer/word.sig
    ../integer/word.sml
+   local ../config/bind-for-config1.sml in ann "forceUsed" in
+      ../config/objptr/$(OBJPTR_REP)
+      ../config/c/misc/$(CTYPES)
+   end end
    ../integer/int-inf.sig
-(*
    ../integer/int-inf.sml
-   local in ann "forceUsed" in
+   local ../config/bind-for-config2.sml in ann "forceUsed" in
       ../config/default/$(DEFAULT_INT)
       ../config/default/$(DEFAULT_WORD)
       ../config/default/large-int.sml
@@ -103,15 +106,19 @@
    end end
    ../integer/int-global.sml
    ../integer/word-global.sml
+   ../top-level/arithmetic.sml
+
+(*
    ../text/char.sig
    ../text/char.sml
    ../text/substring.sig
    ../text/substring.sml
    ../text/string.sig
    ../text/string.sml
-*)
+   local ../config/bind-for-config3.sml in ann "forceUsed" in
+      ../config/default/$(DEFAULT_CHAR)
+   end end
 
-(*
       ../../misc/C.sig
       ../../misc/C.sml
       ../../real/IEEE-real.sig
@@ -136,7 +143,6 @@
          ../../config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
       end
 
-      ../../top-level/arithmetic.sml
 
       (* misc/unique-id.sig *)
       (* misc/unique-id.fun *)

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-choose.sml (from rev 4348, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config0.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config0.sml	2006-02-05 15:30:17 UTC (rev 4348)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-choose.sml	2006-03-03 18:51:40 UTC (rev 4369)
@@ -0,0 +1,28 @@
+(* 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 Char8 = Primitive.Char8
+structure Char16 = Primitive.Char16
+structure Char32 = Primitive.Char32
+
+structure Int8 = Primitive.Int8
+structure Int16 = Primitive.Int16
+structure Int32 = Primitive.Int32
+structure Int64 = Primitive.Int64
+structure IntInf = Primitive.IntInf
+
+structure Real32 = Primitive.Real32
+structure Real64 = Primitive.Real64
+
+structure String8 = Primitive.String8
+structure String16 = Primitive.String16
+structure String32 = Primitive.String32
+
+structure Word8 = Primitive.Word8
+structure Word16 = Primitive.Word16
+structure Word32 = Primitive.Word32
+structure Word64 = Primitive.Word64

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml	2006-03-03 02:19:52 UTC (rev 4368)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml	2006-03-03 18:51:40 UTC (rev 4369)
@@ -13,7 +13,7 @@
 structure Int16 = Int16
 structure Int32 = Int32
 structure Int64 = Int64
-structure IntInf = IntInf
+structure IntInf = Primitive.IntInf
 
 structure Pointer = Primitive.Pointer
 

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config2.sml (from rev 4348, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml)

Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml (from rev 4348, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config1.sml	2006-02-05 15:30:17 UTC (rev 4348)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind-for-config3.sml	2006-03-03 18:51:40 UTC (rev 4369)
@@ -0,0 +1,30 @@
+(* 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 Char8 = Char8
+structure Char16 = Primitive.Char16
+structure Char32 = Primitive.Char32
+
+structure Int8 = Int8
+structure Int16 = Int16
+structure Int32 = Int32
+structure Int64 = Int64
+structure IntInf = IntInf
+
+structure Pointer = Primitive.Pointer
+
+structure Real32 = Primitive.Real32
+structure Real64 = Primitive.Real64
+
+structure String8 = String8
+structure String16 = Primitive.String16
+structure String32 = Primitive.String32
+
+structure Word8 = Word8
+structure Word16 = Word16
+structure Word32 = Word32
+structure Word64 = Word64

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/general.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/general.sml	2006-03-03 02:19:52 UTC (rev 4368)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/general/general.sml	2006-03-03 18:51:40 UTC (rev 4369)
@@ -14,13 +14,13 @@
       exception Bind = Bind
       exception Match = Match
       exception Chr
-      exception Div
-      exception Domain
+      exception Div = Div
+      exception Domain = Domain
       exception Fail of string
       exception Overflow = Overflow
       exception Size = Size
       exception Span
-      exception Subscript
+      exception Subscript = Subscript
 
       datatype order = datatype Primitive.Order.order
 

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sml	2006-03-03 02:19:52 UTC (rev 4368)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf.sml	2006-03-03 18:51:40 UTC (rev 4369)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -6,627 +6,113 @@
  * See the file MLton-LICENSE for details.
  *)
 
-(*
- * IntInf.int's either have a bottom bit of 1, in which case the top 31
- * 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) of
- * the absolute value of the number, from least to most significant.
- *)
 structure IntInf: INT_INF_EXTRA =
    struct
-      structure Word = Word32
-         
-      datatype rep =
-         Big of Word.word Vector.vector
-       | Small of Int.int
-         
-      structure Prim = Primitive.IntInf
-      type bigInt = Prim.int
-      local
-         open Int
-      in
-         val op < = op <
-         val op <= = op <=
-         val op > = op >
-         val op >= = op >=
-         val op + = op +
-         val op - = op -
-      end
-      type smallInt = int
-         
-      (* bigIntConstant is just to make it easy to spot where the bigInt
-       * constants are in this module.
-       *)
-      fun bigIntConstant x = x
-      val zero = bigIntConstant 0
-      val one = bigIntConstant 1
-      val negOne = bigIntConstant ~1
-         
-      (* Check if an IntInf.int is small (i.e., a fixnum). *)
-      fun isSmall (i: bigInt): bool =
-         0w0 <> Word.andb (Prim.toWord i, 0w1)
+      open Primitive.IntInf
 
-      (* Check if two IntInf.int's are both small (i.e., fixnums).
-       * This is a gross hack, but uses only one test.
-       *)
-      fun areSmall (i: bigInt, i': bigInt) =
-         0w0 <> Word.andb (Prim.toWord i, Word.andb (Prim.toWord i', 0w1))
-         
-      (*
-       * Return the number of `limbs' in a bigInt.
-       * If arg is big, then |arg| is in [ 2^ (32 (x-1)), 2^ (32 x) )
-       * where x is size arg.  If arg is small, then it is in
-       * [ - 2^30, 2^30 ).
-       *)
-      fun bigSize (arg: bigInt): smallInt =
-         Vector.length (Prim.toVector arg) -? 1
-      fun size (arg: bigInt): smallInt =
-         if isSmall arg
-            then 1
-         else bigSize arg
+      structure BigWord = C_MPLimb
+      structure SmallInt = ObjptrInt
 
-      val bytesPerWord = 0w4
-      (*
-       * Reserve heap space for a bignum bigInt with room for size + extra
-       * `limbs'.  The reason for splitting this up is that extra is intended
-       * to be a constant, and so can be combined at compile time with the 0w4
-       * below.
-       *)
-      fun reserve (size: smallInt, extra: smallInt): word = 
-         Word.* (bytesPerWord,
-                 Word.+ (Word.fromInt size,
-                         Word.+ (0w4, (* counter, size, header, sign words *)
-                                 Word.fromInt extra)))
+      structure W = ObjptrWord
+      structure I = ObjptrInt
+      structure MPLimb = C_MPLimb
 
-      (*
-       * Given a fixnum bigInt, return the Word.word which it
-       * represents.
-       * NOTE: it is an ERROR to call stripTag on an argument
-       * which is a bignum bigInt.
-       *)
-      fun stripTag (arg: bigInt): Word.word =
-         Word.~>> (Prim.toWord arg, 0w1)
+      val precision: Int.int option = NONE
 
-      (*
-       * Given a Word.word, add the tag bit in so that it looks like
-       * a fixnum bigInt.
-       *)
-      fun addTag (argw: Word.word): Word.word =
-         Word.orb (Word.<< (argw, 0w1), 0w1)
+      fun sign (arg: int): Int.int =
+         if Prim.isSmall arg
+            then I.sign (Prim.dropTagCoerceInt arg)
+            else if isNeg arg
+                    then ~1
+                    else 1
 
-      (*
-       * badw is the fixnum bigInt (as a word) whose negation and
-       * absolute value are not fixnums.  badv is the same thing
-       * with the tag stripped off.
-       * negBad is the negation (and absolute value) of that bigInt.
-       *)
-      val badw: Word.word = 0wx80000001 (* = Prim.toWord ~0x40000000 *)
-      val badv: Word.word = 0wxC0000000 (* = stripTag ~0x40000000 *)
-      val negBad: bigInt = bigIntConstant 0x40000000
+      fun sameSign (x, y) = sign x = sign y
 
-      (*
-       * Given two Word.word's, check if they have the same `sign' bit.
-       *)
-      fun sameSign (lhs: Word.word, rhs: Word.word): bool =
-         Word.toIntX (Word.xorb (lhs, rhs)) >= 0
-
-      (*
-       * Given a bignum bigint, test if it is (strictly) negative.
-       * Note: it is an ERROR to call bigIsNeg on an argument
-       * which is a fixnum bigInt.
-       *)
-      fun bigIsNeg (arg: bigInt): bool =
-         Primitive.Vector.sub (Prim.toVector arg, 0) <> 0w0
-
-      (*
-       * Convert a smallInt to a bigInt.
-       *)
-      fun bigFromInt (arg: smallInt): bigInt =
-         let
-            val argv = Word.fromInt arg
-            val ans = addTag argv
-         in
-            if sameSign (argv, ans)
-               then Prim.fromWord ans
-            else let val space = Primitive.Array.array 2
-                     val (isneg, abs) = if arg < 0
-                                           then (0w1, Word.- (0w0, argv))
-                                        else (0w0, argv)
-                     val _ = Primitive.Array.update (space, 0, isneg)
-                     val _ = Primitive.Array.update (space, 1, abs)
-                     val space = Primitive.Vector.fromArray space
-                 in 
-                    Prim.fromVector space
-                 end
-         end
-
-      fun rep x =
-         if isSmall x
-            then Small (Word.toIntX (stripTag x))
-         else Big (Prim.toVector x)
-            
-      (*
-       * Convert a bigInt to a smallInt, raising overflow if it
-       * is too big.
-       *)
-      fun bigToInt (arg: bigInt): smallInt =
-         if isSmall arg
-            then Word.toIntX (stripTag arg)
-         else if bigSize arg <> 1
-                 then raise Overflow
-              else let val arga = Prim.toVector arg
-                       val argw = Primitive.Vector.sub (arga, 1)
-                   in if Primitive.Vector.sub (arga, 0) <> 0w0
-                         then if Word.<= (argw, 0wx80000000)
-                                 then Word.toIntX (Word.- (0w0, argw))
-                              else raise Overflow
-                      else if Word.< (argw, 0wx80000000)
-                              then Word.toIntX argw
-                           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
+      local
+         val maxShift32 = 0w128
+         val maxShift = Word32.toWord maxShift32
+         fun make f (arg, shift) =
             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
+               fun loop (arg, shift) =
+                  if Word.<= (shift, maxShift)
+                     then f (arg, Word32.fromWord shift)
+                     else loop (f (arg, maxShift32),
+                                Word.- (shift, maxShift))
             in
-               if Int64.>= (i, 0)
-                  then doit (i, 0w0)
-               else
-                  if i = valOf Int64.minInt
-                     then ~0x8000000000000000
-                  else doit (Int64.~? i, 0w1)
+               loop (arg, shift)
             end
-                
-      fun bigToInt64 (arg: bigInt): Int64.int =
-         case rep arg of
-            Small i => Int64.fromInt i
-          | 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.
-       *)
-      fun bigNegate (arg: bigInt): bigInt =
-         if isSmall arg
-            then let val argw = Prim.toWord arg
-                 in if argw = badw
-                       then negBad
-                    else Prim.fromWord (Word.- (0w2, argw))
-                 end
-         else Prim.~ (arg, reserve (bigSize arg, 1))
-
-      val dontInline: (unit -> 'a) -> 'a =
-         fn f =>
-         let
-            val rec recur: int -> 'a =
-               fn i =>
-               if i = 0
-                  then f ()
-               else (ignore (recur (i - 1))
-                     ; recur (i - 2))
-         in
-            recur 0
-         end
-            
-
-      fun bigMul (lhs: bigInt, rhs: bigInt): bigInt =
-         let
-            val res =
-               if areSmall (lhs, rhs)
-                  then let val ansv = (Word.fromInt o Int.*) 
-                                      (Word.toIntX (stripTag lhs),
-                                       Word.toIntX (stripTag rhs))
-                           val ans = addTag ansv
-                       in
-                          if sameSign (ans, ansv)
-                             then SOME (Prim.fromWord ans)
-                             else NONE
-                       end handle Overflow => NONE
-                  else NONE
-         in
-            case res of
-               NONE =>
-                  dontInline
-                  (fn () =>
-                   Prim.* (lhs, rhs, reserve (size lhs +? size rhs, 0)))
-             | SOME i => i
-         end
-
-      (*
-       * bigInt quot.
-       * Round towards 0 (bigRem returns the remainder).
-       * Note, if size num < size den, then the answer is 0.
-       * The only non-trivial case here is num being - den,
-       * and small, but in that case, although den may be big, its
-       * size is still 1.  (den cannot be 0 in this case.)
-       * The space required for the shifted numerator limbs is <= nsize + 1.
-       * The space required for the shifted denominator limbs is <= dsize
-       * The space required for the quotient limbs is <= 1 + nsize - dsize.
-       * Thus the total space for limbs is <= 2*nsize + 2 (and one extra
-       * word for the isNeg flag).
-       *)
-      fun bigQuot (num: bigInt, den: bigInt): bigInt =
-         if areSmall (num, den)
-            then let val numv = stripTag num
-                     val denv = stripTag den
-                 in if numv = badv andalso denv = Word.fromInt ~1
-                       then negBad
-                    else let val numi = Word.toIntX numv
-                             val deni = Word.toIntX denv
-                             val ansi = Int.quot (numi, deni)
-                             val answ = Word.fromInt ansi
-                         in Prim.fromWord (addTag answ)
-                         end
-                 end
-         else let val nsize = size num
-                  val dsize = size den
-              in if nsize < dsize
-                    then zero
-                 else if den = zero
-                         then raise Div
-                      else
-                         Prim.quot
-                         (num, den,
-                          Word.* (Word.* (0w2, bytesPerWord),
-                                  Word.+ (Word.fromInt nsize, 0w3)))
-              end
-
-      (*
-       * bigInt rem.
-       * Sign taken from numerator, quotient is returned by bigQuot.
-       * Note, if size num < size den, then the answer is 0.
-       * The only non-trivial case here is num being - den,
-       * and small, but in that case, although den may be big, its
-       * size is still 1.  (den cannot be 0 in this case.)
-       * The space required for the shifted numerator limbs is <= nsize + 1.
-       * The space required for the shifted denominator limbs is <= dsize
-       * The space required for the quotient limbs is <= 1 + nsize - dsize.
-       * Thus the total space for limbs is <= 2*nsize + 2 (and one extra
-       * word for the isNeg flag).
-       *)
-      fun bigRem (num: bigInt, den: bigInt): bigInt =
-         if areSmall (num, den)
-            then let val numv = stripTag num
-                     val numi = Word.toIntX numv
-                     val denv = stripTag den
-                     val deni = Word.toIntX denv
-                     val ansi = Int.rem (numi, deni)
-                     val answ = Word.fromInt ansi
-                 in Prim.fromWord (addTag answ)
-                 end
-         else let val nsize = size num
-                  val dsize = size den
-              in if nsize < dsize
-                    then num
-                 else if den = zero
-                         then raise Div
-                      else
-                         Prim.rem
-                         (num, den, Word.* (Word.* (0w2, bytesPerWord),
-                                            Word.+ (Word.fromInt nsize, 0w3)))
-              end
-
-      (*
-       * bigInt addition.
-       *)
-      fun bigPlus (lhs: bigInt, rhs: bigInt): bigInt =
-         let
-            val res =
-               if areSmall (lhs, rhs)
-                  then let val ansv = Word.+ (stripTag lhs, stripTag rhs)
-                           val ans = addTag ansv
-                       in if sameSign (ans, ansv)
-                             then SOME (Prim.fromWord ans)
-                          else NONE
-                       end
-               else NONE
-         in
-            case res of
-               NONE => 
-                  dontInline
-                  (fn () =>
-                   Prim.+ (lhs, rhs, reserve (Int.max (size lhs, size rhs), 1)))
-             | SOME i => i
-         end
-
-      (*
-       * bigInt subtraction.
-       *)
-      fun bigMinus (lhs: bigInt, rhs: bigInt): bigInt =
-         let
-            val res =
-               if areSmall (lhs, rhs)
-                  then
-                     let
-                        val ansv = Word.- (stripTag lhs, stripTag rhs)
-                        val ans = addTag ansv
-                     in
-                        if sameSign (ans, ansv)
-                           then SOME (Prim.fromWord ans)
-                        else NONE
-                     end
-               else NONE
-         in
-            case res of
-               NONE =>
-                  dontInline
-                  (fn () =>
-                   Prim.- (lhs, rhs, reserve (Int.max (size lhs, size rhs), 1)))
-             | SOME i => i
-         end
-
-      (*
-       * bigInt compare.
-       *)
-      fun bigCompare (lhs: bigInt, rhs: bigInt): order =
-         if areSmall (lhs, rhs)
-            then Int.compare (Word.toIntX (Prim.toWord lhs),
-                              Word.toIntX (Prim.toWord rhs))
-         else Int.compare (Prim.compare (lhs, rhs), 0)
-
-
-      (*
-       * bigInt comparisions.
-       *)
-      local
-         fun makeTest (smallTest: smallInt * smallInt -> bool)
-            (lhs: bigInt, rhs: bigInt): bool =
-            if areSmall (lhs, rhs)
-               then smallTest (Word.toIntX (Prim.toWord lhs),
-                               Word.toIntX (Prim.toWord rhs))
-            else smallTest (Prim.compare (lhs, rhs), 0)
       in
-         val bigGT = makeTest (op >)
-         val bigGE = makeTest (op >=)
-         val bigLE = makeTest (op <=)
-         val bigLT = makeTest (op <)
+         val << = make <<
+         val ~>> = make ~>>
       end
 
-      (*
-       * bigInt abs.
-       *)
-      fun bigAbs (arg: bigInt): bigInt =
-         if isSmall arg
-            then let val argw = Prim.toWord arg
-                 in if argw = badw
-                       then negBad
-                    else if Word.toIntX argw < 0
-                            then Prim.fromWord (Word.- (0w2, argw))
-                         else arg
-                 end
-         else if bigIsNeg arg
-                 then Prim.~ (arg, reserve (bigSize arg, 1))
-              else arg
-
-      (*
-       * bigInt min.
-       *)
-      fun bigMin (lhs: bigInt, rhs: bigInt): bigInt =
-         if bigLE (lhs, rhs)
-            then lhs
-         else rhs
-
-      (*
-       * bigInt max.
-       *)
-      fun bigMax (lhs: bigInt, rhs: bigInt): bigInt =
-         if bigLE (lhs, rhs)
-            then rhs
-         else lhs
-
-      (*
-       * bigInt sign.
-       *)
-      fun bigSign (arg: bigInt): smallInt =
-         if isSmall arg
-            then Int.sign (Word.toIntX (stripTag arg))
-         else if bigIsNeg arg
-                 then ~1
-              else 1
-
-      (*
-       * bigInt sameSign.
-       *)
-      fun bigSameSign (lhs: bigInt, rhs: bigInt): bool =
-         bigSign lhs = bigSign rhs
-
-      (*
-       * bigInt gcd.
-       * based on code from PolySpace.
-       *)
       local
-         open Int
-
-         fun mod2 x = Word.toIntX (Word.andb (Word.fromInt x, 0w1))
-         fun div2 x = Word.toIntX (Word.>> (Word.fromInt x, 0w1))
-            
-         fun gcdInt (a, b, acc) =
-            case (a, b) of
-               (0, _) => b * acc
-             | (_, 0) => a * acc
-             | (_, 1) => acc
-             | (1, _) => acc
-             | _ => 
-                  if a = b
-                     then a * acc
-                  else
-                     let
-                        val a_2 = div2 a
-                        val a_r2 = mod2 a
-                        val b_2 = div2 b
-                        val b_r2 = mod2 b
-                     in
-                        if 0 = a_r2
-                           then
-                              if 0 = b_r2
-                                 then gcdInt (a_2, b_2, acc + acc)
-                              else gcdInt (a_2, b, acc)
-                        else
-                           if 0 = b_r2
-                              then gcdInt (a, b_2, acc)
-                           else
-                              if a >= b
-                                 then gcdInt (div2 (a - b), b, acc)
-                              else gcdInt (a, div2 (b - a), acc)
-                     end
-                  
-      in
-         fun bigGcd (lhs: bigInt, rhs: bigInt): bigInt =
-            if areSmall (lhs, rhs)
-               then
-                  Prim.fromWord
-                  (addTag
-                   (Word.fromInt
-                    (gcdInt (Int.abs (Word.toIntX (stripTag lhs)),
-                             Int.abs (Word.toIntX (stripTag rhs)),
-                             1))))
-            else Prim.gcd (lhs, rhs, reserve (max (size lhs, size rhs), 0))
-      end
-
-      (*
-       * bigInt toString and fmt.
-       * dpc is the maximum number of digits per `limb'.
-       *)
-      local
          open StringCvt
 
-         fun cvt {base: smallInt,
-                  dpc: word,
-                  smallCvt: smallInt -> string}
-            (arg: bigInt)
-            : string =
-            if isSmall arg
-               then smallCvt (Word.toIntX (stripTag arg))
-            else Prim.toString (arg, base,
-                                Word.+
-                                (reserve (0, 0),
-                                 Word.+ (0w2, (* sign character *)
-                                         Word.* (dpc,
-                                                 Word.fromInt (bigSize arg)))))
-         val binCvt = cvt {base = 2, dpc = 0w32, smallCvt = Int.fmt BIN}
-         val octCvt = cvt {base = 8, dpc = 0w11, smallCvt = Int.fmt OCT}
-         val hexCvt = cvt {base = 16, dpc = 0w8, smallCvt = Int.fmt HEX}
+         val binCvt = mkCvt {base = 2, smallCvt = I.fmt BIN}
+         val octCvt = mkCvt {base = 8, smallCvt = I.fmt OCT}
+         val decCvt = mkCvt {base = 10, smallCvt = I.fmt DEC}
+         val hexCvt = mkCvt {base = 16, smallCvt = I.fmt HEX}
       in
-         val bigToString = cvt {base = 10,
-                                dpc = 0w10,
-                                smallCvt = Int.toString}
-         fun bigFmt radix =
+         fun fmt radix =
             case radix of
                BIN => binCvt
              | OCT => octCvt
-             | DEC => bigToString
+             | DEC => decCvt
              | HEX => hexCvt
+         val toString = fmt DEC
       end
 
-      (*
-       * bigInt scan and fromString.
-       *)
       local
          open StringCvt
 
          (*
-          * We use Word.word to store chunks of digits.
-          * smallToInf converts such a word to a fixnum bigInt.
-          * Thus, it can only represent values in [- 2^30, 2^30).
-          *)
-         fun smallToBig (arg: Word.word): bigInt =
-            Prim.fromWord (addTag arg)
-            
-            
-         (*
           * Given a char, if it is a digit in the appropriate base,
           * convert it to a word.  Otherwise, return NONE.
           * Note, both a-f and A-F are accepted as hexadecimal digits.
           *)
-         fun binDig (ch: char): Word.word option =
+         fun binDig (ch: char): W.word option =
             case ch of
                #"0" => SOME 0w0
              | #"1" => SOME 0w1
              | _ => NONE
 
          local
-            val op <= = Char.<=
+            val op <= = PreChar.<=
          in
-            fun octDig (ch: char): Word.word option =
+            fun octDig (ch: char): W.word option =
                if #"0" <= ch andalso ch <= #"7"
-                  then SOME (Word.fromInt (ord ch -? ord #"0"))
+                  then SOME (W.fromInt (Int.- (PreChar.ord ch, 
+                                               PreChar.ord #"0")))
                else NONE
                   
-            fun decDig (ch: char): Word.word option =
+            fun decDig (ch: char): W.word option =
                if #"0" <= ch andalso ch <= #"9"
-                  then SOME (Word.fromInt (ord ch -? ord #"0"))
+                  then SOME (W.fromInt (Int.- (PreChar.ord ch, 
+                                               PreChar.ord #"0")))
                else NONE
                   
-            fun hexDig (ch: char): Word.word option =
+            fun hexDig (ch: char): W.word option =
                if #"0" <= ch andalso ch <= #"9"
-                  then SOME (Word.fromInt (ord ch -? ord #"0"))
+                  then SOME (W.fromInt (Int.- (PreChar.ord ch, 
+                                               PreChar.ord #"0")))
                else if #"a" <= ch andalso ch <= #"f"
-                       then SOME (Word.fromInt (ord ch -? (ord #"a" - 0xa)))
-                    else if #"A" <= ch andalso ch <= #"F"
-                            then SOME (Word.fromInt
-                                       (ord ch -? (ord #"A" - 0xA)))
-                         else
-                            NONE
+                  then SOME (W.fromInt (Int.- (PreChar.ord ch, 
+                                               Int.- (PreChar.ord #"a", 0xa))))
+               else if #"A" <= ch andalso ch <= #"F"
+                  then SOME (W.fromInt (Int.- (PreChar.ord ch, 
+                                               Int.- (PreChar.ord #"A", 0xA))))
+               else NONE
          end
       
          (*
           * Given a digit converter and a char reader, return a digit
           * reader.
           *)
-         fun toDigR (charToDig: char -> Word.word option,
+         fun toDigR (charToDig: char -> W.word option,
                      cread: (char, 'a) reader)
-            (s: 'a)
-            : (Word.word * 'a) option =
+                    (s: 'a)
+                    : (W.word * 'a) option =
             case cread s of
                NONE => NONE
              | SOME (ch, s') =>
@@ -640,87 +126,83 @@
           * shift is base raised to the number-of-digits-seen power.
           * chunk is the value of the digits seen.
           *)
-         type chunk = {
-                       more: bool,
-                       shift: Word.word,
-                       chunk: Word.word
-                       }
-            
+         type chunk = {more: bool,
+                       shift: W.word,
+                       chunk: W.word}
          (*
-          * Given the base, the number of digits per chunk,
-          * a char reader and a digit reader, return a chunk reader.
+          * Given the base and a digit reader, 
+          * return a chunk reader.
           *)
-         fun toChunkR (base: Word.word,
-                       dpc: smallInt,
-                       dread: (Word.word, 'a) reader)
-            : (chunk, 'a) reader =
-            let fun loop {left: smallInt,
-                          shift: Word.word,
-                          chunk: Word.word,
-                          s: 'a}
-               : chunk * 'a =
-               if left <= 0
-                  then ({more = true,
-                         shift = shift,
-                         chunk = chunk },
-                        s)
-               else
+         fun toChunkR (base: W.word,
+                       dread: (W.word, 'a) reader)
+                      : (chunk, 'a) reader =
+            let 
+               fun loop {left: Int32.int,
+                         shift: W.word,
+                         chunk: W.word,
+                         s: 'a}
+                        : chunk * 'a =
+                  if Int32.<= (left, 0)
+                     then ({more = true,
+                            shift = shift,
+                            chunk = chunk},
+                           s)
+                     else
+                        case dread s of
+                           NONE => ({more = false,
+                                     shift = shift,
+                                     chunk = chunk},
+                                    s)
+                         | SOME (dig, s') =>
+                              loop {left = Int32.- (left, 1),
+                                    shift = W.* (base, shift),
+                                    chunk = W.+ (W.* (base, chunk), dig),
+                                    s = s'}
+               val digitsPerChunk = 
+                  Int32.div (Int32.- (Int32.fromInt W.wordSize, 2), W.log2 base)
+               fun reader (s: 'a): (chunk * 'a) option =
                   case dread s of
-                     NONE => ({more = false,
-                               shift = shift,
-                               chunk = chunk},
-                              s)
-                   | SOME (dig, s') =>
-                        loop {
-                              left = left - 1,
-                              shift = Word.* (base, shift),
-                              chunk = Word.+ (Word.* (base,
-                                                      chunk),
-                                              dig),
-                              s = s'
-                              }
-                fun reader (s: 'a): (chunk * 'a) option =
-                   case dread s of
-                      NONE => NONE
-                    | SOME (dig, next) =>
-                         SOME (loop {left = dpc - 1,
-                                     shift = base,
-                                     chunk = dig,
-                                     s = next})
-            in reader
+                     NONE => NONE
+                   | SOME (dig, next) =>
+                        SOME (loop {left = Int32.- (digitsPerChunk, 1),
+                                    shift = base,
+                                    chunk = dig,
+                                    s = next})
+            in 
+               reader
             end
          
          (*
           * Given a chunk reader, return an unsigned reader.
           *)
-         fun toUnsR (ckread: (chunk, 'a) reader): (bigInt, 'a) reader =
-            let fun loop (more: bool, ac: bigInt, s: 'a) =
-               if more
-                  then case ckread s of
-                     NONE => (ac, s)
-                   | SOME ({more, shift, chunk}, s') =>
-                        loop (more,
-                              bigPlus (bigMul (smallToBig shift,
-                                               ac),
-                                       smallToBig chunk),
-                              s')
-               else (ac, s)
-                fun reader (s: 'a): (bigInt * 'a) option =
-                   case ckread s of
-                      NONE => NONE
-                    | SOME ({more, chunk, ...}, s') =>
-                         SOME (loop (more,
-                                     smallToBig chunk,
-                                     s'))
-            in reader
+         fun toUnsR (ckread: (chunk, 'a) reader): (int, 'a) reader =
+            let 
+               fun loop (more: bool, acc: int, s: 'a) =
+                  if more
+                     then case ckread s of
+                        NONE => (acc, s)
+                      | SOME ({more, shift, chunk}, s') =>
+                           loop (more,
+                                 ((Prim.addTagCoerce shift) * acc)
+                                 + (Prim.addTagCoerce chunk),
+                                 s')
+                     else (acc, s)
+               fun reader (s: 'a): (int * 'a) option =
+                  case ckread s of
+                     NONE => NONE
+                   | SOME ({more, chunk, ...}, s') =>
+                        SOME (loop (more,
+                                    Prim.addTagCoerce chunk,
+                                    s'))
+            in 
+               reader
             end
          
          (*
           * Given a char reader and an unsigned reader, return an unsigned
           * reader that includes skipping the option hex '0x'.
           *)
-         fun toHexR (cread: (char, 'a) reader, uread: (bigInt, 'a) reader) 
-            s =
+         fun toHexR (cread: (char, 'a) reader, uread: (int, 'a) reader) s =
             case cread s of
                NONE => NONE
              | SOME (c1, s1) =>
@@ -732,77 +214,66 @@
                               case uread s2 of 
                                  NONE => SOME (zero, s1)
                                | SOME x => SOME x
-                           else uread s
-                  else uread s
+                              else uread s
+                     else uread s
 
          (*
           * Given a char reader and an unsigned reader, return a signed
           * reader.  This includes skipping any initial white space.
           *)
-         fun toSign (cread: (char, 'a) reader, uread: (bigInt, 'a) reader)
-            : (bigInt, 'a) reader =
+         fun toSign (cread: (char, 'a) reader, uread: (int, 'a) reader)
+                    : (int, 'a) reader =
             let
-               fun reader (s: 'a): (bigInt * 'a) option =
+               fun reader (s: 'a): (int * 'a) option =
                   case cread s of
                      NONE => NONE
                    | SOME (ch, s') =>
-                        if Char.isSpace ch then reader s'
-                        else
-                           let
-                              val (isNeg, s'') =
-                                 case ch of
-                                    #"+" => (false, s')
-                                  | #"-" => (true, s')
-                                  | #"~" => (true, s')
-                                  | _ => (false, s)
-                           in
-                              if isNeg then
-                                 case uread s'' of
-                                    NONE => NONE
-                                  | SOME (abs, s''') =>
-                                       SOME (bigNegate abs, s''')
-                              else uread s''
-                           end
+                        if PreChar.isSpace ch then reader s'
+                        else let
+                                val (isNeg, s'') =
+                                   case ch of
+                                      #"+" => (false, s')
+                                    | #"-" => (true, s')
+                                    | #"~" => (true, s')
+                                    | _ => (false, s)
+                             in
+                                if isNeg then
+                                   case uread s'' of
+                                      NONE => NONE
+                                    | SOME (abs, s''') =>
+                                         SOME (~ abs, s''')
+                                   else uread s''
+                             end
             in
                reader
             end
                   
          (*
           * Base-specific conversions from char readers to
-          * bigInt readers.
+          * int readers.
           *)
          local
-            fun reader (base, dpc, dig)
-               (cread: (char, 'a) reader): (bigInt, 'a) reader =
-               let val dread = toDigR (dig, cread)
-                  val ckread = toChunkR (base, dpc, dread)
+            fun reader (base, dig)
+                       (cread: (char, 'a) reader)
+                       : (int, 'a) reader =
+               let 
+                  val dread = toDigR (dig, cread)
+                  val ckread = toChunkR (base, dread)
                   val uread = toUnsR ckread
                   val hread =
                      if base = 0w16 then toHexR (cread, uread) else uread
                   val reader = toSign (cread, hread)
-               in reader
+               in 
+                  reader
                end
          in
-            fun binReader z = reader (0w2, 29, binDig) z
-            fun octReader z = reader (0w8, 9, octDig) z
-            fun decReader z = reader (0w10, 9, decDig) z
-            fun hexReader z = reader (0w16, 7, hexDig) z
+            fun binReader z = reader (0w2, binDig) z
+            fun octReader z = reader (0w8, octDig) z
+            fun decReader z = reader (0w10, decDig) z
+            fun hexReader z = reader (0w16, hexDig) z
          end     
       in
-         
-         local fun stringReader (pos, str) =
-            if pos >= String.size str
-               then NONE
-            else SOME (String.sub (str, pos), (pos + 1, str))
-               val reader = decReader stringReader
-         in
-            fun bigFromString str =
-               case reader (0, str) of
-                  NONE => NONE
-                | SOME (res, _) => SOME res
-         end
-      
-         fun bigScan radix =
+         fun scan radix =
             case radix of
                BIN => binReader
              | OCT => octReader
@@ -810,11 +281,13 @@
              | HEX => hexReader
       end
 
+      val fromString = StringCvt.scanString (scan StringCvt.DEC)
+
       local
-         fun isEven (n: int) = Int.mod (Int.abs n, 2) = 0
+         fun isEven (n: Int.int) = Int.andb (n, 0x1) = 0
       in
-         fun pow (i: bigInt, j: int): bigInt =
-            if j < 0 then
+         fun pow (i: int, j: Int.int): int =
+            if Int.< (j, 0) then
                if i = zero then
                   raise Div
                else
@@ -825,188 +298,26 @@
                if j = 0 then one
                else
                   let
-                     fun square (n: bigInt): bigInt = bigMul (n, n)
+                     fun square (n: int): int = n * n
                      (* pow (j) returns (i ^ j) *)
-                     fun pow (j: int): bigInt =
-                        if j <= 0 then one
+                     fun pow (j: Int.int): int =
+                        if Int.<= (j, 0) then one
                         else if isEven j then evenPow j
-                        else bigMul (i, evenPow (j - 1))
+                        else i * evenPow (Int.- (j, 1))
                      (* evenPow (j) returns (i ^ j), assuming j is even *)
-                     and evenPow (j: int): bigInt =
-                        square (pow (Int.quot (j, 2)))
-                  in pow (j)
+                     and evenPow (j: Int.int): int =
+                        square (pow (Int.~>> (j, 0w1)))
+                  in 
+                     pow j
                   end
       end
 
-      val op + = bigPlus
-      val op - = bigMinus
-      val op > = bigGT
-      val op >= = bigGE
-      val op < = bigLT
-      val quot = bigQuot
-      val rem = bigRem
+      val log2 = 
+         mkLog2 {fromSmall = fn {smallLog2} => Int32.toInt smallLog2,
+                 fromLarge = fn {numLimbsMinusOne, mostSigLimbLog2} =>
+                 Int.+ (Int.* (MPLimb.wordSize, SeqIndex.toInt numLimbsMinusOne),
+                        Int32.toInt mostSigLimbLog2)}
 
-      fun x div y =
-         if x >= zero
-            then if y > zero
-                    then quot (x, y)
-                 else if y < zero
-                         then if x = zero
-                                 then zero
-                              else quot (x - one, y) - one
-                      else raise Div
-         else if y < zero
-                 then quot (x, y)
-              else if y > zero
-                      then quot (x + one, y) - one
-                   else raise Div
-
-      fun x mod y =
-         if x >= zero
-            then if y > zero
-                    then rem (x, y)
-                 else if y < zero
-                         then if x = zero
-                                 then zero
-                              else rem (x - one, y) + (one + y)
-                      else raise Div
-         else if y < zero
-                 then rem (x, y)
-              else if y > zero
-                      then rem (x + one, y) + (y - one)
-                   else raise Div
-
-      fun divMod (x, y) = (x div y, x mod y)
-      fun quotRem (x, y) = (quot (x, y), rem (x, y))
-
-      (*
-       * bigInt log2
-       *)
-      structure Word =
-         struct
-            open Word
-            fun log2 (w: word): int =
-               let
-                  fun loop (n, s, ac): word =
-                     if n = 0w1
-                        then ac
-                     else
-                        let
-                           val (n, ac) =
-                              if n >= << (0w1, s)
-                                 then (>> (n, s), ac + s)
-                              else (n, ac)
-                        in
-                           loop (n, >> (s, 0w1), ac)
-                        end
-               in
-                  toInt (loop (w, 0w16, 0w0))
-               end
-         end
-
-      local
-         val bitsPerLimb: Int.int = 32
-      in
-         fun log2 (n: bigInt): Int.int =
-            if bigLE (n, 0)
-               then raise Domain
-            else
-               case rep n of
-                  Big v =>
-                     Int.+ (Int.* (bitsPerLimb, Int.- (Vector.length v, 2)),
-                            Word.log2 (Vector.sub (v, Int.- (Vector.length v, 1))))
-                | Small i => Word.log2 (Word.fromInt i)
-      end
-
-      (* 
-       * bigInt bit operations.
-       *)
-      local
-         fun make (wordOp, bigIntOp): bigInt * bigInt -> bigInt =
-            fn (lhs: bigInt, rhs: bigInt) =>
-            if areSmall (lhs, rhs)
-               then
-                  let
-                     val ansv = wordOp (stripTag lhs, stripTag rhs)
-                     val ans = addTag ansv
-                  in
-                     Prim.fromWord ans
-                  end
-            else
-               dontInline
-               (fn () => 
-                bigIntOp (lhs, rhs, reserve (Int.max (size lhs, size rhs), 0)))
-      in
-         val bigAndb = make (Word.andb, Prim.andb)
-         val bigOrb = make (Word.orb, Prim.orb)
-         val bigXorb = make (Word.xorb, Prim.xorb)
-      end
-
-      fun bigNotb (arg: bigInt): bigInt =
-         if isSmall arg
-            then Prim.fromWord (addTag (Word.notb (stripTag arg)))
-         else dontInline (fn () => Prim.notb (arg, reserve (size arg, 0)))
-
-      local
-         val bitsPerLimb : Word.word = 0w32
-         fun shiftSize shift = Word.toIntX (Word.div (shift, bitsPerLimb))
-      in
-         fun bigArshift (arg: bigInt, shift: word): bigInt =
-            if shift = 0wx0
-               then arg
-            else Prim.~>> (arg, shift,
-                           reserve (Int.max (1, size arg -? shiftSize shift),
-                                    0))
-
-         fun bigLshift (arg: bigInt, shift: word): bigInt =
-            if shift = 0wx0
-               then arg
-            else Prim.<< (arg, shift, reserve (size arg +? shiftSize shift, 1))
-      end
-   
-      type int = bigInt
-      val abs = bigAbs
-      val compare = bigCompare
-      val divMod = divMod
-      val fmt = bigFmt
-      val fromInt = bigFromInt
-      val fromInt64 = bigFromInt64
-      val fromLarge = fn x => x
-      val fromString = bigFromString
-      val gcd = bigGcd
-      val max = bigMax
-      val maxInt = NONE
-      val min = bigMin
-      val minInt = NONE
-      val op * = bigMul
-      val op + = bigPlus
-      val op - = bigMinus
-      val op < = bigLT
-      val op <= = bigLE
-      val op > = bigGT
-      val op >= = bigGE
-      val op div = op div
-      val op mod = op mod
-      val pow = pow
-      val precision = NONE
-      val quot = bigQuot
-      val quotRem = quotRem
-      val rem = bigRem
-      val rep = rep
-      val sameSign = bigSameSign
-      val scan = bigScan
-      val sign = bigSign
-      val toInt = bigToInt
-      val toInt64 = bigToInt64
-      val toLarge = fn x => x
-      val toString = bigToString
-      val ~ = bigNegate
-      val andb = bigAndb
-      val notb = bigNotb
-      val orb = bigOrb
-      val xorb = bigXorb
-      val ~>> = bigArshift
-      val << = bigLshift
+      val isSmall = Prim.isSmall
+      val areSmall = Prim.areSmall
    end
-
-structure LargeInt = IntInf

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml	2006-03-03 02:19:52 UTC (rev 4368)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml	2006-03-03 18:51:40 UTC (rev 4369)
@@ -15,14 +15,29 @@
          Big of C_MPLimb.word vector
        | Small of ObjptrInt.int
       val rep: int -> rep
-      val areSmall: int * int -> bool
 
       val maxInt: int option
       val minInt: int option
 
       val zero: int
       val one: int
+      val negOne: int
 
+      structure Prim : 
+         sig
+            val isSmall: int -> bool
+            val areSmall: int * int -> bool
+            val dropTag: ObjptrWord.word -> ObjptrWord.word
+            val dropTagCoerce: int -> ObjptrWord.word
+            val dropTagCoerceInt: int -> ObjptrInt.int
+            val addTag: ObjptrWord.word -> ObjptrWord.word
+            val addTagCoerce: ObjptrWord.word -> int
+            val addTagCoerceInt: ObjptrInt.int -> int
+            val zeroTag: ObjptrWord.word -> ObjptrWord.word
+            val oneTag: ObjptrWord.word -> ObjptrWord.word
+            val oneTagCoerce: ObjptrWord.word -> int
+         end
+
       val abs: int -> int
       val +? : int * int -> int
       val + : int * int -> int
@@ -51,7 +66,8 @@
       val leu: int * int -> bool
       val gtu: int * int -> bool
       val geu: int * int -> bool
-
+      val isNeg: int -> bool
+               
       val andb: int * int -> int
       val << : int * Primitive.Word32.word -> int
       val notb: int -> int
@@ -59,7 +75,13 @@
       val ~>> : int * Primitive.Word32.word -> int
       val xorb: int * int -> int
 
-      val toString8: int -> Primitive.String8.string
+      val mkCvt: ({base: Primitive.Int32.int,
+                   smallCvt: ObjptrInt.int -> Primitive.String8.string} 
+                  -> int -> Primitive.String8.string)
+      val mkLog2: ({fromSmall: {smallLog2: Primitive.Int32.int} -> 'a,
+                    fromLarge: {mostSigLimbLog2: Primitive.Int32.int,
+                                numLimbsMinusOne: SeqIndex.int} -> 'a}
+                   -> int -> 'a)
 
       (* Sign extend. *)
       val fromInt8Unsafe: Primitive.Int8.int -> int
@@ -149,7 +171,6 @@
       structure A = Primitive.Array
       structure V = Primitive.Vector
       structure S = SeqIndex
-
       structure W = struct
                        open ObjptrWord
                        local
@@ -186,7 +207,6 @@
                           val toObjptrIntX = S.f
                        end
                     end
-
       structure I = ObjptrInt
       structure MPLimb = C_MPLimb
       structure Sz = struct 
@@ -586,13 +606,13 @@
        * negation and absolute values are not fixnums. 
        * negBadIntInf is the negation (and absolute value) of that IntInf.int.
        *)
-      val badObjptrInt: I.int = I.~>>? (I.minInt', 0w1)
+      val badObjptrInt: I.int = I.~>> (I.minInt', 0w1)
       val badObjptrWord: W.word = W.fromObjptrInt badObjptrInt
       val badObjptrWordTagged: W.word = addTag badObjptrWord
       val badObjptrIntTagged: I.int = W.toObjptrIntX badObjptrWordTagged
       val negBadIntInf: bigInt = fromObjptrInt (I.~ badObjptrInt)
 
-      (* Given two ObjptrWord.word's, check if they have the same `high'/'sign' bit.
+      (* Given two ObjptrWord.word's, check if they have the same 'high'/'sign' bit.
        *)
       fun sameSignBit (lhs: W.word, rhs: W.word): bool =
          I.>= (W.toObjptrIntX (W.xorb (lhs, rhs)), 0)
@@ -707,9 +727,9 @@
          open I
 
          fun mod2 x = I.andb (x, 1)
-         fun div2 x = I.>>? (x, 0w1)
+         fun div2 x = I.>> (x, 0w1)
             
-         fun gcdInt (a, b, acc) =
+         fun smallGcd (a, b, acc) =
             case (a, b) of
                (0, _) => b * acc
              | (_, 0) => a * acc
@@ -728,27 +748,27 @@
                            if 0 = a_r2
                               then
                                  if 0 = b_r2
-                                    then gcdInt (a_2, b_2, acc + acc)
-                                    else gcdInt (a_2, b, acc)
+                                    then smallGcd (a_2, b_2, acc + acc)
+                                    else smallGcd (a_2, b, acc)
                               else
                                  if 0 = b_r2
-                                    then gcdInt (a, b_2, acc)
+                                    then smallGcd (a, b_2, acc)
                                     else
                                        if a >= b
-                                          then gcdInt (div2 (a - b), b, acc)
-                                          else gcdInt (a, div2 (b - a), acc)
+                                          then smallGcd (div2 (a - b), b, acc)
+                                          else smallGcd (a, div2 (b - a), acc)
                         end
       in
          fun bigGcd (lhs: bigInt, rhs: bigInt): bigInt =
             if areSmall (lhs, rhs)
-               then addTagCoerceInt (gcdInt (I.abs (dropTagCoerceInt lhs),
-                                             I.abs (dropTagCoerceInt rhs),
-                                             1))
-               else Prim.gcd (lhs, rhs, 
-                              reserve (S.max (numLimbs lhs, numLimbs rhs), 0))
+               then addTagCoerceInt 
+                    (smallGcd (I.abs (dropTagCoerceInt lhs),
+                               I.abs (dropTagCoerceInt rhs),
+                               1))
+               else Prim.gcd 
+                    (lhs, rhs, reserve (S.max (numLimbs lhs, numLimbs rhs), 0))
       end
 
-
       fun bigCompare (lhs: bigInt, rhs: bigInt): order =
          if areSmall (lhs, rhs)
             then I.compare (W.toObjptrIntX (Prim.toWord lhs),
@@ -790,18 +810,6 @@
       fun bigMax (lhs: bigInt, rhs: bigInt): bigInt =
          if bigLE (lhs, rhs) then rhs else lhs
 
-(*
-      fun bigSign' (arg: bigInt): Int32.int =
-         if isSmall arg
-            then I.sign' (dropTagCoerceInt arg)
-            else if bigIsNeg arg
-                    then ~1
-                    else 1
-
-      fun bigSameSign (lhs: bigInt, rhs: bigInt): bool =
-         bigSign' lhs = bigSign' rhs
-*)
-
       local
          fun bigLTU (lhs, rhs) =
             case (bigCompare (lhs, 0), bigCompare (rhs, 0)) of
@@ -903,18 +911,72 @@
                               reserve (S.max (1, S.- (numLimbs arg, shiftSize shift)), 0))
       end
 
-      fun bigToString8 (arg: bigInt): String8.string =
-         Prim.toString
-         (arg, 10, Sz.+ (bytesPerArrayHeader (* Array Header *),
-                         Sz.+ (0w2, (* sign *)
-                               Sz.* (0w10, Sz.fromSeqIndex (numLimbs arg)))))
+      fun mkBigCvt {base: Int32.int,
+                    smallCvt: I.int -> Primitive.String8.string}
+                   (arg: bigInt)
+                   : Primitive.String8.string =
+         if isSmall arg
+            then smallCvt (dropTagCoerceInt arg)
+            else let
+                    val bpd = Word32.log2 (Word32.fromInt32 base)
+                    val bpl = MPLimb.wordSize
+                    val dpl =
+                       Int32.+ (Int32.quot (bpl, bpd),
+                                if Int32.mod (bpl, bpd) = 0
+                                   then 0 else 1)
+                 in
+                    Prim.toString
+                    (arg, base, 
+                     Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
+                                 0w1 (* sign *)),
+                           Sz.* (Sz.fromInt32 dpl, 
+                                 Sz.fromSeqIndex (numLi...
 
[truncated message content]

[MLton-commit] r4368

[Matthew F. <fl...@ml...>]

Ported bugfix from SML/NJ:

[2006-02-27]
 Fixed bug with the combination of withNack and never, where the
 negative acknowledgement is never generated.  Thanks to Heath
 Putnam for the bug report and fix.


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

U   mlton/trunk/lib/cml/core-cml/event.sml

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

Modified: mlton/trunk/lib/cml/core-cml/event.sml
===================================================================
--- mlton/trunk/lib/cml/core-cml/event.sml	2006-03-02 21:26:05 UTC (rev 4367)
+++ mlton/trunk/lib/cml/core-cml/event.sml	2006-03-03 02:19:52 UTC (rev 4368)
@@ -421,7 +421,7 @@
 
       (* walk the event group tree, collecting the base events (with associated
        * ack flags), and a list of flag sets.  A flag set is a (cvar * ack flag list)
-       * pairs, where the flags are those associated with the events covered by the
+       * pair, where the flags are those associated with the events covered by the
        * nack cvar.
        *)
       type ack_flg = bool ref
@@ -590,10 +590,7 @@
                                   extRdy (backs, {prio = prio, doitFn = (doitFn, ackFlg)}::doitFns)
                              | _ => extRdy (backs, doitFns))
                end
-            val x =
-               case backs of
-                  [(bevt, _)] => syncOnBEvt bevt
-                | _ => (S.atomicBegin (); ext (backs, []))
+            val x = (S.atomicBegin (); ext (backs, []))
             val () = debug' "syncOnGrp(4)" (* NonAtomic *)
             val () = Assert.assertNonAtomic' "Event.syncOnGrp(4)"
          in

[MLton-commit] r4367

[Stephen W. <sw...@ml...>]

Fixed and simplified String.concatV.

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

U   mlton/trunk/lib/mlton/basic/string.sml

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

Modified: mlton/trunk/lib/mlton/basic/string.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/string.sml	2006-03-02 21:07:25 UTC (rev 4366)
+++ mlton/trunk/lib/mlton/basic/string.sml	2006-03-02 21:26:05 UTC (rev 4367)
@@ -24,31 +24,24 @@
                       end)
          end
 
-      fun concatV ss =
-         if 0 = Vector.length ss then
-            ""
-         else
-            let
-               fun str i =
-                  let
-                     val s = Vector.sub (ss, i)
-                  in
-                     (s, String.size s, i, 0)
-                  end
-            in
-               unfold
-               (Vector.fold (ss, 0, fn (s, n) => n + size s),
-                str 0, fn (s, n, i, j) =>
-                (String.sub (s, j),
-                 let
-                    val j = j + 1
-                 in
-                    if j = n then
-                       str (i + 1)
-                    else
-                       (s, n, i, j)
-                 end))
-            end
+      fun concatV ss = 
+         case Vector.length ss of
+            0 => ""
+          | 1 => Vector.sub (ss, 0)
+          | _ =>
+               let
+                  val n =
+                     Vector.fold (ss, 0, fn (s, n) => n + size s)
+                  val a = Array.new (n, #"a")
+                  val _ =
+                     Vector.fold
+                     (ss, 0, fn (s, i) =>
+                      fold (s, i, fn (c, i) =>
+                            (Array.update (a, i, c);
+                             i + 1)))
+               in
+                  tabulate (n, fn i => Array.sub (a, i))
+               end
 
       fun existsi (s, f) = Int.exists (0, size s, fn i => f (i, sub (s, i)))
 

[MLton-commit] r4366

[Stephen W. <sw...@ml...>]

Exported signature VECTOR.

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

U   mlton/trunk/lib/mlton/basic/sources.mlb
U   mlton/trunk/lib/mlton/sources.mlb

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

Modified: mlton/trunk/lib/mlton/basic/sources.mlb
===================================================================
--- mlton/trunk/lib/mlton/basic/sources.mlb	2006-03-02 20:57:26 UTC (rev 4365)
+++ mlton/trunk/lib/mlton/basic/sources.mlb	2006-03-02 21:07:25 UTC (rev 4366)
@@ -198,6 +198,7 @@
       signature STRING
       signature T
       signature UNIQUE_ID
+      signature VECTOR
 
       structure AppendList
       structure Array

Modified: mlton/trunk/lib/mlton/sources.mlb
===================================================================
--- mlton/trunk/lib/mlton/sources.mlb	2006-03-02 20:57:26 UTC (rev 4365)
+++ mlton/trunk/lib/mlton/sources.mlb	2006-03-02 21:07:25 UTC (rev 4366)
@@ -32,6 +32,7 @@
       signature STRING
       signature T
       signature UNIQUE_ID
+      signature VECTOR
 
       structure AppendList
       structure Array

[MLton-commit] r4365

[Stephen W. <sw...@ml...>]

Exported signature VECTOR.

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

U   mlton/trunk/lib/mlton/basic/sources.cm
U   mlton/trunk/lib/mlton/sources.cm

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

Modified: mlton/trunk/lib/mlton/basic/sources.cm
===================================================================
--- mlton/trunk/lib/mlton/basic/sources.cm	2006-03-02 20:14:16 UTC (rev 4364)
+++ mlton/trunk/lib/mlton/basic/sources.cm	2006-03-02 20:57:26 UTC (rev 4365)
@@ -27,6 +27,7 @@
 signature SUM
 signature T
 signature UNIQUE_ID
+signature VECTOR
 
 structure AppendList
 structure Array

Modified: mlton/trunk/lib/mlton/sources.cm
===================================================================
--- mlton/trunk/lib/mlton/sources.cm	2006-03-02 20:14:16 UTC (rev 4364)
+++ mlton/trunk/lib/mlton/sources.cm	2006-03-02 20:57:26 UTC (rev 4365)
@@ -46,6 +46,7 @@
 signature SUM
 signature T
 signature UNIQUE_ID
+signature VECTOR
 
 structure AppendList
 structure Array

[MLton-commit] r4364

[Stephen W. <sw...@ml...>]

Exported Timer.

Added Vector.size.

Added String.{concatV,exists,unfold}.

Used MLton.Word.rol to implement Word.rotateLeft.


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

U   mlton/trunk/lib/mlton/basic/sources.cm
U   mlton/trunk/lib/mlton/basic/string.sig
U   mlton/trunk/lib/mlton/basic/string.sml
U   mlton/trunk/lib/mlton/basic/vector.fun
U   mlton/trunk/lib/mlton/basic/vector.sig
U   mlton/trunk/lib/mlton/basic/word.sml
U   mlton/trunk/lib/mlton/sources.cm
U   mlton/trunk/lib/mlton-stubs/sources.cm
U   mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm

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

Modified: mlton/trunk/lib/mlton/basic/sources.cm
===================================================================
--- mlton/trunk/lib/mlton/basic/sources.cm	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/basic/sources.cm	2006-03-02 20:14:16 UTC (rev 4364)
@@ -124,6 +124,7 @@
 structure SysWord
 structure Thread
 structure Time
+structure Timer
 structure Trace
 structure Tree
 structure TwoListQueue

Modified: mlton/trunk/lib/mlton/basic/string.sig
===================================================================
--- mlton/trunk/lib/mlton/basic/string.sig	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/basic/string.sig	2006-03-02 20:14:16 UTC (rev 4364)
@@ -26,6 +26,7 @@
       val baseName: t * t -> t
       val compare: t * t -> Relation.t
       val concat: t list -> t
+      val concatV: t vector -> t
       val concatWith: t list * t -> t
       val contains: t * char -> bool
       val deleteSurroundingWhitespace: t -> t
@@ -41,6 +42,7 @@
       val escapeC: t -> t
       val escapeSML: t -> t
       val existsi: t * (int * char -> bool) -> bool
+      val exists: t * (char -> bool) -> bool
       val explode: t -> char list
       (* extract (s, i, SOME j)
        * returns the substring of s of length j starting at i.
@@ -103,6 +105,7 @@
       val toUpper: t -> t
       val tokens: t * (char -> bool) -> t list 
       val translate: t * (char -> t) -> t
+      val unfold: int * 'a * ('a -> char * 'a) -> t
    end
 
 

Modified: mlton/trunk/lib/mlton/basic/string.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/string.sml	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/basic/string.sml	2006-03-02 20:14:16 UTC (rev 4364)
@@ -11,8 +11,49 @@
    struct
       open String1
 
+      fun unfold (n, a, f) =
+         let
+            val r = ref a
+         in
+            tabulate (n, fn _ =>
+                      let
+                         val (b, a) = f (!r)
+                         val () = r := a
+                      in
+                         b
+                      end)
+         end
+
+      fun concatV ss =
+         if 0 = Vector.length ss then
+            ""
+         else
+            let
+               fun str i =
+                  let
+                     val s = Vector.sub (ss, i)
+                  in
+                     (s, String.size s, i, 0)
+                  end
+            in
+               unfold
+               (Vector.fold (ss, 0, fn (s, n) => n + size s),
+                str 0, fn (s, n, i, j) =>
+                (String.sub (s, j),
+                 let
+                    val j = j + 1
+                 in
+                    if j = n then
+                       str (i + 1)
+                    else
+                       (s, n, i, j)
+                 end))
+            end
+
       fun existsi (s, f) = Int.exists (0, size s, fn i => f (i, sub (s, i)))
 
+      fun exists (s, f) = existsi (s, f o #2)
+
       fun keepAll (s: t, f: char -> bool): t =
          implode (List.rev
                   (fold (s, [], fn (c, ac) => if f c then c :: ac else ac)))

Modified: mlton/trunk/lib/mlton/basic/vector.fun
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.fun	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/basic/vector.fun	2006-03-02 20:14:16 UTC (rev 4364)
@@ -13,6 +13,8 @@
 
 open S
 
+val size = length
+
 fun unfold (n, a, f) = unfoldi (n, a, f o #2)
    
 fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))

Modified: mlton/trunk/lib/mlton/basic/vector.sig
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.sig	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/basic/vector.sig	2006-03-02 20:14:16 UTC (rev 4364)
@@ -111,6 +111,7 @@
       val removeDuplicates: 'a t * ('a * 'a -> bool) -> 'a t
       val removeFirst: 'a t * ('a -> bool) -> 'a t
       val rev: 'a t -> 'a t
+      val size: 'a t -> int
       val splitLast: 'a t -> 'a t * 'a
       val tabulate: int * (int -> 'a) -> 'a t
       val tabulator: int * (('a -> unit) -> unit) -> 'a t

Modified: mlton/trunk/lib/mlton/basic/word.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/word.sml	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/basic/word.sml	2006-03-02 20:14:16 UTC (rev 4364)
@@ -23,15 +23,7 @@
                  orb (w (2, 0w16), w (3, 0w24)))
          end
 
-      local
-         val wordSize = fromInt wordSize
-      in
-         fun rotateLeft (w: t, n: t) =
-            let val l = n mod wordSize
-               val r = wordSize - l
-            in orb (<< (w, l), >> (w, r))
-            end
-      end
+      val rotateLeft = MLton.Word.rol
 
       val fromWord = fn x => x
       val toWord = fn x => x

Modified: mlton/trunk/lib/mlton/sources.cm
===================================================================
--- mlton/trunk/lib/mlton/sources.cm	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton/sources.cm	2006-03-02 20:14:16 UTC (rev 4364)
@@ -145,6 +145,7 @@
 structure SysWord
 structure Thread
 structure Time
+structure Timer
 structure Trace
 structure Tree
 structure TwoListQueue

Modified: mlton/trunk/lib/mlton-stubs/sources.cm
===================================================================
--- mlton/trunk/lib/mlton-stubs/sources.cm	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton-stubs/sources.cm	2006-03-02 20:14:16 UTC (rev 4364)
@@ -55,6 +55,7 @@
 structure SysWord
 structure TextIO
 structure Time
+structure Timer
 structure Unix
 structure Unsafe
 structure Vector

Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm	2006-03-02 19:55:59 UTC (rev 4363)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm	2006-03-02 20:14:16 UTC (rev 4364)
@@ -58,6 +58,7 @@
 structure SysWord
 structure TextIO
 structure Time
+structure Timer
 structure Unix
 structure Unsafe
 structure Vector