[fix] stdlib: Move stuff.ml into bson.ml. Remove endian.ml. Default o…

…verflowed ints to new abstract int64 type.

libbase.mllib

@@ -102,7 +102,5 @@ libbase/Terminal
 libbase/Wsdl2mlCommon
 # Bson
 libbase/Buf
-libbase/Endian
-libbase/Stuff
 libbase/Bson
 libbase/Mongo

libbase/_tags

@@ -21,7 +21,6 @@
 <file_mimetype.ml>: with_mlstate_debug
 <bson.ml>: with_mlstate_debug
 <mongo.ml>: with_mlstate_debug
-<endian.ml>: with_mlstate_debug
 
 
 <{testconsole,testfilepos}.{ml,mli,byte,native}>: thread, use_str, use_unix, use_libbase, use_ulex

libbase/bson.ml

@@ -77,8 +77,167 @@ struct
   let rebase _ = ()
   let unsafe_sub = String.sub
 end
-module St = Stuff.StuffF(S)
+module type FILLBUF =
+sig
+  type t
+  val get : t -> int -> char
+  val set : t -> int -> char -> unit
+end
+
+module FillbufF (S : FILLBUF) =
+struct
+
+  let lei32 s pos i =
+    S.set s (pos+3) (Char.chr ((i lsr 24) land 0xff));
+    S.set s (pos+2) (Char.chr ((i lsr 16) land 0xff));
+    S.set s (pos+1) (Char.chr ((i lsr 8 ) land 0xff));
+    S.set s (pos+0) (Char.chr ( i         land 0xff))
+
+  let bei32 s pos i =
+    S.set s (pos+0) (Char.chr ((i lsr 24) land 0xff));
+    S.set s (pos+1) (Char.chr ((i lsr 16) land 0xff));
+    S.set s (pos+2) (Char.chr ((i lsr 8 ) land 0xff));
+    S.set s (pos+3) (Char.chr ( i         land 0xff))
+
+  let led s pos f =
+    let b = Int64.bits_of_float f in
+    S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 56) 0xffL)));
+    S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 48) 0xffL)));
+    S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 40) 0xffL)));
+    S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 32) 0xffL)));
+    S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 24) 0xffL)));
+    S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 16) 0xffL)));
+    S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 8 ) 0xffL)));
+    S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand (                          b   ) 0xffL)))
+
+  let bed s pos f =
+    let b = Int64.bits_of_float f in
+    S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 56) 0xffL)));
+    S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 48) 0xffL)));
+    S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 40) 0xffL)));
+    S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 32) 0xffL)));
+    S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 24) 0xffL)));
+    S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 16) 0xffL)));
+    S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 8 ) 0xffL)));
+    S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand (                          b   ) 0xffL)))
+
+  let lei32l s pos i32 =
+    S.set s (pos+3) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 24) 0xffl)));
+    S.set s (pos+2) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 16) 0xffl)));
+    S.set s (pos+1) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 8 ) 0xffl)));
+    S.set s (pos+0) (Char.chr (Int32.to_int (Int32.logand (                          i32   ) 0xffl)))
+
+  let bei32l s pos i32 =
+    S.set s (pos+0) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 24) 0xffl)));
+    S.set s (pos+1) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 16) 0xffl)));
+    S.set s (pos+2) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 8 ) 0xffl)));
+    S.set s (pos+3) (Char.chr (Int32.to_int (Int32.logand (                          i32   ) 0xffl)))
+
+  let lei64L s pos i64 =
+    S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 56) 0xffL)));
+    S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 48) 0xffL)));
+    S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 40) 0xffL)));
+    S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 32) 0xffL)));
+    S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 24) 0xffL)));
+    S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 16) 0xffL)));
+    S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 8 ) 0xffL)));
+    S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand (                          i64   ) 0xffL)))
+
+  let bei64L s pos i64 =
+    S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 56) 0xffL)));
+    S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 48) 0xffL)));
+    S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 40) 0xffL)));
+    S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 32) 0xffL)));
+    S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 24) 0xffL)));
+    S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 16) 0xffL)));
+    S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 8 ) 0xffL)));
+    S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand (                          i64   ) 0xffL)))
+
+  let ldi32l s i =
+    (Int32.logor (Int32.logand (Int32.shift_left (Int32.of_int (Char.code (S.get (s) (i+3)))) 24) 0x00000000ff000000l)
+    (Int32.logor (Int32.logand (Int32.shift_left (Int32.of_int (Char.code (S.get (s) (i+2)))) 16) 0x0000000000ff0000l)
+    (Int32.logor (Int32.logand (Int32.shift_left (Int32.of_int (Char.code (S.get (s) (i+1))))  8) 0x000000000000ff00l)
+                 (Int32.logand (                 (Int32.of_int (Char.code (S.get (s) (i+0))))   ) 0x00000000000000ffl))))
+
+  let bdi32l s i =
+    (Int32.logor (Int32.logand (Int32.shift_left (Int32.of_int (Char.code (S.get (s) (i+0)))) 24) 0x00000000ff000000l)
+    (Int32.logor (Int32.logand (Int32.shift_left (Int32.of_int (Char.code (S.get (s) (i+1)))) 16) 0x0000000000ff0000l)
+    (Int32.logor (Int32.logand (Int32.shift_left (Int32.of_int (Char.code (S.get (s) (i+2))))  8) 0x000000000000ff00l)
+                 (Int32.logand (                 (Int32.of_int (Char.code (S.get (s) (i+3))))   ) 0x00000000000000ffl))))
+
+  let ldi32 s i = Int32.to_int(ldi32l s i)
+  let bdi32 s i = Int32.to_int(bdi32l s i)
+
+  let ldi64L s i =
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+7)))) 56) 0xff00000000000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+6)))) 48) 0x00ff000000000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+5)))) 40) 0x0000ff0000000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+4)))) 32) 0x000000ff00000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+3)))) 24) 0x00000000ff000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+2)))) 16) 0x0000000000ff0000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+1))))  8) 0x000000000000ff00L)
+                 (Int64.logand (                 (Int64.of_int (Char.code (S.get (s) (i+0))))   ) 0x00000000000000ffL))))))))
+
+  let bdi64L s i =
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+0)))) 56) 0xff00000000000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+1)))) 48) 0x00ff000000000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+2)))) 40) 0x0000ff0000000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+3)))) 32) 0x000000ff00000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+4)))) 24) 0x00000000ff000000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+5)))) 16) 0x0000000000ff0000L)
+    (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+6))))  8) 0x000000000000ff00L)
+                 (Int64.logand (                 (Int64.of_int (Char.code (S.get (s) (i+7))))   ) 0x00000000000000ffL))))))))
+
+  let ldd s i = Int64.float_of_bits (ldi64L s i)
+  let bdd s i = Int64.float_of_bits (bdi64L s i)
+
+end (* module FillbufF *)
+
+module FillbufString = FillbufF(String)
+
+let add_le_int32 b i =
+  if Buf.spare b <= 4 then raise (Failure "add_le_int32");
+  FillbufString.lei32 b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 4
+
+let add_be_int32 b i =
+  if Buf.spare b <= 4 then raise (Failure "add_be_int32");
+  FillbufString.bei32 b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 4
+
+let add_le_d b i =
+  if Buf.spare b <= 8 then raise (Failure "add_le_d");
+  FillbufString.led b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 8
+
+let add_be_d b i =
+  if Buf.spare b <= 8 then raise (Failure "add_be_d");
+  FillbufString.bed b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 8
+
+let add_le_int32l b i =
+  if Buf.spare b <= 4 then raise (Failure "add_le_i32l");
+  FillbufString.lei32l b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 4
+
+let add_be_int32l b i =
+  if Buf.spare b <= 4 then raise (Failure "add_be_i32l");
+  FillbufString.bei32l b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 4
+
+let add_le_int64L b i =
+  if Buf.spare b <= 4 then raise (Failure "add_le_i64L");
+  FillbufString.lei64L b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 8
+
+let add_be_int64L b i =
+  if Buf.spare b <= 4 then raise (Failure "add_be_i64L");
+  FillbufString.bei64L b.Buf.str b.Buf.i i;
+  b.Buf.i <- b.Buf.i + 8
+
+module St = FillbufF(S)
 module SS = BaseStringSlice
