(* * Std - Additional functions * Copyright (C) 2003 Nicolas Cannasse and Markus Mottl * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open ExtBytes let finally handler f x = let r = ( try f x with e -> handler (); raise e ) in handler (); r let input_lines ch = Enum.from (fun () -> try input_line ch with End_of_file -> raise Enum.No_more_elements) let input_chars ch = Enum.from (fun () -> try input_char ch with End_of_file -> raise Enum.No_more_elements) type 'a _mut_list = { hd : 'a; mutable tl : 'a _mut_list; } let input_list ch = let _empty = Obj.magic [] in let rec loop dst = let r = { hd = input_line ch; tl = _empty } in dst.tl <- r; loop r in let r = { hd = Obj.magic(); tl = _empty } in try loop r with End_of_file -> Obj.magic r.tl let buf_len = 8192 let input_all ic = let rec loop acc total buf ofs = let n = input ic buf ofs (buf_len - ofs) in if n = 0 then let res = Bytes.create total in let pos = total - ofs in let _ = Bytes.blit buf 0 res pos ofs in let coll pos buf = let new_pos = pos - buf_len in Bytes.blit buf 0 res new_pos buf_len; new_pos in let _ = List.fold_left coll pos acc in (* [res] doesn't escape and will not be mutated again *) Bytes.unsafe_to_string res else let new_ofs = ofs + n in let new_total = total + n in if new_ofs = buf_len then loop (buf :: acc) new_total (Bytes.create buf_len) 0 else loop acc new_total buf new_ofs in loop [] 0 (Bytes.create buf_len) 0 let input_file ?(bin=false) fname = let ch = (if bin then open_in_bin else open_in) fname in finally (fun () -> close_in ch) input_all ch let output_file ~filename ~text = let ch = open_out filename in finally (fun () -> close_out ch) (output_string ch) text let print_bool = function | true -> print_string "true" | false -> print_string "false" let prerr_bool = function | true -> prerr_string "true" | false -> prerr_string "false" let string_of_char c = String.make 1 c external identity : 'a -> 'a = "%identity" let rec dump r = if Obj.is_int r then string_of_int (Obj.magic r : int) else (* Block. *) let rec get_fields acc = function | 0 -> acc | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n in let rec is_list r = if Obj.is_int r then r = Obj.repr 0 (* [] *) else let s = Obj.size r and t = Obj.tag r in t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) in let rec get_list r = if Obj.is_int r then [] else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in h :: t in let opaque name = (* XXX In future, print the address of value 'r'. Not possible in * pure OCaml at the moment. *) "<" ^ name ^ ">" in let s = Obj.size r and t = Obj.tag r in (* From the tag, determine the type of block. *) match t with | _ when is_list r -> let fields = get_list r in "[" ^ String.concat "; " (List.map dump fields) ^ "]" | 0 -> let fields = get_fields [] s in "(" ^ String.concat ", " (List.map dump fields) ^ ")" | x when x = Obj.lazy_tag -> (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not * clear if very large constructed values could have the same * tag. XXX *) opaque "lazy" | x when x = Obj.closure_tag -> opaque "closure" | x when x = Obj.object_tag -> let fields = get_fields [] s in let clasz, id, slots = match fields with | h::h'::t -> h, h', t | _ -> assert false in (* No information on decoding the class (first field). So just print * out the ID and the slots. *) "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")" | x when x = Obj.infix_tag -> opaque "infix" | x when x = Obj.forward_tag -> opaque "forward" | x when x < Obj.no_scan_tag -> let fields = get_fields [] s in "Tag" ^ string_of_int t ^ " (" ^ String.concat ", " (List.map dump fields) ^ ")" | x when x = Obj.string_tag -> "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" | x when x = Obj.double_tag -> string_of_float (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> opaque "custom" | x when x = Obj.double_array_tag -> let l = ExtList.List.init s (fun i -> string_of_float (Obj.double_field r i)) in "[| " ^ String.concat "; " l ^ " |]" | _ -> opaque (Printf.sprintf "unknown: tag %d size %d" t s) let dump v = dump (Obj.repr v) let print v = print_endline (dump v) let __unique_counter = ref 0 let unique () = incr __unique_counter; !__unique_counter