@tellahq/rescript 10.1.4-republish-2 → 10.1.4-republish-3

package/lib/ocaml/printexc.ml

@@ -0,0 +1,75 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+[@@@bs.config { flags = [| "-bs-no-cross-module-opt" |] }]
+
+let printers = ref []
+
+let locfmt s (linum : int) (start : int) (finish : int) msg =
+  (((((((("File \"" ^ s) ^ "\", line ") ^ __unsafe_cast linum) ^ ", characters ")
+     ^ __unsafe_cast start)
+    ^ "-")
+   ^ __unsafe_cast finish)
+  ^ ": ")
+  ^ msg
+
+let fields : exn -> string =
+  [%raw
+    {|function(x){
+  var s = "" 
+  var index = 1
+  while ("_"+index in x){
+    s += x ["_" + index];
+    ++ index
+  }
+  if(index === 1){
+    return s 
+  }
+  return "(" + s + ")"
+}
+|}]
+
+external exn_slot_name : exn -> string = "?exn_slot_name"
+
+let to_string x =
+  let rec conv = function
+    | hd :: tl -> (
+        match try hd x with _ -> None with Some s -> s | None -> conv tl)
+    | [] -> (
+        match x with
+        | Match_failure (file, line, char) ->
+            locfmt file line char (char + 5) "Pattern matching failed"
+        | Assert_failure (file, line, char) ->
+            locfmt file line char (char + 6) "Assertion failed"
+        | Undefined_recursive_module (file, line, char) ->
+            locfmt file line char (char + 6) "Undefined recursive module"
+        | _ ->
+            let constructor = exn_slot_name x in
+            constructor ^ fields x)
+  in
+  conv !printers
+
+let print fct arg =
+  try fct arg
+  with x ->
+    Js.log ("Uncaught exception: " ^ to_string x);
+    raise x
+
+let catch fct arg =
+  try fct arg
+  with x ->
+    Js.log ("Uncaught exception: " ^ to_string x);
+    exit 2
+
+let register_printer fn = printers := fn :: !printers

package/lib/ocaml/printexc.mli

@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+[@@@ocaml.deprecated "This module is deprecated"]
+(** Facilities for printing exceptions and inspecting current call stack. *)
+
+val to_string: exn -> string
+(** [Printexc.to_string e] returns a string representation of
+   the exception [e]. *)
+
+val print: ('a -> 'b) -> 'a -> 'b
+(** [Printexc.print fn x] applies [fn] to [x] and returns the result.
+   If the evaluation of [fn x] raises any exception, the
+   name of the exception is printed on standard error output,
+   and the exception is raised again.
+   The typical use is to catch and report exceptions that
+   escape a function application. *)
+
+val catch: ('a -> 'b) -> 'a -> 'b
+(** [Printexc.catch fn x] is similar to {!Printexc.print}, but
+   aborts the program with exit code 2 after printing the
+   uncaught exception.  This function is deprecated: the runtime
+   system is now able to print uncaught exceptions as precisely
+   as [Printexc.catch] does.  Moreover, calling [Printexc.catch]
+   makes it harder to track the location of the exception
+   using the debugger or the stack backtrace facility.
+   So, do not use [Printexc.catch] in new code.  *)
+
+val register_printer: (exn -> string option) -> unit
+(** [Printexc.register_printer fn] registers [fn] as an exception
+    printer.  The printer should return [None] or raise an exception
+    if it does not know how to convert the passed exception, and [Some
+    s] with [s] the resulting string if it can convert the passed
+    exception. Exceptions raised by the printer are ignored.
+
+    When converting an exception into a string, the printers will be invoked
+    in the reverse order of their registrations, until a printer returns
+    a [Some s] value (if no such printer exists, the runtime will use a
+    generic printer).
+
+    When using this mechanism, one should be aware that an exception backtrace
+    is attached to the thread that saw it raised, rather than to the exception
+    itself. Practically, it means that the code related to [fn] should not use
+    the backtrace if it has itself raised an exception before.
+    @since 3.11.2
+*)

package/lib/ocaml/queue.ml