+
 let sprintf = Printf.sprintf
 let fprintf = Printf.fprintf
 
@@ -185,15 +344,15 @@ struct
 
   let int b name i =
     estart b el_int name;
-    Stuff.add_le_int32l b.buf i
+    add_le_int32l b.buf i
 
   let long b name l =
     estart b el_long name;
-    Stuff.add_le_int64L b.buf l
+    add_le_int64L b.buf l
 
   let double b name d =
     estart b el_double name;
-    Stuff.add_le_d b.buf d
+    add_le_d b.buf d
 
   let bool b name _b =
     estart b el_bool name;
@@ -213,7 +372,7 @@ struct
 
   let string_base b name value len _type =
     estart b _type name;
-    Stuff.add_le_int32 b.buf (len+1);
+    add_le_int32 b.buf (len+1);
     Buf.append b.buf value len;
     Buf.add_char b.buf '\x00'
 
@@ -240,8 +399,8 @@ struct
     let ssize = size scope in
     let size = slen + ssize + 8 in
     estart b el_codewscope name;
-    Stuff.add_le_int32 b.buf size;
-    Stuff.add_le_int32 b.buf slen;
+    add_le_int32 b.buf size;
+    add_le_int32 b.buf slen;
     Buf.append b.buf code len;
     Buf.add_char b.buf '\x00';
     Buf.append b.buf scope.buf.Buf.str ssize
@@ -250,12 +409,12 @@ struct
     let len = S.length code in
     estart b el_codewscope name;
     b.stack <- b.buf.Buf.i :: b.stack;
