pervasives.ml

(**************************************************************************)
(*                                                                        *)
(*                                 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.          *)
(*                                                                        *)
(**************************************************************************)

(* type 'a option = None | Some of 'a *)

(* Internal *)
external __unsafe_cast : 'a -> 'b = "%identity"

(* Exceptions *)

external raise : exn -> 'a = "%raise"
external raise_notrace : exn -> 'a = "%raise_notrace"

let failwith s = raise(Failure s)
let invalid_arg s = raise(Invalid_argument s)

exception Exit

(* Composition operators *)

external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"

(* Debugging *)

external __LOC__ : string = "%loc_LOC"
external __FILE__ : string = "%loc_FILE"
external __LINE__ : int = "%loc_LINE"
external __MODULE__ : string = "%loc_MODULE"
external __POS__ : string * int * int * int = "%loc_POS"

external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"

(* Comparisons *)

external ( = ) : 'a -> 'a -> bool = "%equal"
external ( <> ) : 'a -> 'a -> bool = "%notequal"
external ( < ) : 'a -> 'a -> bool = "%lessthan"
external ( > ) : 'a -> 'a -> bool = "%greaterthan"
external ( <= ) : 'a -> 'a -> bool = "%lessequal"
external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
external compare : 'a -> 'a -> int = "%compare"
external min : 'a -> 'a -> 'a = "%bs_min"
external max : 'a -> 'a -> 'a = "%bs_max"
external ( == ) : 'a -> 'a -> bool = "%eq"
external ( != ) : 'a -> 'a -> bool = "%noteq"

(* Boolean operations *)

external not : bool -> bool = "%boolnot"

external ( && ) : bool -> bool -> bool = "%sequand"

external ( || ) : bool -> bool -> bool = "%sequor"

(* Integer operations *)

external ( ~- ) : int -> int = "%negint"
external ( ~+ ) : int -> int = "%identity"
external succ : int -> int = "%succint"
external pred : int -> int = "%predint"
external ( + ) : int -> int -> int = "%addint"
external ( - ) : int -> int -> int = "%subint"
external ( * ) : int -> int -> int = "%mulint"
external ( / ) : int -> int -> int = "%divint"
external ( mod ) : int -> int -> int = "%modint"

let abs x = if x >= 0 then x else -x

external ( land ) : int -> int -> int = "%andint"
external ( lor ) : int -> int -> int = "%orint"
external ( lxor ) : int -> int -> int = "%xorint"

let lnot x = x lxor (-1)

external ( lsl ) : int -> int -> int = "%lslint"
external ( lsr ) : int -> int -> int = "%lsrint"
external ( asr ) : int -> int -> int = "%asrint"

let max_int = (-1) lsr 1
let min_int = max_int + 1

(* Floating-point operations *)

external ( ~-. ) : float -> float = "%negfloat"
external ( ~+. ) : float -> float = "%identity"
external ( +. ) : float -> float -> float = "%addfloat"
external ( -. ) : float -> float -> float = "%subfloat"
external ( *. ) : float -> float -> float = "%mulfloat"
external ( /. ) : float -> float -> float = "%divfloat"

external ( ** ) : float -> float -> float = "pow" [@@bs.val] [@@bs.scope "Math"]
external exp : float -> float = "exp" [@@bs.val][@@bs.scope "Math"]
external expm1 : float -> float = "?expm1_float" 

external acos : float -> float =  "acos" [@@bs.val] [@@bs.scope "Math"]
external asin : float -> float = "asin" [@@bs.val] [@@bs.scope "Math"]
external atan : float -> float = "atan" [@@bs.val] [@@bs.scope "Math"]
external atan2 : float -> float -> float = "atan2" [@@bs.val] [@@bs.scope "Math"]
external hypot : float -> float -> float
               = "?hypot_float"

external cos : float -> float = "cos" [@@bs.val] [@@bs.scope "Math"]
external cosh : float -> float = "cosh" [@@bs.val] [@@bs.scope "Math"]
external log : float -> float =  "log" [@@bs.val] [@@bs.scope "Math"]
external log10 : float -> float = "log10"[@@bs.val] [@@bs.scope "Math"]
external log1p : float -> float = "log1p" [@@bs.val] [@@bs.scope "Math"]
external sin : float -> float =  "sin" [@@bs.val] [@@bs.scope "Math"]
external sinh : float -> float = "sinh" [@@bs.val] [@@bs.scope "Math"]
external sqrt : float -> float =  "sqrt" [@@bs.val] [@@bs.scope "Math"]
external tan : float -> float =  "tan" [@@bs.val] [@@bs.scope "Math"]
external tanh : float -> float =  "tanh" [@@bs.val] [@@bs.scope "Math"]
external ceil : float -> float =  "ceil" [@@bs.val] [@@bs.scope "Math"]
external floor : float -> float =  "floor" [@@bs.val] [@@bs.scope "Math"]
external abs_float : float -> float = "abs"[@@bs.val] [@@bs.scope "Math"]
external copysign : float -> float -> float
                  = "?copysign_float"
