Passage a la version bootstrappee (franchissement du Rubicon)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 273 insertions, 0 deletions

diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
new file mode 100644
index 0000000000..bc10141586
--- /dev/null
+++ b/stdlib/pervasives.ml
@@ -0,0 +1,273 @@
+(* 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 = "neg_float"
+external (+.) : float -> float -> float = "add_float"
+external (-.) : float -> float -> float = "sub_float"
+external ( *. ) : float -> float -> float = "mul_float"
+external (/.) : float -> float -> float = "div_float"
+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 = "float_of_int"
+external truncate : float -> int = "int_of_float"
+
+(* 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 *)
+
+open Sys
+
+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