@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Francois Pottier, projet Cristal, INRIA Rocquencourt           *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Empty
+
+type 'a cell =
+  | Nil
+  | Cons of { content: 'a; mutable next: 'a cell }
+
+type 'a t = {
+  mutable length: int;
+  mutable first: 'a cell;
+  mutable last: 'a cell
+}
+
+let create () = {
+  length = 0;
+  first = Nil;
+  last = Nil
+}
+
+let clear q =
+  q.length <- 0;
+  q.first <- Nil;
+  q.last <- Nil
+
+let add x q =
+  let cell = Cons {
+    content = x;
+    next = Nil
+  } in
+  match q.last with
+  | Nil ->
+    q.length <- 1;
+    q.first <- cell;
+    q.last <- cell
+  | Cons last ->
+    q.length <- q.length + 1;
+    last.next <- cell;
+    q.last <- cell
+
+let push =
+  add
+
+let peek q =
+  match q.first with
+  | Nil -> raise Empty
+  | Cons { content } -> content
+
+let top =
+  peek
+
+let take q =
+  match q.first with
+  | Nil -> raise Empty
+  | Cons { content; next = Nil } ->
+    clear q;
+    content
+  | Cons { content; next } ->
+    q.length <- q.length - 1;
+    q.first <- next;
+    content
+
+let pop =
+  take
+
+let copy =
+  let rec copy q_res prev cell =
+    match cell with
+    | Nil -> q_res.last <- prev; q_res
+    | Cons { content; next } ->
+      let res = Cons { content; next = Nil } in
+      begin match prev with
+      | Nil -> q_res.first <- res
+      | Cons p -> p.next <- res
+      end;
+      copy q_res res next
+  in
+  fun q -> copy { length = q.length; first = Nil; last = Nil } Nil q.first
+
+let is_empty q =
+  q.length = 0
+
+let length q =
+  q.length
+
+let iter =
+  let rec iter f cell =
+    match cell with
+    | Nil -> ()
+    | Cons { content; next } ->
+      f content;
+      iter f next
+  in
+  fun f q -> iter f q.first
+
+let fold =
+  let rec fold f accu cell =
+    match cell with
+    | Nil -> accu
+    | Cons { content; next } ->
+      let accu = f accu content in
+      fold f accu next
+  in
+  fun f accu q -> fold f accu q.first
+
+let transfer q1 q2 =
+  if q1.length > 0 then
+    match q2.last with
+    | Nil ->
+      q2.length <- q1.length;
+      q2.first <- q1.first;
+      q2.last <- q1.last;
+      clear q1
+    | Cons last ->
+      q2.length <- q2.length + q1.length;
+      last.next <- q1.first;
+      q2.last <- q1.last;
+      clear q1

package/lib/ocaml/queue.mli