-    Stuff.add_le_int32 b.buf 0;
-    Stuff.add_le_int32 b.buf (len+1);
+    add_le_int32 b.buf 0;
+    add_le_int32 b.buf (len+1);
     Buf.append b.buf code len;
     Buf.add_char b.buf '\x00';
     b.stack <- b.buf.Buf.i :: b.stack;
-    Stuff.add_le_int32 b.buf 0
+    add_le_int32 b.buf 0
 
   let finish_codewscope b code =
     Buf.add_char b.buf '\x00';
@@ -275,12 +434,12 @@ struct
   let binary b name _type str len =
     if _type = st_bin_binary_old
     then (estart b el_bindata name;
-          Stuff.add_le_int32 b.buf (len+4);
+          add_le_int32 b.buf (len+4);
           Buf.add_char b.buf _type;
-          Stuff.add_le_int32 b.buf len;
+          add_le_int32 b.buf len;
           Buf.append b.buf str len)
     else (estart b el_bindata name;
-          Stuff.add_le_int32 b.buf len;
+          add_le_int32 b.buf len;
           Buf.add_char b.buf _type;
           Buf.append b.buf str len)
 
@@ -307,25 +466,25 @@ struct
 
   let timestamp b name (i,t) =
     estart b el_timestamp name;
-    Stuff.add_le_int32l b.buf i;
-    Stuff.add_le_int32l b.buf t
+    add_le_int32l b.buf i;
+    add_le_int32l b.buf t
 
   let date b name millis =
     estart b el_date name;
-    Stuff.add_le_int64L b.buf millis
+    add_le_int64L b.buf millis
 
   let time_t b name t =
     date b name (Int64.of_int (Time.in_milliseconds t))
 
   let start_object b name =
     estart b el_object name;
     b.stack <- b.buf.Buf.i :: b.stack;
-    Stuff.add_le_int32 b.buf 0
+    add_le_int32 b.buf 0
 
   let start_array b name =
     estart b el_array name;
     b.stack <- b.buf.Buf.i :: b.stack;
-    Stuff.add_le_int32 b.buf 0
+    add_le_int32 b.buf 0
 
   let finish_object b =
     Buf.add_char b.buf '\x00';
@@ -390,7 +549,7 @@ module IteratorF(S : S_sig) : Iterator_sig with module S = S =
 struct
 
   module S = S
-  module St = Stuff.StuffF(S)
+  module St = FillbufF(S)
 
   type iter =
       { ibuf : S.t;

libbase/bson.mli

@@ -90,6 +90,63 @@ module type S_sig =
     val unsafe_sub : t -> int -> int -> t
   end
 
+module type FILLBUF =
+  sig
+    type t
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+  end
+
+module FillbufF :
+  functor (S : FILLBUF) ->
+    sig
+      val lei32 : S.t -> int -> int -> unit
+      val bei32 : S.t -> int -> int -> unit
+      val led : S.t -> int -> float -> unit
+      val bed : S.t -> int -> float -> unit
+      val lei32l : S.t -> int -> int32 -> unit
+      val bei32l : S.t -> int -> int32 -> unit
+      val lei64L : S.t -> int -> int64 -> unit
+      val bei64L : S.t -> int -> int64 -> unit
+      val ldi32 : S.t -> int -> int
+      val bdi32 : S.t -> int -> int
+      val ldi32l : S.t -> int -> int32
+      val bdi32l : S.t -> int -> int32
+      val ldi64L : S.t -> int -> int64
+      val bdi64L : S.t -> int -> int64
+      val ldd : S.t -> int -> float
+      val bdd : S.t -> int -> float
+    end
+
+module FillbufString :
+  sig
+    val lei32 : string -> int -> int -> unit
+    val bei32 : string -> int -> int -> unit
+    val led : string -> int -> float -> unit
+    val bed : string -> int -> float -> unit
+    val lei32l : string -> int -> int32 -> unit
+    val bei32l : string -> int -> int32 -> unit
+    val lei64L : string -> int -> int64 -> unit
+    val bei64L : string -> int -> int64 -> unit
+    val ldi32 : string -> int -> int
+    val bdi32 : string -> int -> int
+    val ldi32l : string -> int -> int32
+    val bdi32l : string -> int -> int32
+    val ldi64L : string -> int -> int64
+    val bdi64L : string -> int -> int64
+    val ldd : string -> int -> float
+    val bdd : string -> int -> float
+  end
+
+val add_le_int32 : Buf.buf -> int -> unit
+val add_be_int32 : Buf.buf -> int -> unit
+val add_le_d : Buf.buf -> float -> unit
+val add_be_d : Buf.buf -> float -> unit
+val add_le_int32l : Buf.buf -> int32 -> unit
+val add_be_int32l : Buf.buf -> int32 -> unit
+val add_le_int64L : Buf.buf -> int64 -> unit
+val add_be_int64L : Buf.buf -> int64 -> unit
+
 module S : S_sig with type t = string
 module SS : S_sig with type t = BaseStringSlice.t