ocaml/stdlib/pervasives.ml

279 lines
8.5 KiB
OCaml

(* Exceptions *)
external raise : exn -> 'a = "%raise"
let failwith s = raise(Failure s)
let invalid_arg s = raise(Invalid_argument s)
exception Exit
(* 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"
let min x y = if x <= y then x else y
let max x y = if x >= y then x else y
external (==) : 'a -> 'a -> bool = "%eq"
external (!=) : 'a -> 'a -> bool = "%noteq"
(* Boolean operations *)
external not : bool -> bool = "%boolnot"
external (&) : bool -> bool -> bool = "%sequand"
external (or) : bool -> bool -> bool = "%sequor"
(* Integer operations *)
external (~-) : int -> int = "%negint"
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"
(* Floating-point operations *)
external (~-.) : float -> float = "%negfloat"
external (+.) : float -> float -> float = "%addfloat"
external (-.) : float -> float -> float = "%subfloat"
external ( *. ) : float -> float -> float = "%mulfloat"
external (/.) : float -> float -> float = "%divfloat"
external ( ** ) : float -> float -> float = "power_float"
external exp : float -> float = "exp_float"
external log : float -> float = "log_float"
external sqrt : float -> float = "sqrt_float"
external sin : float -> float = "sin_float"
external cos : float -> float = "cos_float"
external tan : float -> float = "tan_float"
external asin : float -> float = "asin_float"
external acos : float -> float = "acos_float"
external atan : float -> float = "atan_float"
external atan2 : float -> float -> float = "atan2_float"
let abs_float f = if f >= 0.0 then f else -. f
external float : int -> float = "%floatofint"
external truncate : float -> int = "%intoffloat"
(* String operations -- more in module String *)
external string_length : string -> int = "ml_string_length"
external string_create: int -> string = "create_string"
external string_blit : string -> int -> string -> int -> int -> unit
= "blit_string"
let (^) s1 s2 =
let l1 = string_length s1 and l2 = string_length s2 in
let s = string_create (l1 + l2) in
string_blit s1 0 s 0 l1;
string_blit s2 0 s l1 l2;
s
(* Pair operations *)
external fst : 'a * 'b -> 'a = "%field0"
external snd : 'a * 'b -> 'b = "%field1"
(* String conversion functions *)
external format_int: string -> int -> string = "format_int"
external format_float: string -> float -> string = "format_float"
let string_of_bool b =
if b then "true" else "false"
let string_of_int n =
format_int "%d" n
external int_of_string : string -> int = "int_of_string"
let string_of_float f =
format_float "%.12g" f
external float_of_string : string -> float = "float_of_string"
(* List operations -- more in module List *)
let rec (@) l1 l2 =
match l1 with
[] -> l2
| hd :: tl -> hd :: (tl @ l2)
(* I/O operations *)
type in_channel
type out_channel
external open_descriptor_out: int -> out_channel = "open_descriptor"
external open_descriptor_in: int -> in_channel = "open_descriptor"
let stdin = open_descriptor_in 0
let stdout = open_descriptor_out 1
let stderr = open_descriptor_out 2
(* General output functions *)
type open_flag =
Open_rdonly | Open_wronly | Open_rdwr
| Open_append | Open_creat | Open_trunc | Open_excl
| Open_binary | Open_text
external open_desc: string -> open_flag list -> int -> int = "sys_open"
let open_out_gen mode perm name =
open_descriptor_out(open_desc name mode perm)
let open_out name =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
let open_out_bin name =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
external flush : out_channel -> unit = "flush"
external unsafe_output : out_channel -> string -> int -> int -> unit = "output"
external output_char : out_channel -> char -> unit = "output_char"
let output_string oc s =
unsafe_output oc s 0 (string_length s)
let output oc s ofs len =
if ofs < 0 or ofs + len > string_length s
then invalid_arg "output"
else unsafe_output oc s ofs len
external output_byte : out_channel -> int -> unit = "output_char"
external output_binary_int : out_channel -> int -> unit = "output_int"
external output_value : out_channel -> 'a -> unit = "output_value"
external output_compact_value : out_channel -> 'a -> unit = "output_value"
external seek_out : out_channel -> int -> unit = "seek_out"
external pos_out : out_channel -> int = "pos_out"
external size_out : out_channel -> int = "channel_size"
external close_out : out_channel -> unit = "close_out"
(* General input functions *)
let open_in_gen mode perm name =
open_descriptor_in(open_desc name mode perm)
let open_in name =
open_in_gen [Open_rdonly; Open_text] 0 name
let open_in_bin name =
open_in_gen [Open_rdonly; Open_binary] 0 name
external input_char : in_channel -> char = "input_char"
external unsafe_input : in_channel -> string -> int -> int -> int = "input"
let input ic s ofs len =
if ofs < 0 or ofs + len > string_length s
then invalid_arg "input"
else unsafe_input ic s ofs len
let rec unsafe_really_input ic s ofs len =
if len <= 0 then () else begin
let r = unsafe_input ic s ofs len in
if r = 0
then raise End_of_file
else unsafe_really_input ic s (ofs+r) (len-r)
end
let really_input ic s ofs len =
if ofs < 0 or ofs + len > string_length s
then invalid_arg "really_input"
else unsafe_really_input ic s ofs len
external input_scan_line : in_channel -> int = "input_scan_line"
let rec input_line chan =
let n = input_scan_line chan in
if n = 0 then (* n = 0: we are at EOF *)
raise End_of_file
else if n > 0 then begin (* n > 0: newline found in buffer *)
let res = string_create (n-1) in
unsafe_input chan res 0 (n-1);
input_char chan; (* skip the newline *)
res
end else begin (* n < 0: newline not found *)
let beg = string_create (-n) in
unsafe_input chan beg 0 (-n);
try
beg ^ input_line chan
with End_of_file ->
beg
end
external input_byte : in_channel -> int = "input_char"
external input_binary_int : in_channel -> int = "input_int"
external input_value : in_channel -> 'a = "input_value"
external seek_in : in_channel -> int -> unit = "seek_in"
external pos_in : in_channel -> int = "pos_in"
external in_channel_length : in_channel -> int = "channel_size"
external close_in : in_channel -> unit = "close_in"
(* Output functions on standard output *)
let print_char c = output_char stdout c
let print_string s = output_string stdout s
let print_int i = output_string stdout (string_of_int i)
let print_float f = output_string stdout (string_of_float f)
let print_endline s = output_string stdout s; output_char stdout '\n'
let print_newline () = output_char stdout '\n'; flush stdout
(* Output functions on standard error *)
let prerr_char c = output_char stderr c
let prerr_string s = output_string stderr s
let prerr_int i = output_string stderr (string_of_int i)
let prerr_float f = output_string stderr (string_of_float f)
let prerr_endline s =
output_string stderr s; output_char stderr '\n'; flush stderr
let prerr_newline () = output_char stderr '\n'; flush stderr
(* Input functions on standard input *)
let read_line () = flush stdout; input_line stdin
let read_int () = int_of_string(read_line())
let read_float () = float_of_string(read_line())
(* References *)
type 'a ref = { mutable contents: 'a }
external ref: 'a -> 'a ref = "%makeblock"
external (!): 'a ref -> 'a = "%field0"
external (:=): 'a ref -> 'a -> unit = "%setfield0"
external incr: int ref -> unit = "%incr"
external decr: int ref -> unit = "%decr"
(* Miscellaneous *)
external sys_exit : int -> 'a = "sys_exit"
let exit retcode =
flush stdout; flush stderr; sys_exit retcode
type 'a option = None | Some of 'a