@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** First-in first-out queues.
+
+   This module implements queues (FIFOs), with in-place modification.
+
+   {b Warning} This module is not thread-safe: each {!Queue.t} value
+   must be protected from concurrent access (e.g. with a [Mutex.t]).
+   Failure to do so can lead to a crash.
+*)
+
+type 'a t
+(** The type of queues containing elements of type ['a]. *)
+
+
+exception Empty
+(** Raised when {!Queue.take} or {!Queue.peek} is applied to an empty queue. *)
+
+
+val create : unit -> 'a t
+(** Return a new queue, initially empty. *)
+
+val add : 'a -> 'a t -> unit
+(** [add x q] adds the element [x] at the end of the queue [q]. *)
+
+val push : 'a -> 'a t -> unit
+(** [push] is a synonym for [add]. *)
+
+val take : 'a t -> 'a
+(** [take q] removes and returns the first element in queue [q],
+   or raises {!Empty} if the queue is empty. *)
+
+val pop : 'a t -> 'a
+(** [pop] is a synonym for [take]. *)
+
+val peek : 'a t -> 'a
+(** [peek q] returns the first element in queue [q], without removing
+   it from the queue, or raises {!Empty} if the queue is empty. *)
+
+val top : 'a t -> 'a
+(** [top] is a synonym for [peek]. *)
+
+val clear : 'a t -> unit
+(** Discard all elements from a queue. *)
+
+val copy : 'a t -> 'a t
+(** Return a copy of the given queue. *)
+
+val is_empty : 'a t -> bool
+(** Return [true] if the given queue is empty, [false] otherwise. *)
+
+val length : 'a t -> int
+(** Return the number of elements in a queue. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f q] applies [f] in turn to all elements of [q],
+   from the least recently entered to the most recently entered.
+   The queue itself is unchanged. *)
+
+val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+(** [fold f accu q] is equivalent to [List.fold_left f accu l],
+   where [l] is the list of [q]'s elements. The queue remains
+   unchanged. *)
+
+val transfer : 'a t -> 'a t -> unit
+(** [transfer q1 q2] adds all of [q1]'s elements at the end of
+   the queue [q2], then clears [q1]. It is equivalent to the
+   sequence [iter (fun x -> add x q2) q1; clear q1], but runs
+   in constant time. *)

package/lib/ocaml/random.ml

@@ -0,0 +1,273 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pseudo-random number generator
+   This is a lagged-Fibonacci F(55, 24, +) with a modified addition
+   function to enhance the mixing of bits.
+   If we use normal addition, the low-order bit fails tests 1 and 7
+   of the Diehard test suite, and bits 1 and 2 also fail test 7.
+   If we use multiplication as suggested by Marsaglia, it doesn't fare
+   much better.
+   By mixing the bits of one of the numbers before addition (XOR the
+   5 high-order bits into the low-order bits), we get a generator that
+   passes all the Diehard tests.
+*)
+
+let random_seed: unit -> int array = fun _ -> 
+  let seed :int = [%raw "Math.floor(Math.random()*0x7fffffff)"] in
+  [|seed|]
+
+module State = struct
+
+  type t = { st : int array; mutable idx : int }
+
+  let new_state () = { st = Array.make 55 0; idx = 0 }
+  let assign st1 st2 =
+    Array.blit st2.st 0 st1.st 0 55;
+    st1.idx <- st2.idx
+
+
+  let full_init s seed =
+    let combine accu x = Digest.string (accu ^ string_of_int x) in
+    let extract d =
+      Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16)
+      + (Char.code d.[3] lsl 24)
+    in
+    let seed = if Array.length seed = 0 then [| 0 |] else seed in
+    let l = Array.length seed in
+    for i = 0 to 54 do
+      s.st.(i) <- i;
+    done;
+    let accu = ref "x" in
+    for i = 0 to 54 + max 55 l do
+      let j = i mod 55 in
+      let k = i mod l in
+      accu := combine !accu seed.(k);
+      s.st.(j) <- (s.st.(j) lxor extract !accu) land 0x3FFFFFFF;  (* PR#5575 *)
+    done;
+    s.idx <- 0
+
+
+  let make seed =
+    let result = new_state () in
+    full_init result seed;
+    result
+
+
+  let make_self_init () = make (random_seed ())
+
+  let copy s =
+    let result = new_state () in
+    assign result s;
+    result
+
+
+  (* Returns 30 random bits as an integer 0 <= x < 1073741824 *)
+  let bits s =
+    s.idx <- (s.idx + 1) mod 55;
+    let curval = s.st.(s.idx) in
+    let newval = s.st.((s.idx + 24) mod 55)
+                 + (curval lxor ((curval lsr 25) land 0x1F)) in
+    let newval30 = newval land 0x3FFFFFFF in  (* PR#5575 *)
+    s.st.(s.idx) <- newval30;
+    newval30
+
+
+  let rec intaux s n =
+    let r = bits s in
+    let v = r mod n in
+    if r - v > 0x3FFFFFFF - n + 1 then intaux s n else v
+
+  let int s bound =
+    if bound > 0x3FFFFFFF || bound <= 0
+    then invalid_arg "Random.int"
+    else intaux s bound
+
+
+  let rec int32aux s n =
+    let b1 = Int32.of_int (bits s) in
+    let b2 = Int32.shift_left (Int32.of_int (bits s land 1)) 30 in
+    let r = Int32.logor b1 b2 in
+    let v = Int32.rem r n in
+    if Int32.sub r v > Int32.add (Int32.sub Int32.max_int n) 1l
+    then int32aux s n
+    else v
+
+  let int32 s bound =
+    if bound <= 0l
+    then invalid_arg "Random.int32"
+    else int32aux s bound
+
+
+  let rec int64aux s n =
+    let b1 = Int64.of_int (bits s) in
+    let b2 = Int64.shift_left (Int64.of_int (bits s)) 30 in
+    let b3 = Int64.shift_left (Int64.of_int (bits s land 7)) 60 in
+    let r = Int64.logor b1 (Int64.logor b2 b3) in
+    let v = Int64.rem r n in
+    if Int64.sub r v > Int64.add (Int64.sub Int64.max_int n) 1L
+    then int64aux s n
+    else v
+
+  let int64 s bound =
+    if bound <= 0L
+    then invalid_arg "Random.int64"
+    else int64aux s bound
+
+
+  (* Returns a float 0 <= x <= 1 with at most 60 bits of precision. *)
+  let rawfloat s =
+    let scale = 1073741824.0  (* 2^30 *)
+    and r1 = Pervasives.float (bits s)
+    and r2 = Pervasives.float (bits s)
+    in (r1 /. scale +. r2) /. scale
+
+
+  let float s bound = rawfloat s *. bound
+
+  let bool s = (bits s land 1 = 0)
+
+end
+
+(* This is the state you get with [init 27182818] and then applying
+   the "land 0x3FFFFFFF" filter to them.  See #5575, #5793, #5977. *)
+let default = {
+  State.st = [|
+      0x3ae2522b; 0x1d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x3b086c47;
+      0x16d467d6; 0x101d91c7; 0x321df177; 0x0176c193; 0x1ff72bf1; 0x1e889109;
+      0x0b464b18; 0x2b86b97c; 0x0891da48; 0x03137463; 0x085ac5a1; 0x15d61f2f;
+      0x3bced359; 0x29c1c132; 0x3a86766e; 0x366d8c86; 0x1f5b6222; 0x3ce1b59f;
+      0x2ebf78e1; 0x27cd1b86; 0x258f3dc3; 0x389a8194; 0x02e4c44c; 0x18c43f7d;
+      0x0f6e534f; 0x1e7df359; 0x055d0b7e; 0x10e84e7e; 0x126198e4; 0x0e7722cb;
+      0x1cbede28; 0x3391b964; 0x3d40e92a; 0x0c59933d; 0x0b8cd0b7; 0x24efff1c;
+      0x2803fdaa; 0x08ebc72e; 0x0f522e32; 0x05398edc; 0x2144a04c; 0x0aef3cbd;
+      0x01ad4719; 0x35b93cd6; 0x2a559d4f; 0x1e6fd768; 0x26e27f36; 0x186f18c3;
+      0x2fbf967a;
+    |];
+  State.idx = 0;
+}
+
+let bits () = State.bits default
+let int bound = State.int default bound
+let int32 bound = State.int32 default bound
+
+let int64 bound = State.int64 default bound
+let float scale = State.float default scale
+let bool () = State.bool default
+
+let full_init seed = State.full_init default seed
+let init seed = State.full_init default [| seed |]
+let self_init () = full_init (random_seed())
+
+(* Manipulating the current state. *)
+
+let get_state () = State.copy default
+let set_state s = State.assign default s
+
+(********************
+
+(* Test functions.  Not included in the library.
+   The [chisquare] function should be called with n > 10r.
+   It returns a triple (low, actual, high).
+   If low <= actual <= high, the [g] function passed the test,
+   otherwise it failed.
+
+  Some results:
+
+init 27182818; chisquare int 100000 1000
+init 27182818; chisquare int 100000 100
+init 27182818; chisquare int 100000 5000
+init 27182818; chisquare int 1000000 1000
+init 27182818; chisquare int 100000 1024
+init 299792643; chisquare int 100000 1024
+init 14142136; chisquare int 100000 1024
+init 27182818; init_diff 1024; chisquare diff 100000 1024
+init 27182818; init_diff 100; chisquare diff 100000 100
+init 27182818; init_diff2 1024; chisquare diff2 100000 1024
+init 27182818; init_diff2 100; chisquare diff2 100000 100
+init 14142136; init_diff2 100; chisquare diff2 100000 100
+init 299792643; init_diff2 100; chisquare diff2 100000 100
+- : float * float * float = (936.754446796632465, 997.5, 1063.24555320336754)
+# - : float * float * float = (80., 89.7400000000052387, 120.)
+# - : float * float * float = (4858.57864376269, 5045.5, 5141.42135623731)
+# - : float * float * float =
+(936.754446796632465, 944.805999999982305, 1063.24555320336754)
+# - : float * float * float = (960., 1019.19744000000355, 1088.)
+# - : float * float * float = (960., 1059.31776000000536, 1088.)
+# - : float * float * float = (960., 1039.98463999999512, 1088.)
+# - : float * float * float = (960., 1054.38207999999577, 1088.)
+# - : float * float * float = (80., 90.096000000005, 120.)
+# - : float * float * float = (960., 1076.78720000000612, 1088.)
+# - : float * float * float = (80., 85.1760000000067521, 120.)
+# - : float * float * float = (80., 85.2160000000003492, 120.)
+# - : float * float * float = (80., 80.6220000000030268, 120.)
+
+*)
+
+(* Return the sum of the squares of v[i0,i1[ *)
+let rec sumsq v i0 i1 =
+  if i0 >= i1 then 0.0
+  else if i1 = i0 + 1 then Pervasives.float v.(i0) *. Pervasives.float v.(i0)
+  else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1
+
+
+let chisquare g n r =
+  if n <= 10 * r then invalid_arg "chisquare";
+  let f = Array.make r 0 in
+  for i = 1 to n do
+    let t = g r in
+    f.(t) <- f.(t) + 1
+  done;
+  let t = sumsq f 0 r
+  and r = Pervasives.float r
+  and n = Pervasives.float n in
+  let sr = 2.0 *. sqrt r in
+  (r -. sr,   (r *. t /. n) -. n,   r +. sr)
+
+
+(* This is to test for linear dependencies between successive random numbers.
+*)
+let st = ref 0
+let init_diff r = st := int r
+let diff r =
+  let x1 = !st
+  and x2 = int r
+  in
+  st := x2;
+  if x1 >= x2 then
+    x1 - x2
+  else
+    r + x1 - x2
+
+
+let st1 = ref 0
+and st2 = ref 0
+
+
+(* This is to test for quadratic dependencies between successive random
+   numbers.
+*)
+let init_diff2 r = st1 := int r; st2 := int r
+let diff2 r =
+  let x1 = !st1
+  and x2 = !st2
+  and x3 = int r
+  in
+  st1 := x2;
+  st2 := x3;
+  (x3 - x2 - x2 + x1 + 2*r) mod r
+
+
+********************)