stdlib/pervasives.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (*   (C) Flying Frog Consultancy Ltd., 2006                            *)
  13 (* portions lifted from Extlib                                         *)
  14 (* Copyright (C) 2003 Brian Hurt                                       *)
  15 (* Copyright (C) 2003 Nicolas Cannasse                                 *)
  16 (***********************************************************************)
  17
  18 (* $Id$ *)
  19
  20 (* type 'a option = None | Some of 'a *)
  21
  22 (* Exceptions *)
  23
  24 external raise : exn -> 'a = "%raise"
  25
  26 let failwith s = raise(Failure s)
  27 let invalid_arg s = raise(Invalid_argument s)
  28
  29 let finally handler f x =
  30   let r = ( try f x with e -> handler(); raise e ) in
  31   handler(); r
  32
  33
  34 exception Exit
  35
  36 (* Comparisons *)
  37
  38 external (=) : 'a -> 'a -> bool = "%equal"
  39 external (<>) : 'a -> 'a -> bool = "%notequal"
  40 external (<) : 'a -> 'a -> bool = "%lessthan"
  41 external (>) : 'a -> 'a -> bool = "%greaterthan"
  42 external (<=) : 'a -> 'a -> bool = "%lessequal"
  43 external (>=) : 'a -> 'a -> bool = "%greaterequal"
  44 external compare: 'a -> 'a -> int = "%compare"
  45
  46 let min x y = if x <= y then x else y
  47 let max x y = if x >= y then x else y
  48
  49 external (==) : 'a -> 'a -> bool = "%eq"
  50 external (!=) : 'a -> 'a -> bool = "%noteq"
  51
  52 (* Boolean operations *)
  53
  54 external not : bool -> bool = "%boolnot"
  55 external (&) : bool -> bool -> bool = "%sequand"
  56 external (&&) : bool -> bool -> bool = "%sequand"
  57 external (or) : bool -> bool -> bool = "%sequor"
  58 external (||) : bool -> bool -> bool = "%sequor"
  59
  60 (* Integer operations *)
  61
  62 external (~-) : int -> int = "%negint"
  63 external succ : int -> int = "%succint"
  64 external pred : int -> int = "%predint"
  65 external (+) : int -> int -> int = "%addint"
  66 external (-) : int -> int -> int = "%subint"
  67 external ( * ) : int -> int -> int = "%mulint"
  68 external (/) : int -> int -> int = "%divint"
  69 external (mod) : int -> int -> int = "%modint"
  70
  71 let abs x = if x >= 0 then x else -x
  72
  73 external (land) : int -> int -> int = "%andint"
  74 external (lor) : int -> int -> int = "%orint"
  75 external (lxor) : int -> int -> int = "%xorint"
  76
  77 let lnot x = x lxor (-1)
  78
  79 external (lsl) : int -> int -> int = "%lslint"
  80 external (lsr) : int -> int -> int = "%lsrint"
  81 external (asr) : int -> int -> int = "%asrint"
  82
  83 let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62)
  84 let max_int = min_int - 1
  85
  86 (* Floating-point operations *)
  87
  88 external (~-.) : float -> float = "%negfloat"
  89 external (+.) : float -> float -> float = "%addfloat"
  90 external (-.) : float -> float -> float = "%subfloat"
  91 external ( *. ) : float -> float -> float = "%mulfloat"
  92 external (/.) : float -> float -> float = "%divfloat"
  93 external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
  94 external exp : float -> float = "caml_exp_float" "exp" "float"
  95 external acos : float -> float = "caml_acos_float" "acos" "float"
  96 external asin : float -> float = "caml_asin_float" "asin" "float"
  97 external atan : float -> float = "caml_atan_float" "atan" "float"
  98 external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
  99 external cos : float -> float = "caml_cos_float" "cos" "float"
 100 external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 101 external log : float -> float = "caml_log_float" "log" "float"
 102 external log10 : float -> float = "caml_log10_float" "log10" "float"
 103 external sin : float -> float = "caml_sin_float" "sin" "float"
 104 external sinh : float -> float = "caml_sinh_float" "sinh" "float"
 105 external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
 106 external tan : float -> float = "caml_tan_float" "tan" "float"
 107 external tanh : float -> float = "caml_tanh_float" "tanh" "float"
 108 external ceil : float -> float = "caml_ceil_float" "ceil" "float"
 109 external floor : float -> float = "caml_floor_float" "floor" "float"
 110 external abs_float : float -> float = "%absfloat"
 111 external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
 112 external frexp : float -> float * int = "caml_frexp_float"
 113 external ldexp : float -> int -> float = "caml_ldexp_float"
 114 external modf : float -> float * float = "caml_modf_float"
 115 external float : int -> float = "%floatofint"
 116 external float_of_int : int -> float = "%floatofint"
 117 external truncate : float -> int = "%intoffloat"
 118 external int_of_float : float -> int = "%intoffloat"
 119 external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
 120 let infinity =
 121   float_of_bits 0x7F_F0_00_00_00_00_00_00L
 122 let neg_infinity =
 123   float_of_bits 0xFF_F0_00_00_00_00_00_00L
 124 let nan =
 125   float_of_bits 0x7F_F0_00_00_00_00_00_01L
 126 let max_float =
 127   float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
 128 let min_float =
 129   float_of_bits 0x00_10_00_00_00_00_00_00L
 130 let epsilon_float =
 131   float_of_bits 0x3C_B0_00_00_00_00_00_00L
 132 let pi = 4. *. atan 1.
 133
 134 type fpclass =
 135     FP_normal
 136   | FP_subnormal
 137   | FP_zero
 138   | FP_infinite
 139   | FP_nan
 140 external classify_float: float -> fpclass = "caml_classify_float"
 141
 142 (* String operations -- more in module String *)
 143
 144 external string_length : string -> int = "%string_length"
 145 external string_create: int -> string = "caml_create_string"
 146 external string_blit : string -> int -> string -> int -> int -> unit
 147                      = "caml_blit_string" "noalloc"
 148
 149 let (^) s1 s2 =
 150   let l1 = string_length s1 and l2 = string_length s2 in
 151   let s = string_create (l1 + l2) in
 152   string_blit s1 0 s 0 l1;
 153   string_blit s2 0 s l1 l2;
 154   s
 155
 156 (* Character operations -- more in module Char *)
 157
 158 external int_of_char : char -> int = "%identity"
 159 external unsafe_char_of_int : int -> char = "%identity"
 160 let char_of_int n =
 161   if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
 162
 163 (* Unit operations *)
 164
 165 external ignore : 'a -> unit = "%ignore"
 166
 167 (* Pair operations *)
 168
 169 external fst : 'a * 'b -> 'a = "%field0"
 170 external snd : 'a * 'b -> 'b = "%field1"
 171
 172 (* String conversion functions *)
 173
 174 external format_int: string -> int -> string = "caml_format_int"
 175 external format_float: string -> float -> string = "caml_format_float"
 176
 177 let string_of_bool b =
 178   if b then "true" else "false"
 179 let bool_of_string = function
 180   | "true" -> true
 181   | "false" -> false
 182   | _ -> invalid_arg "bool_of_string"
 183
 184 let string_of_int n =
 185   format_int "%d" n
 186
 187 external int_of_string : string -> int = "caml_int_of_string"
 188
 189 module String = struct
 190   external get : string -> int -> char = "%string_safe_get"
 191 end
 192
 193 let valid_float_lexem s =
 194   let l = string_length s in
 195   let rec loop i =
 196     if i >= l then s ^ "." else
 197     match s.[i] with
 198     | '0' .. '9' | '-' -> loop (i+1)
 199     | _ -> s
 200   in
 201   loop 0
 202 ;;
 203
 204 let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
 205
 206 external float_of_string : string -> float = "caml_float_of_string"
 207
 208 (* List operations -- more in module List *)
 209
 210 let rec (@) l1 l2 =
 211   match l1 with
 212     [] -> l2
 213   | hd :: tl -> hd :: (tl @ l2)
 214
 215 (* I/O operations *)
 216
 217 type in_channel
 218 type out_channel
 219
 220 external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out"
 221 external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in"
 222
 223 let stdin = open_descriptor_in 0
 224 let stdout = open_descriptor_out 1
 225 let stderr = open_descriptor_out 2
 226
 227 (* General output functions *)
 228
 229 type open_flag =
 230     Open_rdonly | Open_wronly | Open_append
 231   | Open_creat | Open_trunc | Open_excl
 232   | Open_binary | Open_text | Open_nonblock
 233
 234 external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 235
 236 let open_out_gen mode perm name =
 237   open_descriptor_out(open_desc name mode perm)
 238
 239 let open_out name =
 240   open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
 241
 242 let open_out_bin name =
 243   open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
 244
 245 external flush : out_channel -> unit = "caml_ml_flush"
 246
 247 external out_channels_list : unit -> out_channel list
 248                            = "caml_ml_out_channels_list"
 249
 250 let flush_all () =
 251   let rec iter = function
 252       [] -> ()
 253     | a::l -> (try flush a with _ -> ()); iter l
 254   in iter (out_channels_list ())
 255
 256 external unsafe_output : out_channel -> string -> int -> int -> unit
 257                        = "caml_ml_output"
 258
 259 external output_char : out_channel -> char -> unit = "caml_ml_output_char"
 260
 261 let output_string oc s =
 262   unsafe_output oc s 0 (string_length s)
 263
 264 let output oc s ofs len =
 265   if ofs < 0 || len < 0 || ofs > string_length s - len
 266   then invalid_arg "output"
 267   else unsafe_output oc s ofs len
 268
 269 external output_byte : out_channel -> int -> unit = "caml_ml_output_char"
 270 external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int"
 271
 272 external marshal_to_channel : out_channel -> 'a -> unit list -> unit
 273      = "caml_output_value"
 274 let output_value chan v = marshal_to_channel chan v []
 275
 276 external seek_out : out_channel -> int -> unit = "caml_ml_seek_out"
 277 external pos_out : out_channel -> int = "caml_ml_pos_out"
 278 external out_channel_length : out_channel -> int = "caml_ml_channel_size"
 279 external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
 280 let close_out oc = flush oc; close_out_channel oc
 281 let close_out_noerr oc =
 282   (try flush oc with _ -> ());
 283   (try close_out_channel oc with _ -> ())
 284 external set_binary_mode_out : out_channel -> bool -> unit
 285                              = "caml_ml_set_binary_mode"
 286
 287 (* General input functions *)
 288
 289 let open_in_gen mode perm name =
 290   open_descriptor_in(open_desc name mode perm)
 291
 292 let open_in name =
 293   open_in_gen [Open_rdonly; Open_text] 0 name
 294
 295 let open_in_bin name =
 296   open_in_gen [Open_rdonly; Open_binary] 0 name
 297
 298 external input_char : in_channel -> char = "caml_ml_input_char"
 299
 300 external unsafe_input : in_channel -> string -> int -> int -> int
 301                       = "caml_ml_input"
 302
 303 let input ic s ofs len =
 304   if ofs < 0 || len < 0 || ofs > string_length s - len
 305   then invalid_arg "input"
 306   else unsafe_input ic s ofs len
 307
 308 let rec unsafe_really_input ic s ofs len =
 309   if len <= 0 then () else begin
 310     let r = unsafe_input ic s ofs len in
 311     if r = 0
 312     then raise End_of_file
 313     else unsafe_really_input ic s (ofs+r) (len-r)
 314   end
 315
 316 let really_input ic s ofs len =
 317   if ofs < 0 || len < 0 || ofs > string_length s - len
 318   then invalid_arg "really_input"
 319   else unsafe_really_input ic s ofs len
 320
 321 external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
 322
 323 let input_line chan =
 324   let rec build_result buf pos = function
 325     [] -> buf
 326   | hd :: tl ->
 327       let len = string_length hd in
 328       string_blit hd 0 buf (pos - len) len;
 329       build_result buf (pos - len) tl in
 330   let rec scan accu len =
 331     let n = input_scan_line chan in
 332     if n = 0 then begin                   (* n = 0: we are at EOF *)
 333       match accu with
 334         [] -> raise End_of_file
 335       | _  -> build_result (string_create len) len accu
 336     end else if n > 0 then begin          (* n > 0: newline found in buffer *)
 337       let res = string_create (n-1) in
 338       ignore (unsafe_input chan res 0 (n-1));
 339       ignore (input_char chan);           (* skip the newline *)
 340       match accu with
 341         [] -> res
 342       |  _ -> let len = len + n - 1 in
 343               build_result (string_create len) len (res :: accu)
 344     end else begin                        (* n < 0: newline not found *)
 345       let beg = string_create (-n) in
 346       ignore(unsafe_input chan beg 0 (-n));
 347       scan (beg :: accu) (len - n)
 348     end
 349   in scan [] 0
 350
 351 external input_byte : in_channel -> int = "caml_ml_input_char"
 352 external input_binary_int : in_channel -> int = "caml_ml_input_int"
 353 external input_value : in_channel -> 'a = "caml_input_value"
 354 external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
 355 external pos_in : in_channel -> int = "caml_ml_pos_in"
 356 external in_channel_length : in_channel -> int = "caml_ml_channel_size"
 357 external close_in : in_channel -> unit = "caml_ml_close_channel"
 358 let close_in_noerr ic = (try close_in ic with _ -> ());;
 359 external set_binary_mode_in : in_channel -> bool -> unit
 360                             = "caml_ml_set_binary_mode"
 361
 362 (* Output functions on standard output *)
 363
 364 let print_char c = output_char stdout c
 365 let print_string s = output_string stdout s
 366 let print_int i = output_string stdout (string_of_int i)
 367 let print_float f = output_string stdout (string_of_float f)
 368 let print_endline s =
 369   output_string stdout s; output_char stdout '\n'; flush stdout
 370 let print_newline () = output_char stdout '\n'; flush stdout
 371
 372 (* Output functions on standard error *)
 373
 374 let prerr_char c = output_char stderr c
 375 let prerr_string s = output_string stderr s
 376 let prerr_int i = output_string stderr (string_of_int i)
 377 let prerr_float f = output_string stderr (string_of_float f)
 378 let prerr_endline s =
 379   output_string stderr s; output_char stderr '\n'; flush stderr
 380 let prerr_newline () = output_char stderr '\n'; flush stderr
 381
 382 (* Input functions on standard input *)
 383
 384 let read_line () = flush stdout; input_line stdin
 385 let read_int () = int_of_string(read_line())
 386 let read_float () = float_of_string(read_line())
 387
 388 (* Operations on large files *)
 389
 390 module LargeFile =
 391   struct
 392     external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
 393     external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
 394     external out_channel_length : out_channel -> int64
 395                                 = "caml_ml_channel_size_64"
 396     external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
 397     external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
 398     external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
 399   end
 400
 401 (* References *)
 402
 403 type 'a ref = { mutable contents: 'a }
 404 external ref: 'a -> 'a ref = "%makemutable"
 405 external (!): 'a ref -> 'a = "%field0"
 406 external (:=): 'a ref -> 'a -> unit = "%setfield0"
 407 external incr: int ref -> unit = "%incr"
 408 external decr: int ref -> unit = "%decr"
 409
 410 (* Formats *)
 411 type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 412
 413 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 414
 415 external format_of_string :
 416  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
 417  ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
 418
 419 external format_to_string :
 420  ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity"
 421 external string_to_format :
 422  string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
 423
 424 let (( ^^ ) :
 425       ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
 426       ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
 427       ('a, 'b, 'c, 'd, 'g, 'h) format6) =
 428   fun fmt1 fmt2 ->
 429     string_to_format (format_to_string fmt1 ^ format_to_string fmt2);;
 430
 431 let string_of_format fmt =
 432   let s = format_to_string fmt in
 433   let l = string_length s in
 434   let r = string_create l in
 435   string_blit s 0 r 0 l;
 436   r
 437
 438 (* Miscellaneous *)
 439
 440 external sys_exit : int -> 'a = "caml_sys_exit"
 441
 442 let exit_function = ref flush_all
 443
 444 let at_exit f =
 445   let g = !exit_function in
 446   exit_function := (fun () -> f(); g())
 447
 448 let do_at_exit () = (!exit_function) ()
 449
 450 let exit retcode =
 451   do_at_exit ();
 452   sys_exit retcode
 453
 454 external register_named_value : string -> 'a -> unit
 455                               = "caml_register_named_value"
 456
 457 let _ = register_named_value "Pervasives.do_at_exit" do_at_exit