external mod_float : float -> float -> float = "?fmod_float"
external frexp : float -> float * int = "?frexp_float"
external ldexp : float -> int -> float  =
  "?ldexp_float" 
external modf : float -> float * float = "?modf_float"
external float : int -> float = "%floatofint"
external float_of_int : int -> float = "%floatofint"
external truncate : float -> int = "%intoffloat"
external int_of_float : float -> int = "%intoffloat"


let infinity = 0x1p2047
let neg_infinity = -0x1p2047
external nan : float = "NaN"
[@@bs.val]  [@@bs.scope "Number"]
let max_float = 1.79769313486231571e+308 (*0x1.ffff_ffff_ffff_fp+1023*)
let min_float = 2.22507385850720138e-308 (* 0x1p-1022 *)
let epsilon_float = 2.22044604925031308e-16 (* 0x1p-52 *)



type fpclass =
    FP_normal
  | FP_subnormal
  | FP_zero
  | FP_infinite
  | FP_nan

let classify_float (x : float) : fpclass =   
  if ([%raw{|isFinite|}] : _ -> _ [@bs]) x [@bs] then
    if abs_float x >= (* 0x1p-1022 *) (* 2.22507385850720138e-308*) min_float  then
      FP_normal
    else if x <> 0. then FP_subnormal
    else FP_zero
  else
  if ([%raw{|isNaN|}] : _ -> _ [@bs])  x [@bs] then
    FP_nan
  else FP_infinite  

(* String and byte sequence operations -- more in modules String and Bytes *)

external string_length : string -> int = "%string_length"


external (^) : string -> string -> string = "#string_append"
(* Character operations -- more in module Char *)

external int_of_char : char -> int = "%identity"
external unsafe_char_of_int : int -> char = "%identity"
let char_of_int n =
  if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n

(* Unit operations *)

external ignore : 'a -> unit = "%ignore"

(* Pair operations *)

external fst : 'a * 'b -> 'a = "%field0"
external snd : 'a * 'b -> 'b = "%field1"

(* References *)

type 'a ref = { mutable contents : 'a }
external ref : 'a -> 'a ref = "%makemutable"
external ( ! ) : 'a ref -> 'a = "%bs_ref_field0"
external ( := ) : 'a ref -> 'a -> unit = "%bs_ref_setfield0"
external incr : int ref -> unit = "%incr"
external decr : int ref -> unit = "%decr"

(* Result type *)

type ('a, 'b) result = ('a, 'b) Belt.Result.t =
  | Ok of 'a
  | Error of 'b

(* String conversion functions *)
external format_float : string -> float -> string = "?format_float"

let string_of_bool b =
  if b then "true" else "false"
let bool_of_string = function
  | "true" -> true
  | "false" -> false
  | _ -> invalid_arg "bool_of_string"

let bool_of_string_opt = function
  | "true" -> Some true
  | "false" -> Some false
  | _ -> None


external string_of_int : int -> string = "String" [@@bs.val]

external int_of_string : string -> int = "?int_of_string"

let int_of_string_opt s =
  (* TODO: provide this directly as a non-raising primitive. *)
  try Some (int_of_string s)
  with Failure _ -> None

external string_get : string -> int -> char = "%string_safe_get"

let valid_float_lexem s =
  let l = string_length s in
  let rec loop i =
    if i >= l then s ^ "." else
    match string_get s i with
    | '0' .. '9' | '-' -> loop (i + 1)
    | _ -> s
  in
  loop 0

let string_of_float f = valid_float_lexem (format_float "%.12g" f)

external float_of_string : string -> float = "?float_of_string"

let float_of_string_opt s =
  (* TODO: provide this directly as a non-raising primitive. *)
  try Some (float_of_string s)
  with Failure _ -> None

(* List operations -- more in module List *)

let rec ( @ ) l1 l2 =
  match l1 with
    [] -> l2
  | hd :: tl -> hd :: (tl @ l2)



(* Output functions on standard output *)


external print_endline : string -> unit = "log" 
[@@bs.val] [@@bs.scope "console"]
let print_newline () = print_endline ""

(* Output functions on standard error *)


external prerr_endline : string -> unit = "error" 
[@@bs.val] [@@bs.scope "console"]    
let prerr_newline () = prerr_endline ""

let print_int (i : int) = print_endline (string_of_int i) 
let print_float (i : float) = print_endline (string_of_float i)
let print_string = print_endline

(* Miscellaneous *)

external sys_exit : int -> 'a = "?sys_exit"

let exit_function = ref ignore

let at_exit f =
  let g = !exit_function in
  exit_function := (fun () -> f(); g())

let do_at_exit () = (!exit_function) ()

let exit retcode =
  do_at_exit ();
  sys_exit retcode

type int32 = int