* this file.
*)
+(* don't the code below, use the Dumper module in ocamlextra instead.
(* start of dumper.ml *)
(* Dump an OCaml value into a printable string.
let dump v = dump (repr v)
(* end of dumper.ml *)
+*)
(*
let (dump : 'a -> string) = fun x ->
(* ---------------------------------------------------------------------- *)
-let pr2_gen x = pr2 (dump x)
+let pr2_gen x = pr2 (Dumper.dump x)
let pr2_once s = xxx_once pr2 s
+let clear_pr2_once _ = Hashtbl.clear _already_printed
+
(* ---------------------------------------------------------------------- *)
let mk_pr2_wrappers aref =
let fpr2 s =
let savein = Unix.dup Unix.stdin in
Unix.dup2 descr Unix.stdin;
- f();
+ let res = f() in
Unix.dup2 savein Unix.stdin;
close_in chan;
+ res
end
let redirect_stdin_opt optfile f =
let assert_equal a b =
if not (a = b)
then failwith ("assert_equal: those 2 values are not equal:\n\t" ^
- (dump a) ^ "\n\t" ^ (dump b) ^ "\n")
+ (Dumper.dump a) ^ "\n\t" ^ (Dumper.dump b) ^ "\n")
let (example2: string -> bool -> unit) = fun s b ->
try assert b with x -> failwith s
let c = open_out "/tmp/ttttt.ml" in
begin
output_string c s; close_out c;
- command2 ("ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' " ^
- "-I +camlp4 -impl macro.ml4");
- command2 "camlp4o ./macro.cmo pr_o.cmo /tmp/ttttt.ml";
- command2 "rm -f /tmp/ttttt.ml";
+ command2 (Commands.ocamlc_cmd ^ " -c -pp '" ^ Commands.camlp4o_cmd ^" pa_extend.cmo q_MLast.cmo -impl' " ^
+ "-I +" ^ Commands.camlp4_cmd ^ " -impl macro.ml4");
+ command2 (Commands.camlp4o_cmd ^" ./macro.cmo pr_o.cmo /tmp/ttttt.ml");
+ Unix.unlink "/tmp/ttttt.ml";
end
(*
(*****************************************************************************)
exception Todo
-exception Impossible
+exception Impossible of int
exception Here
exception ReturnExn
(* old: let _TODO () = failwith "TODO", now via fix_caml with raise Todo *)
let internal_error s = failwith ("internal error: "^s)
-let error_cant_have x = internal_error ("cant have this case" ^(dump x))
+let error_cant_have x = internal_error ("cant have this case: " ^(Dumper.dump x))
let myassert cond = if cond then () else failwith "assert error"
* In fact dont have to name it, use +> (fun v -> ...) so when want
* erase debug just have to erase one line.
*)
-let warning s v = (pr2 ("Warning: " ^ s ^ "; value = " ^ (dump v)); v)
+let warning s v = (pr2 ("Warning: " ^ s ^ "; value = " ^ (Dumper.dump v)); v)
short_usage_fun();
raise (UnixExit (2))
| Arg.Help msg -> (* printf "%s" msg; exit 0; *)
- raise Impossible (* -help is specified in speclist *)
+ raise (Impossible 1) (* -help is specified in speclist *)
)
let map_filter f xs = xs +> List.map f +> filter_some
+(* avoid recursion *)
+let tail_map_filter f xs =
+ List.rev
+ (List.fold_left
+ (function prev ->
+ function cur ->
+ match f cur with
+ Some x -> x :: prev
+ | None -> prev)
+ [] xs)
+
let rec find_some p = function
| [] -> raise Not_found
| x :: l ->
| 11 -> "November"
| 12 -> "December"
*)
- | _ -> raise Impossible
+ | _ -> raise (Impossible 2)
let month_info = [
| (Unix.S_REG | Unix.S_LNK) -> true
| _ -> false
)
- with Unix.Unix_error (Unix.ENOENT, _, _) -> false
+ with
+ Unix.Unix_error (Unix.ENOENT, _, _) -> false
+ | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false
+ | Unix.Unix_error (error, _, fl) ->
+ failwith
+ (Printf.sprintf "unexpected error %s for file %s"
+ (Unix.error_message error) fl)
let is_directory file =
(Unix.stat file).Unix.st_kind =*= Unix.S_DIR
let cache_computation_robust2
- file ext_cache
+ dest_dir file ext_cache
(need_no_changed_files, need_no_changed_variables) ext_depend
f =
- if not (Sys.file_exists file)
- then failwith ("can't find: " ^ file);
-
- let file_cache = (file ^ ext_cache) in
- let dependencies_cache = (file ^ ext_depend) in
+ (if not (Sys.file_exists file)
+ then failwith ("can't find: " ^ file));
+ let (file_cache,dependencies_cache) =
+ let file_cache = (file ^ ext_cache) in
+ let dependencies_cache = (file ^ ext_depend) in
+ match dest_dir with
+ None -> (file_cache, dependencies_cache)
+ | Some dir ->
+ let file_cache =
+ Filename.concat dir
+ (if String.get file_cache 0 =*= '/'
+ then String.sub file_cache 1 ((String.length file_cache) - 1)
+ else file_cache) in
+ let dependencies_cache =
+ Filename.concat dir
+ (if String.get dependencies_cache 0 =*= '/'
+ then
+ String.sub dependencies_cache 1
+ ((String.length dependencies_cache) - 1)
+ else dependencies_cache) in
+ let _ = Sys.command
+ (Printf.sprintf "mkdir -p %s" (Filename.dirname file_cache)) in
+ (file_cache,dependencies_cache) in
+
let dependencies =
(* could do md5sum too *)
((file::need_no_changed_files) +> List.map (fun f -> f, filemtime f),
- need_no_changed_variables)
+ need_no_changed_variables)
in
if Sys.file_exists dependencies_cache &&
get_value dependencies_cache =*= dependencies
- then get_value file_cache
+ then
+ (*begin
+ pr2 ("cache computation reuse " ^ file);*)
+ get_value file_cache
+ (*end*)
else begin
- pr2 ("cache computation recompute " ^ file);
+ (*pr2 ("cache computation recompute " ^ file);*)
let res = f () in
write_value dependencies dependencies_cache;
write_value res file_cache;
let cache_computation_robust a b c d e =
profile_code "Common.cache_computation_robust" (fun () ->
- cache_computation_robust2 a b c d e)
+ cache_computation_robust2 None a b c d e)
+
+let cache_computation_robust_in_dir a b c d e f =
+ profile_code "Common.cache_computation_robust" (fun () ->
+ cache_computation_robust2 a b c d e f)
with Timeout ->
begin
log "timeout (we abort)";
+ (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
raise Timeout;
end
| e ->
| Some x -> timeout_function x f
+(* removes only if the file does not exists *)
+let remove_file path =
+ if Sys.file_exists path
+ then Sys.remove path
+ else ()
(* creation of tmp files, a la gcc *)
if not !save_tmp_files then begin
!_temp_files_created +> List.iter (fun s ->
(* pr2 ("erasing: " ^ s); *)
- command2 ("rm -f " ^ s)
+ remove_file s
);
_temp_files_created := []
end
if not !save_tmp_files then begin
_temp_files_created :=
List.filter (function x -> not (x =$= f)) !_temp_files_created;
- command2 ("rm -f " ^ f)
+ remove_file f
end
let (exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list)=
fun f xs ->
- let rec aux_filter acc = function
- | [] -> [] (* drop what was accumulated because nothing to attach to *)
+ let rec aux_filter acc ans = function
+ | [] -> (* drop what was accumulated because nothing to attach to *)
+ List.rev ans
| x::xs ->
if f x
- then aux_filter (x::acc) xs
- else (x, List.rev acc)::aux_filter [] xs
+ then aux_filter (x::acc) ans xs
+ else aux_filter [] ((x, List.rev acc)::ans) xs
in
- aux_filter [] xs
+ aux_filter [] [] xs
let _ = example
(exclude_but_keep_attached (fun x -> x =|= 3) [3;3;1;3;2;3;3;3] =*=
[(1,[3;3]);(2,[3])])
([1;1], [(3,[2]); (3,[4;5]); (3,[6;6;6])]))
-let rec (split_when: ('a -> bool) -> 'a list -> 'a list * 'a * 'a list) =
- fun p -> function
+let (split_when: ('a -> bool) -> 'a list -> 'a list * 'a * 'a list) =
+ fun p l ->
+ let rec loop acc = function
| [] -> raise Not_found
| x::xs ->
if p x then
- [], x, xs
- else
- let (l1, a, l2) = split_when p xs in
- (x::l1, a, l2)
+ List.rev acc, x, xs
+ else loop (x :: acc) xs in
+ loop [] l
let _ = example (split_when (fun x -> x =|= 3)
[1;2;3;4;1;2] =*= ([1;2],3,[4;1;2]))
let assoc_with_err_msg k l =
try List.assoc k l
with Not_found ->
- pr2 (spf "pb assoc_with_err_msg: %s" (dump k));
+ pr2 (spf "pb assoc_with_err_msg: %s" (Dumper.dump k));
raise Not_found
(*****************************************************************************)
let tail = List.tl
let is_singleton = fun xs -> List.length xs =|= 1
+let tail_map f l = (* tail recursive map, using rev *)
+ let rec loop acc = function
+ [] -> acc
+ | x::xs -> loop ((f x) :: acc) xs in
+ List.rev(loop [] l)
+
(*****************************************************************************)
(* Geometry (raytracer) *)
(*****************************************************************************)
| ("|" | "/" | "\\" ) ->
f !a !b BnotinA; f !a !b AnotinB; incr a; incr b;
| "<" -> f !a !b AnotinB; incr a;
- | _ -> raise Impossible
+ | _ -> raise (Impossible 3)
)
(*
let _ =
| ">" -> f !a !b BnotinA; incr b;
| "|" -> f !a !b BnotinA; f !a !b AnotinB; incr a; incr b;
| "<" -> f !a !b AnotinB; incr a;
- | _ -> raise Impossible
+ | _ -> raise (Impossible 4)
)
profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a)
let test_charpos file =
- full_charpos_to_pos file +> dump +> pr2
+ full_charpos_to_pos file +> Dumper.dump +> pr2
let empty_score () = (Hashtbl.create 101 : score)
+let save_score score path =
+ write_value score path
+let load_score path () =
+ read_value path
let regression_testing_vs newscore bestscore =
optionise (fun () -> Hashtbl.find newscore res),
optionise (fun () -> Hashtbl.find bestscore res)
with
- | None, None -> raise Impossible
+ | None, None -> raise (Impossible 5)
| Some x, None ->
Printf.printf "new test file appeared: %s\n" res;
Hashtbl.add newbestscore res x;
let new_scope_h scoped_env =
scoped_env := {!scoped_env with scoped_list = []::!scoped_env.scoped_list}
+
let del_scope_h scoped_env =
begin
List.hd !scoped_env.scoped_list +> List.iter (fun (k, v) ->
}
end
+let clean_scope_h scoped_env = (* keep only top level (last scope) *)
+ let rec loop _ =
+ match (!scoped_env).scoped_list with
+ [] | [_] -> ()
+ | _::_ -> del_scope_h scoped_env; loop () in
+ loop()
+
let do_in_new_scope_h scoped_env f =
begin
new_scope_h scoped_env;
if !profile <> PNONE
then pr2 (profile_diagnostic ());
erase_temp_files ();
+ clear_pr2_once()
)
)
(* let _ = if not !Sys.interactive then (main ()) *)
HCoop / bpt / coccinelle.git / blobdiff