X-Git-Url: http://git.hcoop.net/bpt/coccinelle.git/blobdiff_plain/b1b2de814d2c59af2526bc19d41bb22a0c1fd16d..abad11c5570b7b9bbae5ff92b3050cf68fe3fd14:/commons/common.ml

diff --git a/commons/common.ml b/commons/common.ml
index 1d128a0..34d602b 100644
--- a/commons/common.ml
+++ b/commons/common.ml
@@ -1,12 +1,13 @@
 (* Yoann Padioleau
  *
+ * Copyright (C) 2010 INRIA, University of Copenhagen DIKU
  * Copyright (C) 1998-2009 Yoann Padioleau
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
  * version 2.1 as published by the Free Software Foundation, with the
  * special exception on linking described in file license.txt.
- * 
+ *
  * 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 file
@@ -27,7 +28,7 @@
  * functions depends on other functions from this common, it would
  * be tedious to add those dependencies. Here simpler (have just the
  * pb of the Prelude, but it's a small problem).
- * 
+ *
  * pixel means code from Pascal Rigaux
  * julia means code from Julia Lawall
  *)
@@ -36,32 +37,32 @@
 (*****************************************************************************)
 (* We use *)
 (*****************************************************************************)
-(* 
+(*
  * modules:
  *   - Pervasives, of course
  *   - List
  *   - Str
  *   - Hashtbl
- *   - Format 
+ *   - Format
  *   - Buffer
  *   - Unix and Sys
  *   - Arg
- * 
- * functions: 
- *   - =, <=, max min, abs, ... 
+ *
+ * functions:
+ *   - =, <=, max min, abs, ...
  *   - List.rev, List.mem, List.partition,
- *   - List.fold*, List.concat, ... 
+ *   - List.fold*, List.concat, ...
  *   - Str.global_replace
  *   - Filename.is_relative
  *   - String.uppercase, String.lowercase
- * 
- * 
+ *
+ *
  * The Format library allows to hide passing an indent_level variable.
  * You use as usual the print_string function except that there is
  * this automatic indent_level variable handled for you (and maybe
  * more services). src: julia in coccinelle unparse_cocci.
- * 
- * Extra packages 
+ *
+ * Extra packages
  *  - ocamlbdb
  *  - ocamlgtk, and gtksourceview
  *  - ocamlgl
@@ -70,10 +71,10 @@
  *  - ocamlfuse
  *  - ocamlmpi
  *  - ocamlcalendar
- * 
+ *
  *  - pcre
  *  - sdl
- * 
+ *
  * Many functions in this file were inspired by Haskell or Lisp librairies.
  *)
 
@@ -93,7 +94,7 @@ let (+>) o f = f o
 let (++) = (@)
 
 exception Timeout
-exception UnixExit of int 
+exception UnixExit of int
 
 let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
   if i = 0 then () else (f(); do_n (i-1) f)
@@ -106,11 +107,11 @@ let sum_int   = List.fold_left (+) 0
 let fold_left_with_index f acc =
   let rec fold_lwi_aux acc n = function
     | [] -> acc
-    | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs 
+    | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs
   in fold_lwi_aux acc 0
 
 
-let rec drop n xs = 
+let rec drop n xs =
   match (n,xs) with
   | (0,_) -> xs
   | (_,[]) -> failwith "drop: not enough"
@@ -118,15 +119,15 @@ let rec drop n xs =
 
 let rec enum_orig x n = if x = n then [n] else x::enum_orig (x+1)  n
 
-let enum x n = 
+let enum x n =
   if not(x <= n)
   then failwith (Printf.sprintf "bad values in enum, expect %d <= %d" x n);
-  let rec enum_aux acc x n = 
-    if x = n then n::acc else enum_aux (x::acc) (x+1) n 
+  let rec enum_aux acc x n =
+    if x = n then n::acc else enum_aux (x::acc) (x+1) n
   in
   List.rev (enum_aux [] x n)
 
-let rec take n xs = 
+let rec take n xs =
   match (n,xs) with
   | (0,_) -> []
   | (_,[]) -> failwith "take: not enough"
@@ -141,12 +142,12 @@ let (list_of_string: string -> char list) = function
     "" -> []
   | s -> (enum 0 ((String.length s) - 1) +> List.map (String.get s))
 
-let (lines: string -> string list) = fun s -> 
+let (lines: string -> string list) = fun s ->
   let rec lines_aux = function
     | [] -> []
-    | [x] -> if x = "" then [] else [x] 
-    | x::xs -> 
-        x::lines_aux xs 
+    | [x] -> if x = "" then [] else [x]
+    | x::xs ->
+        x::lines_aux xs
   in
   Str.split_delim (Str.regexp "\n") s +> lines_aux
 
@@ -159,27 +160,27 @@ let null xs = match xs with [] -> true | _ -> false
 
 
 
-let debugger = ref false  
+let debugger = ref false
 
 let unwind_protect f cleanup =
-  if !debugger then f() else 
+  if !debugger then f() else
     try f ()
     with e -> begin cleanup e; raise e end
 
-let finalize f cleanup = 
-  if !debugger then f() else 
-  try 
+let finalize f cleanup =
+  if !debugger then f() else
+  try
     let res = f () in
     cleanup ();
     res
-  with e -> 
+  with e ->
     cleanup ();
     raise e
 
 let command2 s = ignore(Sys.command s)
 
 
-let (matched: int -> string -> string) = fun i s -> 
+let (matched: int -> string -> string) = fun i s ->
   Str.matched_group i s
 
 let matched1 = fun s -> matched 1 s
@@ -204,10 +205,10 @@ let foldl1 p = function x::xs -> List.fold_left p x xs | _ -> failwith "foldl1"
 (* Debugging/logging *)
 (*****************************************************************************)
 
-(* I used this in coccinelle where the huge logging of stuff ask for 
+(* I used this in coccinelle where the huge logging of stuff ask for
  * a more organized solution that use more visual indentation hints.
- * 
- * todo? could maybe use log4j instead ? or use Format module more 
+ *
+ * todo? could maybe use log4j instead ? or use Format module more
  * consistently ?
  *)
 
@@ -217,74 +218,103 @@ let _tab_indent = 5
 
 let _prefix_pr = ref ""
 
-let indent_do f = 
+let indent_do f =
   _tab_level_print := !_tab_level_print + _tab_indent;
-  finalize f 
+  finalize f
    (fun () -> _tab_level_print := !_tab_level_print - _tab_indent;)
 
 
-let pr s = 
+let pr s =
   print_string !_prefix_pr;
   do_n !_tab_level_print (fun () -> print_string " ");
   print_string s;
-  print_string "\n"; 
+  print_string "\n";
   flush stdout
 
-let pr_no_nl s = 
+let pr_no_nl s =
   print_string !_prefix_pr;
   do_n !_tab_level_print (fun () -> print_string " ");
   print_string s;
   flush stdout
 
 
-let pr2 s = 
-  prerr_string !_prefix_pr;
-  do_n !_tab_level_print (fun () -> prerr_string " ");
-  prerr_string s;
-  prerr_string "\n"; 
-  flush stderr
 
-let pr2_no_nl s = 
-  prerr_string !_prefix_pr;
-  do_n !_tab_level_print (fun () -> prerr_string " ");
-  prerr_string s;
-  flush stderr
 
-let pr_xxxxxxxxxxxxxxxxx () = 
+
+
+let _chan_pr2 = ref (None: out_channel option)
+
+let out_chan_pr2 ?(newline=true) s =
+  match !_chan_pr2 with
+  | None -> ()
+  | Some chan ->
+      output_string chan (s ^ (if newline then "\n" else ""));
+      flush chan
+
+let print_to_stderr = ref true
+
+let pr2 s =
+  if !print_to_stderr
+  then
+    begin
+      prerr_string !_prefix_pr;
+      do_n !_tab_level_print (fun () -> prerr_string " ");
+      prerr_string s;
+      prerr_string "\n";
+      flush stderr;
+      out_chan_pr2 s;
+      ()
+    end
+
+let pr2_no_nl s =
+  if !print_to_stderr
+  then
+    begin
+      prerr_string !_prefix_pr;
+      do_n !_tab_level_print (fun () -> prerr_string " ");
+      prerr_string s;
+      flush stderr;
+      out_chan_pr2 ~newline:false s;
+      ()
+    end
+
+
+let pr_xxxxxxxxxxxxxxxxx () =
   pr "-----------------------------------------------------------------------"
 
-let pr2_xxxxxxxxxxxxxxxxx () = 
+let pr2_xxxxxxxxxxxxxxxxx () =
   pr2 "-----------------------------------------------------------------------"
 
 
 let reset_pr_indent () =
   _tab_level_print := 0
 
-(* old: 
+(* old:
  * let pr s = (print_string s; print_string "\n"; flush stdout)
- * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr) 
+ * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr)
  *)
 
 (* ---------------------------------------------------------------------- *)
 
-(* I can not use the _xxx ref tech that I use for common_extra.ml here because 
+(* I can not use the _xxx ref tech that I use for common_extra.ml here because
  * ocaml don't like the polymorphism of Dumper mixed with refs.
- * 
- * let (_dump_func : ('a -> string) ref) = ref 
+ *
+ * let (_dump_func : ('a -> string) ref) = ref
  * (fun x -> failwith "no dump yet, have you included common_extra.cmo?")
  * let (dump : 'a -> string) = fun x ->
  * !_dump_func x
- * 
+ *
  * So I have included directly dumper.ml in common.ml. It's more practical
  * when want to give script that use my common.ml, I just have to give
  * 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.
  * By Richard W.M. Jones (rich@annexia.org).
- * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp 
+ * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp
  *)
 open Printf
 open Obj
@@ -368,6 +398,7 @@ let rec dump r =
 let dump v = dump (repr v)
 
 (* end of dumper.ml *)
+*)
 
 (*
 let (dump : 'a -> string) = fun x ->
@@ -376,7 +407,7 @@ let (dump : 'a -> string) = fun x ->
 
 
 (* ---------------------------------------------------------------------- *)
-let pr2_gen x = pr2 (dump x)
+let pr2_gen x = pr2 (Dumper.dump x)
 
 
 
@@ -384,21 +415,62 @@ let pr2_gen x = pr2 (dump x)
 
 
 let _already_printed = Hashtbl.create 101
-let disable_pr2_once = ref false 
-let pr2_once s = 
+let disable_pr2_once = ref false
+
+let xxx_once f s =
   if !disable_pr2_once then pr2 s
-  else 
+  else
     if not (Hashtbl.mem _already_printed s)
     then begin
       Hashtbl.add _already_printed s true;
-      pr2 ("(ONCE) " ^ s);
+      f ("(ONCE) " ^ s);
     end
 
+let pr2_once s = xxx_once pr2 s
+
+let clear_pr2_once _ = Hashtbl.clear _already_printed
+
+(* ---------------------------------------------------------------------- *)
+let mk_pr2_wrappers aref =
+  let fpr2 s =
+    if !aref
+    then pr2 s
+    else
+      (* just to the log file *)
+      out_chan_pr2 s
+  in
+  let fpr2_once s =
+    if !aref
+    then pr2_once s
+    else
+      xxx_once out_chan_pr2 s
+  in
+    fpr2, fpr2_once
 
 (* ---------------------------------------------------------------------- *)
 (* could also be in File section *)
 
-let redirect_stdout_stderr file f = 
+let redirect_stdout file f =
+  begin
+    let chan = open_out file in
+    let descr = Unix.descr_of_out_channel chan in
+
+    let saveout = Unix.dup Unix.stdout in
+      Unix.dup2 descr Unix.stdout;
+      flush stdout;
+      let res = f() in
+	flush stdout;
+	Unix.dup2 saveout Unix.stdout;
+	close_out chan;
+	res
+  end
+
+let redirect_stdout_opt optfile f =
+  match optfile with
+    | None -> f()
+    | Some outfile -> redirect_stdout outfile f
+
+let redirect_stdout_stderr file f =
   begin
     let chan = open_out file in
     let descr = Unix.descr_of_out_channel chan in
@@ -415,24 +487,29 @@ let redirect_stdout_stderr file f =
     close_out chan;
   end
 
-let redirect_stdin file f = 
+let redirect_stdin file f =
   begin
     let chan = open_in file in
     let descr = Unix.descr_of_in_channel chan in
 
     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 redirect_stdin_opt optfile f =
   match optfile with
   | None -> f()
   | Some infile -> redirect_stdin infile f
 
 
+(* cf end
+let with_pr2_to_string f =
+*)
+
 
 (* ---------------------------------------------------------------------- *)
 
@@ -444,7 +521,7 @@ include Printf
  *  val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
  *)
 
-(* ex of printf: 
+(* ex of printf:
  *  printf "%02d" i
  * for padding
  *)
@@ -454,11 +531,11 @@ let spf = sprintf
 (* ---------------------------------------------------------------------- *)
 
 let _chan = ref stderr
-let start_log_file () = 
+let start_log_file () =
   let filename = (spf "/tmp/debugml%d:%d" (Unix.getuid()) (Unix.getpid())) in
   pr2 (spf "now using %s for logging" filename);
   _chan := open_out filename
-   
+
 
 let dolog s = output_string !_chan (s ^ "\n"); flush !_chan
 
@@ -479,7 +556,7 @@ let pause () = (pr2 "pause: type return"; ignore(read_line ()))
 
 (* src: from getopt from frish *)
 let bip ()  = Printf.printf "\007"; flush stdout
-let wait () = Unix.sleep 1 
+let wait () = Unix.sleep 1
 
 (* was used by fix_caml *)
 let _trace_var = ref 0
@@ -487,9 +564,9 @@ let add_var() = incr _trace_var
 let dec_var() = decr _trace_var
 let get_var() = !_trace_var
 
-let (print_n: int -> string -> unit) = fun i s -> 
+let (print_n: int -> string -> unit) = fun i s ->
   do_n i (fun () -> print_string s)
-let (printerr_n: int -> string -> unit) = fun i s -> 
+let (printerr_n: int -> string -> unit) = fun i s ->
   do_n i (fun () -> prerr_string s)
 
 let _debug = ref true
@@ -500,7 +577,7 @@ let debug f = if !_debug then f () else ()
 
 
 (* now in prelude:
- * let debugger = ref false  
+ * let debugger = ref false
  *)
 
 
@@ -519,18 +596,18 @@ let memory_stat () =
   Printf.sprintf "lives   = %d Mo\n" (conv_mo stat.Gc.live_words)
   (* Printf.printf "fragments = %d Mo\n" (conv_mo stat.Gc.fragments); *)
 
-let timenow () = 
+let timenow () =
   "sys:" ^ (string_of_float (Sys.time ())) ^ " seconds" ^
-  ":real:" ^ 
+  ":real:" ^
     (let tm = Unix.time () +> Unix.gmtime in
-     tm.Unix.tm_min +> string_of_int ^ " min:" ^ 
+     tm.Unix.tm_min +> string_of_int ^ " min:" ^
      tm.Unix.tm_sec +> string_of_int ^ ".00 seconds")
 
-let _count1 = ref 0  
-let _count2 = ref 0  
-let _count3 = ref 0  
-let _count4 = ref 0  
-let _count5 = ref 0  
+let _count1 = ref 0
+let _count2 = ref 0
+let _count3 = ref 0
+let _count4 = ref 0
+let _count5 = ref 0
 
 let count1 () = incr _count1
 let count2 () = incr _count2
@@ -538,14 +615,14 @@ let count3 () = incr _count3
 let count4 () = incr _count4
 let count5 () = incr _count5
 
-let profile_diagnostic_basic () = 
-  Printf.sprintf 
-    "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n" 
+let profile_diagnostic_basic () =
+  Printf.sprintf
+    "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n"
     !_count1 !_count2 !_count3 !_count4 !_count5
 
 
 
-let time_func f = 
+let time_func f =
   (*   let _ = Timing () in *)
   let x = f () in
   (*   let _ = Timing () in *)
@@ -566,9 +643,9 @@ let check_profile category =
 let _profile_table = ref (Hashtbl.create 100)
 
 let adjust_profile_entry category difftime =
-  let (xtime, xcount) = 
+  let (xtime, xcount) =
     (try Hashtbl.find !_profile_table category
-    with Not_found -> 
+    with Not_found ->
       let xtime = ref 0.0 in
       let xcount = ref 0 in
       Hashtbl.add !_profile_table category (xtime, xcount);
@@ -584,17 +661,17 @@ let profile_end category = failwith "todo"
 
 (* subtil: don't forget to give all argumens to f, otherwise partial app
  * and will profile nothing.
- * 
+ *
  * todo: try also detect when complexity augment each time, so can
- * detect the situation for a function gets worse and worse ? 
- *)  
-let profile_code category f = 
+ * detect the situation for a function gets worse and worse ?
+ *)
+let profile_code category f =
   if not (check_profile category)
-  then f() 
+  then f()
   else begin
   if !show_trace_profile then pr2 (spf "p: %s" category);
   let t = Unix.gettimeofday () in
-  let res, prefix = 
+  let res, prefix =
     try Some (f ()), ""
     with Timeout -> None, "*"
   in
@@ -609,60 +686,60 @@ let profile_code category f =
   end
 
 
-let _is_in_exclusif = ref (None: string option) 
+let _is_in_exclusif = ref (None: string option)
 
-let profile_code_exclusif category f = 
+let profile_code_exclusif category f =
   if not (check_profile category)
-  then f() 
+  then f()
   else begin
 
   match !_is_in_exclusif with
-  | Some s -> 
+  | Some s ->
       failwith (spf "profile_code_exclusif: %s but already in %s " category s);
-  | None -> 
+  | None ->
       _is_in_exclusif := (Some category);
-      finalize 
-        (fun () -> 
+      finalize
+        (fun () ->
           profile_code category f
-        ) 
-        (fun () -> 
+        )
+        (fun () ->
           _is_in_exclusif := None
         )
 
   end
 
-let profile_code_inside_exclusif_ok category f = 
+let profile_code_inside_exclusif_ok category f =
   failwith "Todo"
 
 
 (* todo: also put  % ? also add % to see if coherent numbers *)
-let profile_diagnostic () = 
+let profile_diagnostic () =
   if !profile = PNONE then "" else
-  let xs = 
-    Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table [] 
+  let xs =
+    Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table []
       +> List.sort (fun (k1, (t1,n1)) (k2, (t2,n2)) -> compare t2 t1)
     in
-    with_open_stringbuf (fun (pr,_) -> 
+    with_open_stringbuf (fun (pr,_) ->
       pr "---------------------";
       pr "profiling result";
       pr "---------------------";
-      xs +> List.iter (fun (k, (t,n)) -> 
+      xs +> List.iter (fun (k, (t,n)) ->
         pr (sprintf "%-40s : %10.3f sec %10d count" k !t !n)
       )
     )
 
 
 
-let report_if_take_time timethreshold s f = 
+let report_if_take_time timethreshold s f =
   let t = Unix.gettimeofday () in
   let res = f () in
   let t' = Unix.gettimeofday () in
-  if (t' -. t  > float_of_int timethreshold) 
-  then pr2 (sprintf "NOTE: this code takes more than: %ds %s" timethreshold s);
+  if (t' -. t  > float_of_int timethreshold)
+  then pr2 (sprintf "Note: processing took %7.1fs: %s" (t' -. t) s);
   res
 
-let profile_code2 category f = 
-  profile_code category (fun () -> 
+let profile_code2 category f =
+  profile_code category (fun () ->
     if !profile = PALL
     then pr2 ("starting: " ^ category);
     let t = Unix.gettimeofday () in
@@ -672,7 +749,7 @@ let profile_code2 category f =
     then pr2 (spf "ending: %s, %fs" category (t' -. t));
     res
   )
-    
+
 
 (*****************************************************************************)
 (* Test *)
@@ -681,37 +758,37 @@ let example b = assert b
 
 let _ex1 = example (enum 1 4 = [1;2;3;4])
 
-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")
+let assert_equal a b =
+  if not (a = b)
+  then failwith ("assert_equal: those 2 values are not equal:\n\t" ^
+                 (Dumper.dump a) ^ "\n\t" ^ (Dumper.dump b) ^ "\n")
 
-let (example2: string -> bool -> unit) = fun s b -> 
+let (example2: string -> bool -> unit) = fun s b ->
   try assert b with x -> failwith s
 
 (*-------------------------------------------------------------------*)
 let _list_bool = ref []
 
-let (example3: string -> bool -> unit) = fun s b -> 
+let (example3: string -> bool -> unit) = fun s b ->
  _list_bool := (s,b)::(!_list_bool)
 
 (* could introduce a fun () otherwise the calculus is made at compile time
  * and this can be long. This would require to redefine test_all.
- *   let (example3: string -> (unit -> bool) -> unit) = fun s func -> 
+ *   let (example3: string -> (unit -> bool) -> unit) = fun s func ->
  *   _list_bool := (s,func):: (!_list_bool)
- * 
+ *
  * I would like to do as a func that take 2 terms, and make an = over it
  * avoid to add this ugly fun (), but pb of type, cant do that :(
  *)
 
 
-let (test_all: unit -> unit) = fun () -> 
-  List.iter (fun (s, b) -> 
+let (test_all: unit -> unit) = fun () ->
+  List.iter (fun (s, b) ->
     Printf.printf "%s: %s\n" s (if b then "passed" else "failed")
   ) !_list_bool
 
-let (test: string -> unit) = fun s -> 
-  Printf.printf "%s: %s\n" s 
+let (test: string -> unit) = fun s ->
+  Printf.printf "%s: %s\n" s
     (if (List.assoc s (!_list_bool)) then "passed" else "failed")
 
 let _ex = example3 "++" ([1;2]++[3;4;5] = [1;2;3;4;5])
@@ -720,7 +797,7 @@ let _ex = example3 "++" ([1;2]++[3;4;5] = [1;2;3;4;5])
 (* Regression testing *)
 (*-------------------------------------------------------------------*)
 
-(* cf end of file. It uses too many other common functions so I 
+(* cf end of file. It uses too many other common functions so I
  * have put the code at the end of this file.
  *)
 
@@ -750,7 +827,7 @@ let reset () =
   ok_ref := 0;
   bug_ref := 0
 
-let test x s = 
+let test x s =
   if x then ok () else begin Printf.printf "%s\n" s; bug () end;;
 
 let test_exn x s =
@@ -769,24 +846,24 @@ let test_exn x s =
 
 (* Better than quickcheck, cos cant do a test_all_prop in haskell cos
  * prop were functions, whereas here we have not prop_Unix x = ... but
- * laws "unit" ... 
+ * laws "unit" ...
  *
  * How to do without overloading ? objet ? can pass a generator as a
  * parameter, mais lourd, prefer automatic inferring of the
  * generator? But at the same time quickcheck does not do better cos
- * we must explictly type the property. So between a 
- *    prop_unit:: [Int] -> [Int] -> bool ... 
- *    prop_unit x = reverse [x] == [x] 
- * and 
- *    let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg) 
- * there is no real differences.  
+ * we must explictly type the property. So between a
+ *    prop_unit:: [Int] -> [Int] -> bool ...
+ *    prop_unit x = reverse [x] == [x]
+ * and
+ *    let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg)
+ * there is no real differences.
  *
  * Yes I define typeg generator but quickcheck too, he must define
  * class instance. I emulate the context Gen a => Gen [a] by making
  * listg take as a param a type generator. Moreover I have not the pb of
- * monad. I can do random independently, so my code is more simple 
+ * monad. I can do random independently, so my code is more simple
  * I think than the haskell code of quickcheck.
- * 
+ *
  * update: apparently Jane Street have copied some of my code for their
  * Ounit_util.ml and quichcheck.ml in their Core library :)
  *)
@@ -798,34 +875,34 @@ type 'a gen = unit -> 'a
 
 let (ig: int gen) = fun () ->
   Random.int 10
-let (lg: ('a gen) -> ('a list) gen) = fun gen () -> 
+let (lg: ('a gen) -> ('a list) gen) = fun gen () ->
   foldn (fun acc i -> (gen ())::acc) [] (Random.int 10)
-let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () -> 
+let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () ->
   (gen1 (), gen2 ())
 let polyg = ig
-let (ng: (string gen)) = fun () -> 
+let (ng: (string gen)) = fun () ->
   "a" ^ (string_of_int (ig ()))
 
-let (oneofl: ('a list) -> 'a gen) = fun xs () -> 
-  List.nth xs (Random.int (List.length xs)) 
+let (oneofl: ('a list) -> 'a gen) = fun xs () ->
+  List.nth xs (Random.int (List.length xs))
 (* let oneofl l = oneof (List.map always l) *)
 
-let (oneof: (('a gen) list) -> 'a gen) = fun xs -> 
-  List.nth xs (Random.int (List.length xs)) 
+let (oneof: (('a gen) list) -> 'a gen) = fun xs ->
+  List.nth xs (Random.int (List.length xs))
 
 let (always: 'a -> 'a gen) = fun e () -> e
 
-let (frequency: ((int * ('a gen)) list) -> 'a gen) = fun xs -> 
+let (frequency: ((int * ('a gen)) list) -> 'a gen) = fun xs ->
   let sums = sum_int (List.map fst xs) in
   let i = Random.int sums in
-  let rec freq_aux acc = function 
-    | (x,g)::xs -> if i < acc+x then g else freq_aux (acc+x) xs 
-    | _ -> failwith "frequency" 
+  let rec freq_aux acc = function
+    | (x,g)::xs -> if i < acc+x then g else freq_aux (acc+x) xs
+    | _ -> failwith "frequency"
   in
   freq_aux 0 xs
 let frequencyl l = frequency (List.map (fun (i,e) -> (i,always e)) l)
 
-(* 
+(*
 let b = oneof [always true; always false] ()
 let b = frequency [3, always true; 2, always false] ()
 *)
@@ -834,20 +911,20 @@ let b = frequency [3, always true; 2, always false] ()
  *    let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneofl [[]; lg gen ()]
  * nor
  *    let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneof [always []; lg gen]
- * 
+ *
  * because caml is not as lazy as haskell :( fix the pb by introducing a size
  * limit. take the bounds/size as parameter. morover this is needed for
  * more complex type.
- * 
+ *
  * how make a bintreeg ?? we need recursion
- * 
- * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () -> 
- * let rec aux n = 
+ *
+ * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () ->
+ * let rec aux n =
  * if n = 0 then (Leaf (gen ()))
  * else frequencyl [1, Leaf (gen ()); 4, Branch ((aux (n / 2)), aux (n / 2))]
  * ()
  * in aux 20
- * 
+ *
  *)
 
 
@@ -856,12 +933,12 @@ let b = frequency [3, always true; 2, always false] ()
 (*---------------------------------------------------------------------------*)
 
 (* todo: a test_all_laws, better syntax (done already a little with ig in
- * place of intg. En cas d'erreur, print the arg that not respect 
- * 
+ * place of intg. En cas d'erreur, print the arg that not respect
+ *
  * todo: with monitoring, as in haskell, laws = laws2, no need for 2 func,
  * but hard i found
- * 
- * todo classify, collect, forall 
+ *
+ * todo classify, collect, forall
  *)
 
 
@@ -880,11 +957,11 @@ let rec (statistic_number: ('a list) -> (int * 'a) list) = function
 let (statistic: ('a list) -> (int * 'a) list) = fun xs ->
   let stat_num = statistic_number xs in
   let totals = sum_int (List.map fst stat_num) in
-  List.map (fun (i, v) -> ((i * 100) / totals), v) stat_num 
-  
-let (laws2: 
-        string -> ('a -> (bool * 'b)) -> ('a gen) -> 
-        ('a option * ((int * 'b) list ))) = 
+  List.map (fun (i, v) -> ((i * 100) / totals), v) stat_num
+
+let (laws2:
+        string -> ('a -> (bool * 'b)) -> ('a gen) ->
+        ('a option * ((int * 'b) list ))) =
   fun s func gen ->
   let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in
   let stat = statistic (List.map (fun (x,(b,v)) -> v) res) in
@@ -899,7 +976,7 @@ let b = laws "rev " (fun xs      -> reverse (reverse xs) = xs
 let b = laws "appb" (fun (xs,ys) -> reverse (xs++ys)     = reverse xs++reverse ys)(pg (lg ig)(lg ig))
 let b = laws "max"  (fun (x,y)   -> x <= y ==> (max x y  = y)                       )(pg ig ig)
 
-let b = laws2 "max"  (fun (x,y)   -> ((x <= y ==> (max x y  = y)), x <= y))(pg ig ig) 
+let b = laws2 "max"  (fun (x,y)   -> ((x <= y ==> (max x y  = y)), x <= y))(pg ig ig)
 *)
 
 
@@ -914,44 +991,44 @@ let b = laws "funs" (fun (f,g,h) -> x <= y ==> (max x y  = y)       )(pg ig ig)
  *)
 
 (*
-let one_of xs = List.nth xs (Random.int (List.length xs)) 
+let one_of xs = List.nth xs (Random.int (List.length xs))
 let take_one xs =
   if empty xs then failwith "Take_one: empty list"
-  else 
+  else
     let i = Random.int (List.length xs) in
     List.nth xs i, filter_index (fun j _ -> i <> j) xs
-*)    
+*)
 
 (*****************************************************************************)
 (* Persistence *)
 (*****************************************************************************)
 
-let get_value filename = 
+let get_value filename =
   let chan = open_in filename in
   let x = input_value chan in (* <=> Marshal.from_channel  *)
   (close_in chan; x)
 
-let write_value valu filename = 
+let write_value valu filename =
   let chan = open_out filename in
   (output_value chan valu;  (* <=> Marshal.to_channel *)
    (* Marshal.to_channel chan valu [Marshal.Closures]; *)
-   close_out chan) 
+   close_out chan)
 
-let write_back func filename = 
+let write_back func filename =
   write_value (func (get_value filename)) filename
 
 
 let read_value f = get_value f
 
 
-let marshal__to_string2 v flags = 
+let marshal__to_string2 v flags =
   Marshal.to_string v flags
-let marshal__to_string a b = 
+let marshal__to_string a b =
   profile_code "Marshalling" (fun () -> marshal__to_string2 a b)
 
-let marshal__from_string2 v flags = 
+let marshal__from_string2 v flags =
   Marshal.from_string v flags
-let marshal__from_string a b = 
+let marshal__from_string a b =
   profile_code "Marshalling" (fun () -> marshal__from_string2 a b)
 
 
@@ -976,11 +1053,11 @@ type timestamp = int
 (* To work with the macro system autogenerated string_of and print_ function
    (kind of deriving a la haskell) *)
 
-(* int, bool, char, float, ref ?, string *) 
+(* int, bool, char, float, ref ?, string *)
 
 let string_of_string s = "\"" ^ s "\""
 
-let string_of_list f xs = 
+let string_of_list f xs =
   "[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]"
 
 let string_of_unit () = "()"
@@ -1001,15 +1078,15 @@ let print_option pr = function
   | None   -> print_string "None"
   | Some x -> print_string "Some ("; pr x; print_string ")"
 
-let print_list pr xs = 
+let print_list pr xs =
   begin
-    print_string "["; 
-    List.iter (fun x -> pr x; print_string ",") xs; 
+    print_string "[";
+    List.iter (fun x -> pr x; print_string ",") xs;
     print_string "]";
   end
 
-(* specialised 
-let (string_of_list: char list -> string) = 
+(* specialised
+let (string_of_list: char list -> string) =
   List.fold_left (fun acc x -> acc^(Char.escaped x)) ""
 *)
 
@@ -1022,15 +1099,15 @@ let rec print_between between fn = function
 
 
 
-let adjust_pp_with_indent f = 
-  Format.open_box !_tab_level_print; 
+let adjust_pp_with_indent f =
+  Format.open_box !_tab_level_print;
   (*Format.force_newline();*)
-  f(); 
+  f();
   Format.close_box ();
   Format.print_newline()
 
-let adjust_pp_with_indent_and_header s f = 
-  Format.open_box (!_tab_level_print + String.length s); 
+let adjust_pp_with_indent_and_header s f =
+  Format.open_box (!_tab_level_print + String.length s);
   do_n !_tab_level_print (fun () -> Format.print_string " ");
   Format.print_string s;
   f();
@@ -1042,60 +1119,48 @@ let adjust_pp_with_indent_and_header s f =
 let pp_do_in_box f      = Format.open_box 1; f(); Format.close_box ()
 let pp_do_in_zero_box f = Format.open_box 0; f(); Format.close_box ()
 
-let pp_f_in_box f      = 
-  Format.open_box 1; 
-  let res = f() in 
+let pp_f_in_box f      =
+  Format.open_box 1;
+  let res = f() in
   Format.close_box ();
   res
 
 let pp s = Format.print_string s
 
-
-
-(* julia: convert something printed using format to print into a string *)
-let format_to_string f =
-  let o = open_out "/tmp/out" in
-  Format.set_formatter_out_channel o;
-  let _ = f() in
-  Format.print_flush();
-  Format.set_formatter_out_channel stdout;
-  close_out o;
-  let i = open_in "/tmp/out" in
-  let lines = ref [] in
-  let rec loop _ =
-    let cur = input_line i in
-    lines := cur :: !lines;
-    loop() in
-  (try loop() with End_of_file -> ());
-  close_in i;
-  String.concat "\n" (List.rev !lines)
-
-
-
-let mk_str_func_of_assoc_conv xs = 
+let mk_str_func_of_assoc_conv xs =
   let swap (x,y) = (y,x) in
 
-  (fun s -> 
+  (fun s ->
     let xs' = List.map swap xs in
     List.assoc s xs'
   ),
-  (fun a -> 
+  (fun a ->
     List.assoc a xs
   )
 
+
+
+(* julia: convert something printed using format to print into a string *)
+(* now at bottom of file
+let format_to_string f =
+ ...
+*)
+
+
+
 (*****************************************************************************)
 (* Macro *)
 (*****************************************************************************)
 
 (* put your macro in macro.ml4, and you can test it interactivly as in lisp *)
-let macro_expand s = 
+let macro_expand 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
 
 (*
@@ -1109,24 +1174,24 @@ let t = macro_expand "{x = 2; x = 3}"
 let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)"
 *)
 
-  
+
 
 (*****************************************************************************)
 (* Composition/Control *)
 (*****************************************************************************)
 
 (* I like the obj.func object notation. In OCaml cant use '.' so I use +>
- * 
+ *
  * update: it seems that F# agrees with me :) but they use |>
  *)
 
 (* now in prelude:
  * let (+>) o f = f o
  *)
-let (+!>) refo f = refo := f !refo 
-(* alternatives: 
+let (+!>) refo f = refo := f !refo
+(* alternatives:
  *  let ((@): 'a -> ('a -> 'b) -> 'b) = fun a b -> b a
- *  let o f g x = f (g x) 
+ *  let o f g x = f (g x)
  *)
 
 let ($)     f g x = g (f x)
@@ -1137,7 +1202,7 @@ let compose f g x = f (g x)
    by Keisuke Nakano on the caml mailing list.
 >    let ( /* ) x y = y x
 >    and ( */ ) x y = x y
-or 
+or
   let ( <| ) x y = y x
   and ( |> ) x y = x y
 
@@ -1155,17 +1220,17 @@ let do_nothing () = ()
 
 let rec applyn n f o = if n = 0 then o else applyn (n-1) f (f o)
 
-let forever f = 
+let forever f =
   while true do
     f();
   done
 
 
-class ['a] shared_variable_hook (x:'a) = 
+class ['a] shared_variable_hook (x:'a) =
   object(self)
     val mutable data = x
     val mutable registered = []
-    method set x = 
+    method set x =
       begin
         data <- x;
         pr "refresh registered";
@@ -1173,14 +1238,14 @@ class ['a] shared_variable_hook (x:'a) =
       end
     method get = data
     method modify f = self#set (f self#get)
-    method register f = 
-      registered <- f :: registered 
-  end    
+    method register f =
+      registered <- f :: registered
+  end
 
 (* src: from aop project. was called ptFix *)
 let rec fixpoint trans elem =
   let image = trans elem in
-  if (image = elem) 
+  if (image = elem)
   then elem (* point fixe *)
   else fixpoint trans image
 
@@ -1190,58 +1255,69 @@ let rec fixpoint_for_object trans elem =
   if (image#equal elem) then elem (* point fixe *)
   else fixpoint_for_object trans image
 
-let (add_hook: ('a -> ('a -> 'b) -> 'b) ref  -> ('a -> ('a -> 'b) -> 'b) -> unit) = 
+let (add_hook: ('a -> ('a -> 'b) -> 'b) ref  -> ('a -> ('a -> 'b) -> 'b) -> unit) =
  fun var f ->
-  let oldvar = !var in 
+  let oldvar = !var in
   var := fun arg k -> f arg (fun x -> oldvar x k)
 
-let (add_hook_action: ('a -> unit) ->   ('a -> unit) list ref -> unit) = 
- fun f hooks -> 
+let (add_hook_action: ('a -> unit) ->   ('a -> unit) list ref -> unit) =
+ fun f hooks ->
   push2 f hooks
 
-let (run_hooks_action: 'a -> ('a -> unit) list ref -> unit) = 
- fun obj hooks -> 
+let (run_hooks_action: 'a -> ('a -> unit) list ref -> unit) =
+ fun obj hooks ->
   !hooks +> List.iter (fun f -> try f obj with _ -> ())
 
 
 type 'a mylazy = (unit -> 'a)
 
 (* a la emacs *)
-let save_excursion reference f = 
+let save_excursion reference f =
   let old = !reference in
-  let res = f() in
+  let res = try f() with e -> reference := old; raise e in
   reference := old;
   res
 
+let save_excursion_and_disable reference f =
+  save_excursion reference (fun () ->
+    reference := false;
+    f ()
+  )
+
+let save_excursion_and_enable reference f =
+  save_excursion reference (fun () ->
+    reference := true;
+    f ()
+  )
 
 
-let memoized h k f = 
-  try Hashtbl.find h k 
-  with Not_found -> 
+let memoized h k f =
+  try Hashtbl.find h k
+  with Not_found ->
     let v = f () in
     begin
       Hashtbl.add h k v;
       v
     end
 
-let cache_in_ref myref f = 
+let cache_in_ref myref f =
   match !myref with
   | Some e -> e
-  | None -> 
+  | None ->
       let e = f () in
       myref := Some e;
       e
 
-let once f = 
+let once f =
   let already = ref false in
-  (fun x -> 
+  (fun x ->
     if not !already
     then begin already := true; f x end
   )
 
 (* cache_file, cf below *)
 
-let before_leaving f x = 
+let before_leaving f x =
   f x;
   x
 
@@ -1256,7 +1332,7 @@ let rec y f = fun x -> f (y f) x
 (*****************************************************************************)
 
 (* from http://en.wikipedia.org/wiki/File_locking
- * 
+ *
  * "When using file locks, care must be taken to ensure that operations
  * are atomic. When creating the lock, the process must verify that it
  * does not exist and then create it, but without allowing another
@@ -1265,12 +1341,12 @@ let rec y f = fun x -> f (y f) x
  * system calls designed for this purpose (but such system calls are
  * not usually available to shell scripts) or by creating the lock file
  * under a temporary name and then attempting to move it into place."
- * 
+ *
  * => can't use 'if(not (file_exist xxx)) then create_file xxx' because
  * file_exist/create_file are not in atomic section (classic problem).
- * 
+ *
  * from man open:
- * 
+ *
  * "O_EXCL When used with O_CREAT, if the file already exists it
  * is an error and the open() will fail. In this context, a
  * symbolic link exists, regardless of where it points to.
@@ -1287,15 +1363,15 @@ let rec y f = fun x -> f (y f) x
 
  *)
 
-exception FileAlreadyLocked 
+exception FileAlreadyLocked
 
 (* Racy if lock file on NFS!!! But still racy with recent Linux ? *)
-let acquire_file_lock filename = 
+let acquire_file_lock filename =
   pr2 ("Locking file: " ^ filename);
-  try 
+  try
     let _fd = Unix.openfile filename [Unix.O_CREAT;Unix.O_EXCL] 0o777 in
     ()
-  with Unix.Unix_error (e, fm, argm) -> 
+  with Unix.Unix_error (e, fm, argm) ->
     pr2 (spf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm);
     raise FileAlreadyLocked
 
@@ -1312,7 +1388,7 @@ let release_file_lock filename =
 (*****************************************************************************)
 
 exception Todo
-exception Impossible
+exception Impossible of int
 exception Here
 exception ReturnExn
 
@@ -1323,29 +1399,29 @@ exception WrongFormat of string
 (* 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"
 
 
 
 (* before warning I was forced to do stuff like this:
- *  
- * let (fixed_int_to_posmap: fixed_int -> posmap) = fun fixed -> 
+ *
+ * let (fixed_int_to_posmap: fixed_int -> posmap) = fun fixed ->
  * let v = ((fix_to_i fixed) / (power 2 16)) in
  * let _ = Printf.printf "coord xy = %d\n" v in
  * v
- * 
- * The need for printf make me force to name stuff :( 
+ *
+ * The need for printf make me force to name stuff :(
  * How avoid ? use 'it' special keyword ?
- * In fact dont have to name it, use +> (fun v -> ...)  so when want 
+ * 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)
 
 
 
 
-let exn_to_s exn = 
+let exn_to_s exn =
   Printexc.to_string exn
 
 (* alias *)
@@ -1376,10 +1452,10 @@ let evoval = ()
 (*****************************************************************************)
 
 let check_stack = ref true
-let check_stack_size limit = 
+let check_stack_size limit =
   if !check_stack then begin
     pr2 "checking stack size (do ulimit -s 50000 if problem)";
-    let rec aux i = 
+    let rec aux i =
       if i = limit
       then 0
       else 1 + aux (i + 1)
@@ -1388,24 +1464,26 @@ let check_stack_size limit =
     ()
   end
 
-let test_check_stack_size limit = 
+let test_check_stack_size limit =
   (* bytecode: 100000000 *)
   (* native:   10000000 *)
   check_stack_size (int_of_string limit)
 
 
 (* only relevant in bytecode, in native the stacklimit is the os stacklimit
- * (adjustable by ulimit -s) 
+ * (adjustable by ulimit -s)
  *)
-let _init_gc_stack = 
+let _init_gc_stack =
   Gc.set {(Gc.get ()) with Gc.stack_limit = 100 * 1024 * 1024}
 
 
+
+
 (* if process a big set of files then dont want get overflow in the middle
  * so for this we are ready to spend some extra time at the beginning that
  * could save far more later.
  *)
-let check_stack_nbfiles nbfiles = 
+let check_stack_nbfiles nbfiles =
   if nbfiles > 200
   then check_stack_size 10000000
 
@@ -1413,86 +1491,86 @@ let check_stack_nbfiles nbfiles =
 (* Arguments/options and command line (cocci and acomment) *)
 (*****************************************************************************)
 
-(* 
+(*
  * Why define wrappers ? Arg not good enough ? Well the Arg.Rest is not that
  * good and I need a way sometimes to get a list of argument.
- * 
+ *
  * I could define maybe a new Arg.spec such as
- * | String_list of (string list -> unit), but the action may require 
+ * | String_list of (string list -> unit), but the action may require
  * some flags to be set, so better to process this after all flags have
  * been set by parse_options. So have to split. Otherwise it would impose
- * an order of the options such as 
+ * an order of the options such as
  * -verbose_parsing -parse_c file1 file2. and I really like to use bash
  * history and add just at the end of my command a -profile for instance.
- * 
- * 
+ *
+ *
  * Why want a -action arg1 arg2 arg3 ? (which in turn requires this
- * convulated scheme ...) Why not use Arg.String action such as 
- * "-parse_c", Arg.String (fun file -> ...) ? 
- * I want something that looks like ocaml function but at the UNIX 
- * command line level. So natural to have this scheme instead of 
+ * convulated scheme ...) Why not use Arg.String action such as
+ * "-parse_c", Arg.String (fun file -> ...) ?
+ * I want something that looks like ocaml function but at the UNIX
+ * command line level. So natural to have this scheme instead of
  * -taxo_file arg2 -sample_file arg3 -parse_c arg1.
- * 
- * 
- * Why not use the toplevel ? 
+ *
+ *
+ * Why not use the toplevel ?
  * - because to debug, ocamldebug is far superior to the toplevel
  *   (can go back, can go directly to a specific point, etc).
- *   I want a kind of testing at cmdline level. 
- * - Also I don't have file completion when in the ocaml toplevel. 
+ *   I want a kind of testing at cmdline level.
+ * - Also I don't have file completion when in the ocaml toplevel.
  *   I have to type "/path/to/xxx" without help.
- * 
- * 
- * Why having variable flags ? Why use 'if !verbose_parsing then ...' ? 
+ *
+ *
+ * Why having variable flags ? Why use 'if !verbose_parsing then ...' ?
  * why not use strings and do stuff like the following
  * 'if (get_config "verbose_parsing") then ...'
  * Because I want to make the interface for flags easier for the code
  * that use it. The programmer should not be bothered wether this
- * flag is set via args cmd line or a config file, so I want to make it 
+ * flag is set via args cmd line or a config file, so I want to make it
  * as simple as possible, just use a global plain caml ref variable.
- * 
+ *
  * Same spirit a little for the action. Instead of having function such as
  * test_parsing_c, I could do it only via string. But I still prefer
  * to have plain caml test functions. Also it makes it easier to call
  * those functions from a toplevel for people who prefer the toplevel.
- * 
- * 
- * So have flag_spec and action_spec. And in flag have debug_xxx flags, 
+ *
+ *
+ * So have flag_spec and action_spec. And in flag have debug_xxx flags,
  * verbose_xxx flags and other flags.
- * 
+ *
  * I would like to not have to separate the -xxx actions spec from the
  * corresponding actions, but those actions may need more than one argument
  * and so have to wait for parse_options, which in turn need the options
- * spec, so circle. 
- * 
+ * spec, so circle.
+ *
  * Also I dont want to mix code with data structures, so it's better that the
  * options variable contain just a few stuff and have no side effects except
  * setting global variables.
- * 
+ *
  * Why not have a global variable such as Common.actions that
  * other modules modify ? No, I prefer to do less stuff behind programmer's
  * back so better to let the user merge the different options at call
  * site, but at least make it easier by providing shortcut for set of options.
- * 
- * 
- * 
- * 
+ *
+ *
+ *
+ *
  * todo? isn't unison or scott-mcpeak-lib-in-cil handles that kind of
  * stuff better ? That is the need to localize command line argument
  * while still being able to gathering them. Same for logging.
  * Similiar to the type prof = PALL | PNONE | PSOME of string list.
  * Same spirit of fine grain config in log4j ?
- * 
+ *
  * todo? how mercurial/cvs/git manage command line options ? because they
  * all have a kind of DSL around arguments with some common options,
  * specific options, conventions, etc.
- * 
- * 
- * todo? generate the corresponding noxxx options ? 
+ *
+ *
+ * todo? generate the corresponding noxxx options ?
  * todo? generate list of options and show their value ?
- * 
- * todo? make it possible to set this value via a config file ? 
- * 
- * 
+ *
+ * todo? make it possible to set this value via a config file ?
+ *
+ *
  *)
 
 type arg_spec_full = Arg.key * Arg.spec * Arg.doc
@@ -1507,7 +1585,7 @@ type cmdline_sections = options_with_title list
 
 (* ---------------------------------------------------------------------- *)
 
-(* now I use argv as I like at the call sites to show that 
+(* now I use argv as I like at the call sites to show that
  * this function internally use argv.
  *)
 let parse_options options usage_msg argv =
@@ -1524,7 +1602,7 @@ let parse_options options usage_msg argv =
 
 
 
-let usage usage_msg options  = 
+let usage usage_msg options  =
   Arg.usage (Arg.align options) usage_msg
 
 
@@ -1535,21 +1613,21 @@ let arg_align2 xs =
   Arg.align xs +> List.rev +> drop 2 +> List.rev
 
 
-let short_usage usage_msg  ~short_opt = 
+let short_usage usage_msg  ~short_opt =
   usage usage_msg short_opt
 
-let long_usage  usage_msg  ~short_opt ~long_opt  = 
+let long_usage  usage_msg  ~short_opt ~long_opt  =
   pr usage_msg;
   pr "";
-  let all_options_with_title = 
+  let all_options_with_title =
     (("main options", "", short_opt)::long_opt) in
-  all_options_with_title +> List.iter 
-    (fun (title, explanations, xs) -> 
+  all_options_with_title +> List.iter
+    (fun (title, explanations, xs) ->
       pr title;
       pr_xxxxxxxxxxxxxxxxx();
-      if explanations <> "" 
+      if explanations <> ""
       then begin pr explanations; pr "" end;
-      arg_align2 xs +> List.iter (fun (key,action,s) -> 
+      arg_align2 xs +> List.iter (fun (key,action,s) ->
         pr ("  " ^ key ^ s)
       );
       pr "";
@@ -1562,7 +1640,7 @@ let arg_parse2 l msg short_usage_fun =
   let args = ref [] in
   let f = (fun file -> args := file::!args) in
   let l = Arg.align l in
-  (try begin 
+  (try begin
     Arg.parse_argv Sys.argv l f msg;
     args := List.rev !args;
     !args
@@ -1575,93 +1653,93 @@ let arg_parse2 l msg short_usage_fun =
       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 *)
   )
 
 
 (* ---------------------------------------------------------------------- *)
-(* kind of unit testing framework, or toplevel like functionnality 
+(* kind of unit testing framework, or toplevel like functionnality
  * at shell command line. I realize than in fact It follows a current trend
- * to have a main cmdline program where can then select different actions, 
+ * to have a main cmdline program where can then select different actions,
  * as in cvs/hg/git where do  hg <action> <arguments>, and the shell even
  * use a curried syntax :)
- * 
- * 
+ *
+ *
  * Not-perfect-but-basic-feels-right: an action
  * spec looks like this:
- * 
+ *
  *    let actions () = [
- *      "-parse_taxo", "   <file>", 
+ *      "-parse_taxo", "   <file>",
  *      Common.mk_action_1_arg test_parse_taxo;
  *      ...
  *     ]
- * 
+ *
  * Not-perfect-but-basic-feels-right because for such functionality we
  * need a way to transform a string into a caml function and pass arguments
  * and the preceding design does exactly that, even if then the
  * functions that use this design are not so convenient to use (there
  * are 2 places where we need to pass those data, in the options and in the
- * main dispatcher). 
- * 
+ * main dispatcher).
+ *
  * Also it's not too much intrusive. Still have an
- * action ref variable in the main.ml and can still use the previous 
+ * action ref variable in the main.ml and can still use the previous
  * simpler way to do where the match args with in main.ml do the
  * dispatch.
- * 
- * Use like this at option place: 
+ *
+ * Use like this at option place:
  *   (Common.options_of_actions actionref (Test_parsing_c.actions())) ++
- * Use like this at dispatch action place: 
- *   | xs when List.mem !action (Common.action_list all_actions) -> 
+ * Use like this at dispatch action place:
+ *   | xs when List.mem !action (Common.action_list all_actions) ->
  *        Common.do_action !action xs all_actions
- * 
+ *
  *)
 
 type flag_spec   = Arg.key * Arg.spec * Arg.doc
-type action_spec = Arg.key * Arg.doc * action_func 
+type action_spec = Arg.key * Arg.doc * action_func
    and action_func = (string list -> unit)
 
 type cmdline_actions = action_spec list
 exception WrongNumberOfArguments
 
-let options_of_actions action_ref actions = 
-  actions +> List.map (fun (key, doc, _func) -> 
+let options_of_actions action_ref actions =
+  actions +> List.map (fun (key, doc, _func) ->
     (key, (Arg.Unit (fun () -> action_ref := key)), doc)
   )
-    
-let (action_list: cmdline_actions -> Arg.key list) = fun xs -> 
-  List.map (fun (a,b,c) -> a) xs 
+
+let (action_list: cmdline_actions -> Arg.key list) = fun xs ->
+  List.map (fun (a,b,c) -> a) xs
 
 let (do_action: Arg.key -> string list (* args *) -> cmdline_actions -> unit) =
-  fun key args xs -> 
+  fun key args xs ->
     let assoc = xs +> List.map (fun (a,b,c) -> (a,c)) in
     let action_func = List.assoc key assoc in
     action_func args
 
 
-(* todo? if have a function with default argument ? would like a 
- *  mk_action_0_or_1_arg ? 
+(* todo? if have a function with default argument ? would like a
+ *  mk_action_0_or_1_arg ?
  *)
 
-let mk_action_0_arg f = 
-  (function 
+let mk_action_0_arg f =
+  (function
   | [] -> f ()
   | _ -> raise WrongNumberOfArguments
   )
 
-let mk_action_1_arg f = 
-  (function 
+let mk_action_1_arg f =
+  (function
   | [file] -> f file
   | _ -> raise WrongNumberOfArguments
   )
 
-let mk_action_2_arg f = 
-  (function 
+let mk_action_2_arg f =
+  (function
   | [file1;file2] -> f file1 file2
   | _ -> raise WrongNumberOfArguments
   )
 
-let mk_action_3_arg f = 
-  (function 
+let mk_action_3_arg f =
+  (function
   | [file1;file2;file3] -> f file1 file2 file3
   | _ -> raise WrongNumberOfArguments
   )
@@ -1691,7 +1769,7 @@ let (=:=) : bool   -> bool   -> bool = (=)
 
 (* the evil generic (=). I define another symbol to more easily detect
  * it, cos the '=' sign is syntaxically overloaded in caml. It is also
- * used to define function. 
+ * used to define function.
  *)
 let (=*=) = (=)
 
@@ -1734,8 +1812,8 @@ let string_of_char c = String.make 1 c
 let is_single  = String.contains ",;()[]{}_`"
 let is_symbol  = String.contains "!@#$%&*+./<=>?\\^|:-~"
 let is_space   = String.contains "\n\t "
-let cbetween min max c = 
-  (int_of_char c) <= (int_of_char max) && 
+let cbetween min max c =
+  (int_of_char c) <= (int_of_char max) &&
   (int_of_char c) >= (int_of_char min)
 let is_upper = cbetween 'A' 'Z'
 let is_lower = cbetween 'a' 'z'
@@ -1753,7 +1831,7 @@ let string_of_chars cs = cs +> List.map (String.make 1) +> String.concat ""
 (* since 3.08, div by 0 raise Div_by_rezo, and not anymore a hardware trap :)*)
 let (/!) x y = if y =|= 0 then (log "common.ml: div by 0"; 0) else x / y
 
-(* now in prelude 
+(* now in prelude
  * let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
  * if i = 0 then () else (f(); do_n (i-1) f)
  *)
@@ -1785,25 +1863,25 @@ let rec power x n = if n =|= 0 then 1 else x * power x (n-1)
 
 let between i min max = i > min && i < max
 
-let (between_strict: int -> int -> int -> bool) = fun a b c -> 
+let (between_strict: int -> int -> int -> bool) = fun a b c ->
   a < b && b < c
 
 
 let bitrange x p = let v = power 2 p in between x (-v) v
 
 (* descendant *)
-let (prime1: int -> int option)  = fun x -> 
-  let rec prime1_aux n = 
+let (prime1: int -> int option)  = fun x ->
+  let rec prime1_aux n =
     if n =|= 1 then None
-    else 
+    else
       if (x / n) * n =|= x then Some n else prime1_aux (n-1)
   in if x =|= 1 then None else if x < 0 then failwith "negative" else prime1_aux (x-1)
 
 (* montant, better *)
-let (prime: int -> int option)  = fun x -> 
-  let rec prime_aux n = 
+let (prime: int -> int option)  = fun x ->
+  let rec prime_aux n =
     if n =|= x then None
-    else 
+    else
       if (x / n) * n =|= x then Some n else prime_aux (n+1)
   in if x =|= 1 then None else if x < 0 then failwith "negative" else prime_aux 2
 
@@ -1811,14 +1889,14 @@ let sum xs = List.fold_left (+) 0 xs
 let product = List.fold_left ( * ) 1
 
 
-let decompose x = 
-  let rec decompose x = 
+let decompose x =
+  let rec decompose x =
   if x =|= 1 then []
-  else 
+  else
     (match prime x with
     | None -> [x]
     | Some n -> n::decompose (x / n)
-    ) 
+    )
   in assert (product (decompose x) =|= x); decompose x
 
 let mysquare x = x * x
@@ -1832,11 +1910,11 @@ let (<==>) a b = if a =*= b then 0 else if a < b then -1 else 1
 type uint = int
 
 
-let int_of_stringchar s = 
+let int_of_stringchar s =
   fold_left_with_index (fun acc e i -> acc + (Char.code e*(power 8 i))) 0 (List.rev (list_of_string s))
 
-let int_of_base s base = 
-  fold_left_with_index (fun acc e i -> 
+let int_of_base s base =
+  fold_left_with_index (fun acc e i ->
     let j = Char.code e - Char.code '0' in
     if j >= base then failwith "not in good base"
     else acc + (j*(power base i))
@@ -1851,7 +1929,7 @@ let _ = example (int_of_octal "017" =|= 15)
 
 (* let int_of_hex s = int_of_base s 16, NONONONO cos 'A' - '0' does not give 10 !! *)
 
-let int_of_all s = 
+let int_of_all s =
   if String.length s >= 2 && (String.get s 0 =<= '0') && is_digit (String.get s 1)
   then int_of_octal s else int_of_string s
 
@@ -1859,24 +1937,24 @@ let int_of_all s =
 let (+=) ref v = ref := !ref + v
 let (-=) ref v = ref := !ref - v
 
-let pourcent x total = 
+let pourcent x total =
   (x * 100) / total
-let pourcent_float x total = 
+let pourcent_float x total =
   ((float_of_int x) *. 100.0) /. (float_of_int total)
 
-let pourcent_float_of_floats x total = 
+let pourcent_float_of_floats x total =
   (x *. 100.0) /. total
 
 
-let pourcent_good_bad good bad = 
+let pourcent_good_bad good bad =
   (good * 100) / (good + bad)
 
-let pourcent_good_bad_float good bad = 
+let pourcent_good_bad_float good bad =
   (float_of_int good *. 100.0) /. (float_of_int good +. float_of_int bad)
 
 type 'a max_with_elem = int ref * 'a ref
-let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) = 
-  if is_better newv aref 
+let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) =
+  if is_better newv aref
   then begin
     aref := newv;
     aelem := newelem;
@@ -1886,10 +1964,10 @@ let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) =
 (* Numeric/overloading *)
 (*****************************************************************************)
 
-type 'a numdict = 
-    NumDict of (('a-> 'a -> 'a) * 
-		('a-> 'a -> 'a) * 
-		('a-> 'a -> 'a) * 
+type 'a numdict =
+    NumDict of (('a-> 'a -> 'a) *
+		('a-> 'a -> 'a) *
+		('a-> 'a -> 'a) *
 		('a -> 'a));;
 
 let add (NumDict(a, m, d, n)) = a;;
@@ -1899,17 +1977,17 @@ let neg (NumDict(a, m, d, n)) = n;;
 
 let numd_int   = NumDict(( + ),( * ),( / ),( ~- ));;
 let numd_float = NumDict(( +. ),( *. ), ( /. ),( ~-. ));;
-let testd dict n = 
-  let ( * ) x y = mul dict x y in 
-  let ( / ) x y = div dict x y in 
-  let ( + ) x y = add dict x y in 
-  (* Now you can define all sorts of things in terms of *, /, + *) 
-  let f num = (num * num) / (num + num) in 
+let testd dict n =
+  let ( * ) x y = mul dict x y in
+  let ( / ) x y = div dict x y in
+  let ( + ) x y = add dict x y in
+  (* Now you can define all sorts of things in terms of *, /, + *)
+  let f num = (num * num) / (num + num) in
   f n;;
 
 
 
-module ArithFloatInfix = struct 
+module ArithFloatInfix = struct
     let (+..) = (+)
     let (-..) = (-)
     let (/..) = (/)
@@ -1989,7 +2067,7 @@ let do_option f = function
   | None -> ()
   | Some x -> f x
 
-let optionise f = 
+let optionise f =
   try Some (f ()) with Not_found -> None
 
 
@@ -2003,12 +2081,22 @@ let some_or = function
 let partition_either f l =
   let rec part_either left right = function
   | [] -> (List.rev left, List.rev right)
-  | x :: l -> 
+  | x :: l ->
       (match f x with
       | Left  e -> part_either (e :: left) right l
       | Right e -> part_either left (e :: right) l) in
   part_either [] [] l
 
+let partition_either3 f l =
+  let rec part_either left middle right = function
+  | [] -> (List.rev left, List.rev middle, List.rev right)
+  | x :: l ->
+      (match f x with
+      | Left3  e -> part_either (e :: left) middle right l
+      | Middle3  e -> part_either left (e :: middle) right l
+      | Right3 e -> part_either left middle (e :: right) l) in
+  part_either [] [] [] l
+
 
 (* pixel *)
 let rec filter_some = function
@@ -2018,15 +2106,26 @@ let rec filter_some = function
 
 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 -> 
+  | x :: l ->
       match p x with
       |	Some v -> v
       |	None -> find_some p l
 
 (* same
-let map_find f xs = 
+let map_find f xs =
   xs +> List.map f +> List.find (function Some x -> true | None -> false)
     +> (function Some x -> x | None -> raise Impossible)
 *)
@@ -2051,21 +2150,21 @@ type bool3 = True3 | False3 | TrueFalsePb3 of string
 (*****************************************************************************)
 
 (* Note: OCaml Str regexps are different from Perl regexp:
- *  - The OCaml regexp must match the entire way. 
- *    So  "testBee" =~ "Bee" is wrong  
+ *  - The OCaml regexp must match the entire way.
+ *    So  "testBee" =~ "Bee" is wrong
  *    but "testBee" =~ ".*Bee" is right
- *    Can have the perl behavior if use  Str.search_forward instead of 
+ *    Can have the perl behavior if use  Str.search_forward instead of
  *    Str.string_match.
- *  - Must add some additional \ in front of some special char. So use 
+ *  - Must add some additional \ in front of some special char. So use
  *    \\( \\|  and also \\b
  *  - It does not always handle newlines very well.
  *  - \\b does consider _ but not numbers in indentifiers.
- * 
+ *
  * Note: PCRE regexps are then different from Str regexps ...
  *  - just use '(' ')' for grouping, not '\\)'
  *  - still need \\b for word boundary, but this time it works ...
  *    so can match some word that have some digits in them.
- * 
+ *
  *)
 
 (* put before String section because String section use some =~ *)
@@ -2073,54 +2172,54 @@ type bool3 = True3 | False3 | TrueFalsePb3 of string
 (* let gsubst = global_replace *)
 
 
-let (==~) s re = Str.string_match re s 0 
+let (==~) s re = Str.string_match re s 0
 
 let _memo_compiled_regexp = Hashtbl.create 101
-let candidate_match_func s re = 
+let candidate_match_func s re =
   (* old: Str.string_match (Str.regexp re) s 0 *)
-  let compile_re = 
-    memoized _memo_compiled_regexp re (fun () -> Str.regexp re) 
+  let compile_re =
+    memoized _memo_compiled_regexp re (fun () -> Str.regexp re)
   in
   Str.string_match compile_re s 0
 
-let match_func s re = 
+let match_func s re =
   profile_code "Common.=~" (fun () -> candidate_match_func s re)
 
-let (=~) s re = 
+let (=~) s re =
   match_func s re
 
 
 
 
 
-let string_match_substring re s = 
-  try let _i = Str.search_forward re s 0 in true 
+let string_match_substring re s =
+  try let _i = Str.search_forward re s 0 in true
   with Not_found -> false
 
-let _ = 
+let _ =
   example(string_match_substring (Str.regexp "foo") "a foo b")
-let _ = 
+let _ =
   example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b")
-let _ = 
+let _ =
   example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b")
-let _ = 
+let _ =
   example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b")
-(* does not work :( 
-let _ = 
+(* does not work :(
+let _ =
   example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b")
 *)
 
 
 
-let (regexp_match: string -> string -> string) = fun s re -> 
+let (regexp_match: string -> string -> string) = fun s re ->
   assert(s =~ re);
   Str.matched_group 1 s
 
 (* beurk, side effect code, but hey, it is convenient *)
 (* now in prelude
- * let (matched: int -> string -> string) = fun i s -> 
+ * let (matched: int -> string -> string) = fun i s ->
  *    Str.matched_group i s
- * 
+ *
  * let matched1 = fun s -> matched 1 s
  * let matched2 = fun s -> (matched 1 s, matched 2 s)
  * let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s)
@@ -2147,12 +2246,12 @@ let (split_list_regexp: string -> string list -> (string * string list) list) =
  fun re xs ->
   let rec split_lr_aux (heading, accu) = function
     | [] -> [(heading, List.rev accu)]
-    | x::xs -> 
-        if x =~ re 
+    | x::xs ->
+        if x =~ re
         then (heading, List.rev accu)::split_lr_aux (x, []) xs
         else split_lr_aux (heading, x::accu) xs
   in
-  split_lr_aux ("__noheading__", []) xs 
+  split_lr_aux ("__noheading__", []) xs
   +> (fun xs -> if (List.hd xs) =*= ("__noheading__",[]) then List.tl xs else xs)
 
 
@@ -2161,10 +2260,10 @@ let regexp_alpha =  Str.regexp
   "^[a-zA-Z_][A-Za-z_0-9]*$"
 
 
-let all_match re s = 
+let all_match re s =
   let regexp = Str.regexp re in
   let res = ref [] in
-  let _ = Str.global_substitute regexp (fun _s -> 
+  let _ = Str.global_substitute regexp (fun _s ->
     let substr = Str.matched_string s in
     assert(substr ==~ regexp); (* @Effect: also use it's side effect *)
     let paren_matched = matched1 substr in
@@ -2173,27 +2272,27 @@ let all_match re s =
   ) s in
   List.rev !res
 
-let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment" 
+let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment"
                   =*= ["@Et";"@Comment"])
 
 
-let global_replace_regexp re f_on_substr s = 
+let global_replace_regexp re f_on_substr s =
   let regexp = Str.regexp re in
-  Str.global_substitute regexp (fun _wholestr -> 
+  Str.global_substitute regexp (fun _wholestr ->
 
     let substr = Str.matched_string s in
     f_on_substr substr
   ) s
 
 
-let regexp_word_str = 
+let regexp_word_str =
   "\\([a-zA-Z_][A-Za-z_0-9]*\\)"
 let regexp_word = Str.regexp regexp_word_str
 
-let regular_words s = 
+let regular_words s =
   all_match regexp_word_str s
 
-let contain_regular_word s = 
+let contain_regular_word s =
   let xs = regular_words s in
   List.length xs >= 1
 
@@ -2214,8 +2313,8 @@ let s_to_i = int_of_string
 (* strings take space in memory. Better when can share the space used by
    similar strings *)
 let _shareds = Hashtbl.create 100
-let (shared_string: string -> string) = fun s -> 
-  try Hashtbl.find _shareds s 
+let (shared_string: string -> string) = fun s ->
+  try Hashtbl.find _shareds s
   with Not_found -> (Hashtbl.add _shareds s s; s)
 
 let chop = function
@@ -2228,42 +2327,42 @@ let chop_dirsymbol = function
   | s -> s
 
 
-let (<!!>) s (i,j) = 
+let (<!!>) s (i,j) =
   String.sub s i (if j < 0 then String.length s - i + j + 1 else j - i)
 (* let _ = example  ( "tototati"<!!>(3,-2) = "otat" ) *)
 
-let (<!>) s i = String.get s i 
+let (<!>) s i = String.get s i
 
 (* pixel *)
 let rec split_on_char c s =
   try
     let sp = String.index s c in
-    String.sub s 0 sp :: 
+    String.sub s 0 sp ::
     split_on_char c (String.sub s (sp+1) (String.length s - sp - 1))
   with Not_found -> [s]
 
 
 let lowercase = String.lowercase
 
-let quote s = "\"" ^ s ^ "\""  
+let quote s = "\"" ^ s ^ "\""
 
 (* easier to have this to be passed as hof, because ocaml dont have
  * haskell "section" operators
  *)
-let null_string s = 
-  s =$= "" 
+let null_string s =
+  s =$= ""
 
-let is_blank_string s = 
+let is_blank_string s =
   s =~ "^\\([ \t]\\)*$"
 
 (* src: lablgtk2/examples/entrycompletion.ml *)
 let is_string_prefix s1 s2 =
-  (String.length s1 <= String.length s2) && 
+  (String.length s1 <= String.length s2) &&
   (String.sub s2 0 (String.length s1) =$= s1)
 
-let plural i s = 
+let plural i s =
   if i =|= 1
-  then Printf.sprintf "%d %s" i s 
+  then Printf.sprintf "%d %s" i s
   else Printf.sprintf "%d %ss" i s
 
 let showCodeHex xs = List.iter (fun i -> printf "%02x" i) xs
@@ -2271,7 +2370,7 @@ let showCodeHex xs = List.iter (fun i -> printf "%02x" i) xs
 let take_string n s =
   String.sub s 0 (n-1)
 
-let take_string_safe n s = 
+let take_string_safe n s =
   if n > String.length s
   then s
   else take_string n s
@@ -2279,30 +2378,30 @@ let take_string_safe n s =
 
 
 (* used by LFS *)
-let size_mo_ko i = 
+let size_mo_ko i =
   let ko = (i / 1024) mod 1024 in
   let mo = (i / 1024) / 1024 in
-  (if mo > 0 
+  (if mo > 0
   then sprintf "%dMo%dKo" mo ko
   else sprintf "%dKo" ko
   )
 
-let size_ko i = 
+let size_ko i =
   let ko = i / 1024 in
   sprintf "%dKo" ko
 
 
 
- 
 
 
-(* done in summer 2007 for julia 
+
+(* done in summer 2007 for julia
  * Reference: P216 of gusfeld book
  * For two strings S1 and S2, D(i,j) is defined to be the edit distance of S1[1..i] to S2[1..j]
  * So edit distance of S1 (of length n) and S2 (of length m) is D(n,m)
- * 
+ *
  * Dynamic programming technique
- * base: 
+ * base:
  * D(i,0) = i  for all i (cos to go from S1[1..i] to 0 characteres of S2 you have to delete all characters from S1[1..i]
  * D(0,j) = j  for all j (cos j characters must be inserted)
  * recurrence:
@@ -2310,23 +2409,23 @@ let size_ko i =
  * where t(i,j) is equal to 1 if S1(i) != S2(j) and  0 if equal
  * intuition = there is 4 possible action =  deletion, insertion, substitution, or match
  * so Lemma =
- * 
+ *
  * D(i,j) must be one of the three
  *  D(i, j-1) + 1
- *  D(i-1, j)+1 
- *  D(i-1, j-1) + 
- *  t(i,j) 
- * 
- * 
+ *  D(i-1, j)+1
+ *  D(i-1, j-1) +
+ *  t(i,j)
+ *
+ *
  *)
-let matrix_distance s1 s2 = 
+let matrix_distance s1 s2 =
   let n = (String.length s1) in
-  let m = (String.length s2) in 
+  let m = (String.length s2) in
   let mat = Array.make_matrix (n+1) (m+1) 0 in
-  let t i j = 
+  let t i j =
     if String.get s1 (i-1) =<= String.get s2 (j-1)
     then 0
-    else 1 
+    else 1
   in
   let min3 a b c = min (min a b) c in
 
@@ -2339,13 +2438,13 @@ let matrix_distance s1 s2 =
     done;
     for i = 1 to n do
       for j = 1 to m do
-        mat.(i).(j) <- 
+        mat.(i).(j) <-
           min3 (mat.(i).(j-1) + 1) (mat.(i-1).(j) + 1) (mat.(i-1).(j-1) + t i j)
       done
     done;
     mat
   end
-let edit_distance s1 s2 = 
+let edit_distance s1 s2 =
   (matrix_distance s1 s2).(String.length s1).(String.length s2)
 
 
@@ -2371,9 +2470,9 @@ module BasicType = struct
 end
 
 
-let (filesuffix: filename -> string) = fun s -> 
+let (filesuffix: filename -> string) = fun s ->
   (try regexp_match s ".+\\.\\([a-zA-Z0-9_]+\\)$" with _ ->  "NOEXT")
-let (fileprefix: filename -> string) = fun s -> 
+let (fileprefix: filename -> string) = fun s ->
   (try regexp_match s "\\(.+\\)\\.\\([a-zA-Z0-9_]+\\)?$" with _ ->  s)
 
 let _ = example (filesuffix "toto.c" =$= "c")
@@ -2387,8 +2486,8 @@ let () = example "without"
     (withoutExtension "toto.s.toto" = "toto")
 *)
 
-let adjust_ext_if_needed filename ext = 
-  if String.get ext 0 <> '.' 
+let adjust_ext_if_needed filename ext =
+  if String.get ext 0 <> '.'
   then failwith "I need an extension such as .c not just c";
 
   if not (filename =~ (".*\\" ^ ext))
@@ -2397,34 +2496,34 @@ let adjust_ext_if_needed filename ext =
 
 
 
-let db_of_filename file = 
+let db_of_filename file =
   dirname file, basename file
 
-let filename_of_db (basedir, file) = 
+let filename_of_db (basedir, file) =
   Filename.concat basedir file
 
 
 
-let dbe_of_filename file = 
+let dbe_of_filename file =
   (* raise Invalid_argument if no ext, so safe to use later the unsafe
    * fileprefix and filesuffix functions.
    *)
-  ignore(Filename.chop_extension file); 
-  Filename.dirname file, 
-  Filename.basename file +> fileprefix, 
+  ignore(Filename.chop_extension file);
+  Filename.dirname file,
+  Filename.basename file +> fileprefix,
   Filename.basename file +> filesuffix
 
-let filename_of_dbe (dir, base, ext) = 
+let filename_of_dbe (dir, base, ext) =
   Filename.concat dir (base ^ "." ^ ext)
 
 
-let dbe_of_filename_safe file = 
+let dbe_of_filename_safe file =
   try Left (dbe_of_filename file)
-  with Invalid_argument _ -> 
+  with Invalid_argument _ ->
     Right (Filename.dirname file, Filename.basename file)
 
 
-let dbe_of_filename_nodot file = 
+let dbe_of_filename_nodot file =
   let (d,b,e) = dbe_of_filename file in
   let d = if d =$= "." then "" else d in
   d,b,e
@@ -2433,18 +2532,18 @@ let dbe_of_filename_nodot file =
 
 
 
-let replace_ext file oldext newext = 
+let replace_ext file oldext newext =
   let (d,b,e) = dbe_of_filename file in
   assert(e =$= oldext);
   filename_of_dbe (d,b,newext)
 
 
-let normalize_path file = 
+let normalize_path file =
   let (dir, filename) = Filename.dirname file, Filename.basename file in
   let xs = split "/" dir in
   let rec aux acc = function
     | [] -> List.rev acc
-    | x::xs -> 
+    | x::xs ->
         (match x with
         | "." -> aux acc xs
         | ".." -> aux (List.tl acc) xs
@@ -2457,9 +2556,9 @@ let normalize_path file =
 
 
 (*
-let relative_to_absolute s = 
+let relative_to_absolute s =
   if Filename.is_relative s
-  then 
+  then
     begin
       let old = Sys.getcwd () in
       Sys.chdir s;
@@ -2470,7 +2569,7 @@ let relative_to_absolute s =
   else s
 *)
 
-let relative_to_absolute s = 
+let relative_to_absolute s =
   if Filename.is_relative s
   then Sys.getcwd () ^ "/" ^ s
   else s
@@ -2480,19 +2579,19 @@ let is_absolute s = not (is_relative s)
 
 
 (* @Pre: prj_path must not contain regexp symbol *)
-let filename_without_leading_path prj_path s = 
+let filename_without_leading_path prj_path s =
   let prj_path = chop_dirsymbol prj_path in
   if s =~ ("^" ^ prj_path ^ "/\\(.*\\)$")
   then matched1 s
-  else 
-    failwith 
+  else
+    failwith
       (spf "cant find filename_without_project_path: %s  %s" prj_path s)
 
 
 (*****************************************************************************)
 (* i18n *)
 (*****************************************************************************)
-type langage = 
+type langage =
   | English
   | Francais
   | Deutsch
@@ -2506,7 +2605,7 @@ type langage =
 
 (* maybe I should use ocamlcalendar, but I don't like all those functors ... *)
 
-type month = 
+type month =
   | Jan  | Feb  | Mar  | Apr  | May  | Jun
   | Jul  | Aug  | Sep  | Oct  | Nov  | Dec
 type year = Year of int
@@ -2534,10 +2633,10 @@ type float_time = float
 
 
 
-let check_date_dmy (DMY (day, month, year)) = 
+let check_date_dmy (DMY (day, month, year)) =
   raise Todo
 
-let check_time_dmy (TimeDMY (day, month, year)) = 
+let check_time_dmy (TimeDMY (day, month, year)) =
   raise Todo
 
 let check_time_hms (HMS (x,y,a)) =
@@ -2548,7 +2647,7 @@ let check_time_hms (HMS (x,y,a)) =
 (* ---------------------------------------------------------------------- *)
 
 (* older code *)
-let int_to_month i = 
+let int_to_month i =
   assert (i <= 12 && i >= 1);
   match i with
 
@@ -2578,7 +2677,7 @@ let int_to_month i =
   | 11 -> "November"
   | 12 -> "December"
 *)
-  | _ -> raise Impossible
+  | _ -> raise (Impossible 2)
 
 
 let month_info = [
@@ -2606,64 +2705,64 @@ let week_day_info = [
   6 , Saturday  , "Sat" ,"Sam"  , "Saturday";
 ]
 
-let i_to_month_h = 
+let i_to_month_h =
   month_info +> List.map (fun (i,month,monthstr,mlong,days) -> i, month)
-let s_to_month_h = 
+let s_to_month_h =
   month_info +> List.map (fun (i,month,monthstr,mlong,days) -> monthstr, month)
-let slong_to_month_h = 
+let slong_to_month_h =
   month_info +> List.map (fun (i,month,monthstr,mlong,days) -> mlong, month)
-let month_to_s_h = 
+let month_to_s_h =
   month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, monthstr)
-let month_to_i_h = 
+let month_to_i_h =
   month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, i)
 
-let i_to_wday_h = 
+let i_to_wday_h =
   week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> i, day)
 let wday_to_en_h =
   week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayen)
 let wday_to_fr_h =
   week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayfr)
 
-let month_of_string s = 
+let month_of_string s =
   List.assoc s s_to_month_h
 
-let month_of_string_long s = 
+let month_of_string_long s =
   List.assoc s slong_to_month_h
 
-let string_of_month s = 
+let string_of_month s =
   List.assoc s month_to_s_h
 
-let month_of_int i = 
+let month_of_int i =
   List.assoc i i_to_month_h
 
-let int_of_month m = 
+let int_of_month m =
   List.assoc m month_to_i_h
 
 
-let wday_of_int i = 
+let wday_of_int i =
   List.assoc i i_to_wday_h
 
-let string_en_of_wday wday = 
+let string_en_of_wday wday =
   List.assoc wday wday_to_en_h
-let string_fr_of_wday wday = 
+let string_fr_of_wday wday =
   List.assoc wday wday_to_fr_h
 
 (* ---------------------------------------------------------------------- *)
 
-let wday_str_of_int ~langage i = 
+let wday_str_of_int ~langage i =
   let wday = wday_of_int i in
   match langage with
   | English -> string_en_of_wday wday
   | Francais -> string_fr_of_wday wday
   | Deutsch -> raise Todo
-  
 
 
-let string_of_date_dmy (DMY (Day n, month, Year y)) = 
+
+let string_of_date_dmy (DMY (Day n, month, Year y)) =
   (spf "%02d-%s-%d" n (string_of_month month) y)
 
 
-let string_of_unix_time ?(langage=English) tm = 
+let string_of_unix_time ?(langage=English) tm =
   let y = tm.Unix.tm_year + 1900 in
   let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in
   let d = tm.Unix.tm_mday in
@@ -2672,24 +2771,24 @@ let string_of_unix_time ?(langage=English) tm =
   let s = tm.Unix.tm_sec in
 
   let wday = wday_str_of_int ~langage tm.Unix.tm_wday in
-  
+
   spf "%02d/%03s/%04d (%s) %02d:%02d:%02d" d mon y wday h min s
 
 (* ex: 21/Jul/2008 (Lun) 21:25:12 *)
-let unix_time_of_string s = 
-  if s =~ 
+let unix_time_of_string s =
+  if s =~
     ("\\([0-9][0-9]\\)/\\(...\\)/\\([0-9][0-9][0-9][0-9]\\) " ^
      "\\(.*\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)")
   then
     let (sday, smonth, syear, _sday, shour, smin, ssec) = matched7 s in
 
     let y = s_to_i syear - 1900 in
-    let mon = 
+    let mon =
       smonth +> month_of_string +> int_of_month +> (fun i -> i -1)
     in
 
     let tm = Unix.localtime (Unix.time ()) in
-    { tm with 
+    { tm with
       Unix.tm_year = y;
       Unix.tm_mon = mon;
       Unix.tm_mday = s_to_i sday;
@@ -2701,7 +2800,7 @@ let unix_time_of_string s =
 
 
 
-let short_string_of_unix_time ?(langage=English) tm = 
+let short_string_of_unix_time ?(langage=English) tm =
   let y = tm.Unix.tm_year + 1900 in
   let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in
   let d = tm.Unix.tm_mday in
@@ -2710,36 +2809,36 @@ let short_string_of_unix_time ?(langage=English) tm =
   let _s = tm.Unix.tm_sec in
 
   let wday = wday_str_of_int ~langage tm.Unix.tm_wday in
-  
+
   spf "%02d/%03s/%04d (%s)" d mon y wday
 
 
-let string_of_unix_time_lfs time = 
-  spf "%02d--%s--%d" 
-    time.Unix.tm_mday 
-    (int_to_month (time.Unix.tm_mon + 1)) 
+let string_of_unix_time_lfs time =
+  spf "%02d--%s--%d"
+    time.Unix.tm_mday
+    (int_to_month (time.Unix.tm_mon + 1))
     (time.Unix.tm_year + 1900)
 
 
 (* ---------------------------------------------------------------------- *)
-let string_of_floattime ?langage i = 
+let string_of_floattime ?langage i =
   let tm = Unix.localtime i in
   string_of_unix_time ?langage tm
 
-let short_string_of_floattime ?langage i = 
+let short_string_of_floattime ?langage i =
   let tm = Unix.localtime i in
   short_string_of_unix_time ?langage tm
 
-let floattime_of_string s = 
+let floattime_of_string s =
   let tm = unix_time_of_string s in
   let (sec,_tm) = Unix.mktime tm in
   sec
 
 
 (* ---------------------------------------------------------------------- *)
-let days_in_week_of_day day = 
-  let tm = Unix.localtime day in 
-  
+let days_in_week_of_day day =
+  let tm = Unix.localtime day in
+
   let wday = tm.Unix.tm_wday in
   let wday = if wday =|= 0 then 6 else wday -1 in
 
@@ -2748,27 +2847,27 @@ let days_in_week_of_day day =
   let start_d = mday - wday in
   let end_d = mday + (6 - wday) in
 
-  enum start_d end_d +> List.map (fun mday -> 
+  enum start_d end_d +> List.map (fun mday ->
     Unix.mktime {tm with Unix.tm_mday = mday} +> fst
   )
 
-let first_day_in_week_of_day day = 
+let first_day_in_week_of_day day =
   List.hd (days_in_week_of_day day)
 
-let last_day_in_week_of_day day = 
+let last_day_in_week_of_day day =
   last (days_in_week_of_day day)
 
 
 (* ---------------------------------------------------------------------- *)
 
 (* (modified) copy paste from ocamlcalendar/src/date.ml *)
-let days_month = 
+let days_month =
   [| 0;    31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334(*; 365*) |]
 
 
-let rough_days_since_jesus (DMY (Day nday, month, Year year)) = 
-  let n = 
-    nday + 
+let rough_days_since_jesus (DMY (Day nday, month, Year year)) =
+  let n =
+    nday +
       (days_month.(int_of_month month -1)) +
       year * 365
   in
@@ -2776,47 +2875,47 @@ let rough_days_since_jesus (DMY (Day nday, month, Year year)) =
 
 
 
-let is_more_recent d1 d2 = 
+let is_more_recent d1 d2 =
   let (Days n1) = rough_days_since_jesus d1 in
   let (Days n2) = rough_days_since_jesus d2 in
-  (n1 > n2) 
+  (n1 > n2)
 
 
-let max_dmy d1 d2 = 
-  if is_more_recent d1 d2 
+let max_dmy d1 d2 =
+  if is_more_recent d1 d2
   then d1
   else d2
 
-let min_dmy d1 d2 = 
-  if is_more_recent d1 d2 
+let min_dmy d1 d2 =
+  if is_more_recent d1 d2
   then d2
   else d1
 
 
-let maximum_dmy ds = 
+let maximum_dmy ds =
   foldl1 max_dmy ds
 
-let minimum_dmy ds = 
+let minimum_dmy ds =
   foldl1 min_dmy ds
-  
 
 
-let rough_days_between_dates d1 d2 = 
+
+let rough_days_between_dates d1 d2 =
   let (Days n1) = rough_days_since_jesus d1 in
   let (Days n2) = rough_days_since_jesus d2 in
   Days (n2 - n1)
 
-let _ = example 
-  (rough_days_between_dates 
+let _ = example
+  (rough_days_between_dates
       (DMY (Day 7, Jan, Year 1977))
       (DMY (Day 13, Jan, Year 1977)) =*= Days 6)
 
 (* because of rough days, it is a bit buggy, here it should return 1 *)
 (*
 let _ = assert_equal
-  (rough_days_between_dates 
+  (rough_days_between_dates
       (DMY (Day 29, Feb, Year 1977))
-      (DMY (Day 1, Mar , Year 1977))) 
+      (DMY (Day 1, Mar , Year 1977)))
   (Days 1)
 *)
 
@@ -2849,7 +2948,7 @@ let normalize (year,month,day,hour,minute,second) =
 *)
 
 
-let mk_date_dmy day month year = 
+let mk_date_dmy day month year =
   let date = DMY (Day day, month_of_int month, Year year) in
   (* check_date_dmy date *)
   date
@@ -2858,8 +2957,8 @@ let mk_date_dmy day month year =
 (* ---------------------------------------------------------------------- *)
 (* conversion to unix.tm *)
 
-let dmy_to_unixtime (DMY (Day n, month, Year year)) = 
-  let tm = { 
+let dmy_to_unixtime (DMY (Day n, month, Year year)) =
+  let tm = {
     Unix.tm_sec = 0;      (** Seconds 0..60 *)
     tm_min = 0;           (** Minutes 0..59 *)
     tm_hour = 12;           (** Hours 0..23 *)
@@ -2872,22 +2971,22 @@ let dmy_to_unixtime (DMY (Day n, month, Year year)) =
   } in
   Unix.mktime tm
 
-let unixtime_to_dmy tm = 
+let unixtime_to_dmy tm =
   let n = tm.Unix.tm_mday  in
   let month = month_of_int (tm.Unix.tm_mon + 1) in
   let year = tm.Unix.tm_year + 1900 in
- 
+
   DMY (Day n, month, Year year)
 
 
-let unixtime_to_floattime tm = 
+let unixtime_to_floattime tm =
   Unix.mktime tm +> fst
 
-let floattime_to_unixtime sec = 
+let floattime_to_unixtime sec =
   Unix.localtime sec
 
 
-let sec_to_days sec = 
+let sec_to_days sec =
   let minfactor = 60 in
   let hourfactor = 60 * 60 in
   let dayfactor = 60 * 60 * 24 in
@@ -2897,12 +2996,12 @@ let sec_to_days sec =
   let mins  = (sec mod hourfactor) / minfactor in
   let sec = (sec mod 60) in
   (* old:   Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
-  (if days > 0  then plural days "day" ^ " "    else "") ^ 
+  (if days > 0  then plural days "day" ^ " "    else "") ^
   (if hours > 0 then plural hours "hour" ^ " " else "") ^
   (if mins > 0  then plural mins "min"   ^ " " else "") ^
   (spf "%dsec" sec)
 
-let sec_to_hours sec = 
+let sec_to_hours sec =
   let minfactor = 60 in
   let hourfactor = 60 * 60 in
 
@@ -2913,7 +3012,7 @@ let sec_to_hours sec =
   (if hours > 0 then plural hours "hour" ^ " " else "") ^
   (if mins > 0  then plural mins "min"   ^ " " else "") ^
   (spf "%dsec" sec)
-  
+
 
 
 let test_date_1 () =
@@ -2935,12 +3034,12 @@ let lastweek  : unit -> float = fun () ->  (Unix.time () -. (7.0 *. day_secs))
 let lastmonth  : unit -> float = fun () ->  (Unix.time () -. (30.0 *. day_secs))
 
 
-let week_before  : float_time -> float_time = fun d ->  
+let week_before  : float_time -> float_time = fun d ->
   (d -. (7.0 *. day_secs))
-let month_before  : float_time -> float_time = fun d ->  
+let month_before  : float_time -> float_time = fun d ->
   (d -. (30.0 *. day_secs))
 
-let week_after  : float_time -> float_time = fun d ->  
+let week_after  : float_time -> float_time = fun d ->
   (d +. (7.0 *. day_secs))
 
 
@@ -2950,33 +3049,33 @@ let week_after  : float_time -> float_time = fun d ->
 (*****************************************************************************)
 
 (* now in prelude:
- * let (list_of_string: string -> char list) = fun s -> 
+ * let (list_of_string: string -> char list) = fun s ->
  * (enum 0 ((String.length s) - 1) +> List.map (String.get s))
  *)
 
 let _ = example (list_of_string "abcd" =*= ['a';'b';'c';'d'])
 
 (*
-let rec (list_of_stream: ('a Stream.t) -> 'a list) = 
+let rec (list_of_stream: ('a Stream.t) -> 'a list) =
 parser
   | [< 'c ; stream >]  -> c :: list_of_stream stream
   | [<>]               -> []
 
-let (list_of_string: string -> char list) = 
+let (list_of_string: string -> char list) =
   Stream.of_string $ list_of_stream
 *)
 
-(* now in prelude: 
+(* now in prelude:
  * let (lines: string -> string list) = fun s -> ...
  *)
 
-let (lines_with_nl: string -> string list) = fun s -> 
+let (lines_with_nl: string -> string list) = fun s ->
   let rec lines_aux = function
     | [] -> []
     | [x] -> if x =$= "" then [] else [x ^ "\n"] (* old: [x] *)
-    | x::xs -> 
+    | x::xs ->
         let e = x ^ "\n" in
-        e::lines_aux xs 
+        e::lines_aux xs
   in
   (time_func (fun () -> Str.split_delim (Str.regexp "\n") s)) +> lines_aux
 
@@ -2985,29 +3084,29 @@ let (lines_with_nl: string -> string list) = fun s ->
 (* +> List.map (fun s -> s ^ "\n") but add an \n even at the end => lines_aux *)
 (* old: slow
   let chars = list_of_string s in
-  chars +> List.fold_left (fun (acc, lines) char -> 
+  chars +> List.fold_left (fun (acc, lines) char ->
     let newacc = acc ^ (String.make 1 char) in
-    if char = '\n' 
+    if char = '\n'
     then ("", newacc::lines)
     else (newacc, lines)
-    ) ("", []) 
+    ) ("", [])
        +> (fun (s, lines) -> List.rev (s::lines))
 *)
 
 (*  CHECK: unlines (lines x) = x *)
-let (unlines: string list -> string) = fun s -> 
+let (unlines: string list -> string) = fun s ->
   (String.concat "\n" s) ^ "\n"
-let (words: string -> string list)   = fun s -> 
+let (words: string -> string list)   = fun s ->
   Str.split (Str.regexp "[ \t()\";]+") s
-let (unwords: string list -> string) = fun s -> 
+let (unwords: string list -> string) = fun s ->
   String.concat "" s
 
-let (split_space: string -> string list)   = fun s -> 
+let (split_space: string -> string list)   = fun s ->
   Str.split (Str.regexp "[ \t\n]+") s
 
 
 (* todo opti ? *)
-let nblines s = 
+let nblines s =
   lines s +> List.length
 let _ = example (nblines "" =|= 0)
 let _ = example (nblines "toto" =|= 1)
@@ -3018,10 +3117,10 @@ let _ = example (nblines "toto\ntata\n" =|= 2)
 (*****************************************************************************)
 (* Process/Files *)
 (*****************************************************************************)
-let cat_orig file = 
+let cat_orig file =
   let chan = open_in file in
-  let rec cat_orig_aux ()  = 
-    try 
+  let rec cat_orig_aux ()  =
+    try
       (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
       let l = input_line chan in
       l :: cat_orig_aux ()
@@ -3029,34 +3128,34 @@ let cat_orig file =
   cat_orig_aux()
 
 (* tail recursive efficient version *)
-let cat file = 
+let cat file =
   let chan = open_in file in
-  let rec cat_aux acc ()  = 
+  let rec cat_aux acc ()  =
       (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
     let (b, l) = try (true, input_line chan) with End_of_file -> (false, "") in
-    if b 
+    if b
     then cat_aux (l::acc) ()
-    else acc 
+    else acc
   in
   cat_aux [] () +> List.rev +> (fun x -> close_in chan; x)
 
-let cat_array file = 
-  (""::cat file) +> Array.of_list 
+let cat_array file =
+  (""::cat file) +> Array.of_list
 
 
-let interpolate str = 
+let interpolate str =
   begin
     command2 ("printf \"%s\\n\" " ^ str ^ ">/tmp/caml");
     cat "/tmp/caml"
   end
 
 (* could do a print_string but printf dont like print_string *)
-let echo s = printf "%s" s; flush stdout; s 
+let echo s = printf "%s" s; flush stdout; s
 
 let usleep s = for i = 1 to s do () done
 
 let sleep_little () =
-  (*old:  *) 
+  (*old:  *)
   Unix.sleep 1
   (*ignore(Sys.command ("usleep " ^ !_sleep_time))*)
 
@@ -3065,26 +3164,26 @@ let sleep_little () =
  * let command2 s = ignore(Sys.command s)
  *)
 
-let do_in_fork f = 
+let do_in_fork f =
   let pid = Unix.fork () in
   if pid =|= 0
-  then 
-    begin 
+  then
+    begin
       (* Unix.setsid(); *)
-      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ -> 
+      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ ->
         pr2 "being killed";
         Unix.kill 0 Sys.sigkill;
         ));
-      f(); 
+      f();
       exit 0;
     end
   else pid
 
 
-let process_output_to_list2 = fun command -> 
+let process_output_to_list2 = fun command ->
   let chan = Unix.open_process_in command in
   let res = ref ([] : string list) in
-  let rec process_otl_aux () =  
+  let rec process_otl_aux () =
     let e = input_line chan in
     res := e::!res;
     process_otl_aux() in
@@ -3098,11 +3197,11 @@ let cmd_to_list_and_status = process_output_to_list2
 
 (* now in prelude:
  * let command2 s = ignore(Sys.command s)
- *) 
+ *)
 
 
-let _batch_mode = ref false 
-let command2_y_or_no cmd = 
+let _batch_mode = ref false
+let command2_y_or_no cmd =
   if !_batch_mode then begin command2 cmd; true end
   else begin
 
@@ -3113,16 +3212,16 @@ let command2_y_or_no cmd =
     | _ -> failwith "answer by yes or no"
   end
 
-let command2_y_or_no_exit_if_no cmd = 
+let command2_y_or_no_exit_if_no cmd =
   let res = command2_y_or_no cmd in
   if res
   then ()
   else raise (UnixExit (1))
 
-  
 
 
-let mkdir ?(mode=0o770) file = 
+
+let mkdir ?(mode=0o770) file =
   Unix.mkdir file mode
 
 let read_file_orig file = cat file +> unlines
@@ -3135,69 +3234,75 @@ let read_file file =
   buf
 
 
-let write_file ~file s = 
+let write_file ~file s =
   let chan = open_out file in
   (output_string chan s; close_out chan)
 
-let filesize file = 
+let filesize file =
   (Unix.stat file).Unix.st_size
 
-let filemtime file = 
+let filemtime file =
   (Unix.stat file).Unix.st_mtime
 
 (* opti? use wc -l ? *)
-let nblines_file file = 
+let nblines_file file =
   cat file +> List.length
 
-let lfile_exists filename = 
-  try 
+let lfile_exists filename =
+  try
     (match (Unix.lstat filename).Unix.st_kind with
     | (Unix.S_REG | Unix.S_LNK) -> true
     | _ -> false
     )
-  with Unix.Unix_error (Unix.ENOENT, _, _) -> false
-
-let is_directory file = 
+  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
-    
-      
+
+
 (* src: from chailloux et al book *)
-let capsule_unix f args = 
-  try (f args) 
-  with Unix.Unix_error (e, fm, argm) -> 
+let capsule_unix f args =
+  try (f args)
+  with Unix.Unix_error (e, fm, argm) ->
     log (Printf.sprintf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm)
 
 
-let (readdir_to_kind_list: string -> Unix.file_kind -> string list) = 
- fun path kind -> 
-  Sys.readdir path 
-  +> Array.to_list 
-  +> List.filter (fun s -> 
-    try 
+let (readdir_to_kind_list: string -> Unix.file_kind -> string list) =
+ fun path kind ->
+  Sys.readdir path
+  +> Array.to_list
+  +> List.filter (fun s ->
+    try
       let stat = Unix.lstat (path ^ "/" ^  s) in
       stat.Unix.st_kind =*= kind
-    with e -> 
+    with e ->
       pr2 ("EXN pb stating file: " ^ s);
       false
     )
 
-let (readdir_to_dir_list: string -> string list) = fun path -> 
+let (readdir_to_dir_list: string -> string list) = fun path ->
   readdir_to_kind_list path Unix.S_DIR
 
-let (readdir_to_file_list: string -> string list) = fun path -> 
+let (readdir_to_file_list: string -> string list) = fun path ->
   readdir_to_kind_list path Unix.S_REG
 
-let (readdir_to_link_list: string -> string list) = fun path -> 
+let (readdir_to_link_list: string -> string list) = fun path ->
   readdir_to_kind_list path Unix.S_LNK
 
 
-let (readdir_to_dir_size_list: string -> (string * int) list) = fun path -> 
-  Sys.readdir path 
-  +> Array.to_list 
-  +> map_filter (fun s -> 
+let (readdir_to_dir_size_list: string -> (string * int) list) = fun path ->
+  Sys.readdir path
+  +> Array.to_list
+  +> map_filter (fun s ->
     let stat = Unix.lstat (path ^ "/" ^  s) in
-    if stat.Unix.st_kind =*= Unix.S_DIR 
-    then Some (s, stat.Unix.st_size) 
+    if stat.Unix.st_kind =*= Unix.S_DIR
+    then Some (s, stat.Unix.st_size)
     else None
     )
 
@@ -3207,14 +3312,14 @@ let (readdir_to_dir_size_list: string -> (string * int) list) = fun path ->
  * want put the cache_computation funcall in comment, so just easier to
  * pass this extra option.
  *)
-let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f = 
-  if not use_cache 
+let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f =
+  if not use_cache
   then f ()
   else begin
-    if not (Sys.file_exists file) 
+    if not (Sys.file_exists file)
     then failwith ("can't find: "  ^ file);
     let file_cache = (file ^ ext_cache) in
-    if Sys.file_exists file_cache && 
+    if Sys.file_exists file_cache &&
       filemtime file_cache >= filemtime file
     then begin
       if verbose then pr2 ("using cache: " ^ file_cache);
@@ -3226,32 +3331,55 @@ let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f =
       res
     end
   end
-let cache_computation ?verbose ?use_cache a b c = 
-  profile_code "Common.cache_computation" (fun () -> 
+let cache_computation ?verbose ?use_cache a b c =
+  profile_code "Common.cache_computation" (fun () ->
     cache_computation2 ?verbose ?use_cache a b c)
-  
 
-let cache_computation_robust2 
- 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
+let cache_computation_robust2
+ 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 dependencies = 
+  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) 
+    ((file::need_no_changed_files) +> List.map (fun f -> f, filemtime f),
+     need_no_changed_variables)
   in
 
-  if Sys.file_exists dependencies_cache && 
+  if Sys.file_exists dependencies_cache &&
      get_value dependencies_cache =*= dependencies
-  then get_value file_cache
-  else begin 
-    pr2 ("cache computation recompute " ^ file);
+  then
+    (*begin
+    pr2 ("cache computation reuse " ^ file);*)
+    get_value file_cache
+    (*end*)
+  else begin
+    (*pr2 ("cache computation recompute " ^ file);*)
     let res = f () in
     write_value dependencies dependencies_cache;
     write_value res file_cache;
@@ -3259,8 +3387,12 @@ let cache_computation_robust2
   end
 
 let cache_computation_robust a b c d e =
-  profile_code "Common.cache_computation_robust" (fun () -> 
-    cache_computation_robust2 a b c d e)
+  profile_code "Common.cache_computation_robust" (fun () ->
+    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)
 
 
 
@@ -3274,19 +3406,19 @@ let glob pattern =
 
 (* update: have added the -type f, so normally need less the sanity_check_xxx
  * function below *)
-let files_of_dir_or_files ext xs = 
-  xs +> List.map (fun x -> 
+let files_of_dir_or_files ext xs =
+  xs +> List.map (fun x ->
     if is_directory x
     then cmd_to_list ("find " ^ x  ^" -noleaf -type f -name \"*." ^ext^"\"")
     else [x]
   ) +> List.concat
 
 
-let files_of_dir_or_files_no_vcs ext xs = 
-  xs +> List.map (fun x -> 
+let files_of_dir_or_files_no_vcs ext xs =
+  xs +> List.map (fun x ->
     if is_directory x
-    then 
-      cmd_to_list 
+    then
+      cmd_to_list
         ("find " ^ x  ^" -noleaf -type f -name \"*." ^ext^"\"" ^
             "| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
         )
@@ -3294,13 +3426,13 @@ let files_of_dir_or_files_no_vcs ext xs =
   ) +> List.concat
 
 
-let files_of_dir_or_files_no_vcs_post_filter regex xs = 
-  xs +> List.map (fun x -> 
+let files_of_dir_or_files_no_vcs_post_filter regex xs =
+  xs +> List.map (fun x ->
     if is_directory x
-    then 
-      cmd_to_list 
+    then
+      cmd_to_list
         ("find " ^ x  ^
-         " -noleaf -type f | grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/"
+         " -noleaf -type f | grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
         )
         +> List.filter (fun s -> s =~ regex)
     else [x]
@@ -3308,32 +3440,32 @@ let files_of_dir_or_files_no_vcs_post_filter regex xs =
 
 
 let sanity_check_files_and_adjust ext files =
-  let files = files +> List.filter (fun file -> 
+  let files = files +> List.filter (fun file ->
     if not (file =~ (".*\\."^ext))
-    then begin 
+    then begin
       pr2 ("warning: seems not a ."^ext^" file");
       false
     end
-    else 
+    else
       if is_directory file
       then begin
         pr2 (spf "warning: %s is a directory" file);
         false
-      end 
+      end
     else true
   ) in
   files
-        
 
 
-  
+
+
 (* taken from mlfuse, the predecessor of ocamlfuse *)
 type rwx = [`R|`W|`X] list
-let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm = 
+let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm =
  fun ~u ~g ~o ->
-  let to_oct l = 
+  let to_oct l =
     List.fold_left (fun acc p -> acc lor ((function `R -> 4 | `W -> 2 | `X -> 1) p)) 0 l in
-  let perm = 
+  let perm =
     ((to_oct u) lsl 6) lor
     ((to_oct g) lsl 3) lor
     (to_oct o)
@@ -3342,17 +3474,17 @@ let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm =
 
 
 (* pixel *)
-let has_env var = 
-  try 
+let has_env var =
+  try
     let _ = Sys.getenv var in true
   with Not_found -> false
 
 (* emacs/lisp inspiration (eric cooper and yaron minsky use that too) *)
-let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) = 
+let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) =
  fun file f ->
   let chan = open_out file in
   let pr s = output_string chan s in
-  unwind_protect (fun () -> 
+  unwind_protect (fun () ->
     let res = f (pr, chan) in
     close_out chan;
     res)
@@ -3360,18 +3492,18 @@ let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) ->
 
 let (with_open_infile: filename -> ((in_channel) -> 'a) -> 'a) = fun file f ->
   let chan = open_in file in
-  unwind_protect (fun () -> 
+  unwind_protect (fun () ->
     let res = f chan in
     close_in chan;
     res)
     (fun e -> close_in chan)
 
 
-let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) = 
+let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) =
  fun file f ->
   let chan = open_out_gen [Open_creat;Open_append] 0o666 file in
   let pr s = output_string chan s in
-  unwind_protect (fun () -> 
+  unwind_protect (fun () ->
     let res = f (pr, chan) in
     close_out chan;
     res)
@@ -3383,44 +3515,63 @@ let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) ->
  *)
 
 (* it seems that the toplevel block such signals, even with this explicit
- *  command :( 
+ *  command :(
  *  let _ = Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigalrm]
  *)
 
 (* could be in Control section *)
 
-(* subtil: have to make sure that timeout is not intercepted before here, so 
+(* subtil: have to make sure that timeout is not intercepted before here, so
  * avoid exn handle such as try (...) with _ -> cos timeout will not bubble up
- * enough. In such case, add a case before such as  
- * with Timeout -> raise Timeout | _ -> ... 
- * 
- * question: can we have a signal and so exn when in a exn handler ? 
+ * enough. In such case, add a case before such as
+ * with Timeout -> raise Timeout | _ -> ...
+ *
+ * question: can we have a signal and so exn when in a exn handler ?
  *)
-let timeout_function timeoutval = fun f -> 
-  try 
+
+let interval_timer = ref true
+
+let timeout_function timeoutval = fun f ->
+  try
+    if !interval_timer
+    then
+      begin
+        Sys.set_signal Sys.sigvtalrm
+	  (Sys.Signal_handle (fun _ -> raise Timeout));
+	ignore
+	  (Unix.setitimer Unix.ITIMER_VIRTUAL
+             {Unix.it_interval=float_of_int timeoutval;
+               Unix.it_value =float_of_int timeoutval});
+	let x = f() in
+	ignore(Unix.alarm 0);
+	x
+      end
+    else
+      begin
+	Sys.set_signal Sys.sigalrm
+	  (Sys.Signal_handle (fun _ -> raise Timeout ));
+	ignore(Unix.alarm timeoutval);
+	let x = f() in
+	ignore(Unix.alarm 0);
+	x
+      end
+  with Timeout ->
     begin
-      Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout ));
-      ignore(Unix.alarm timeoutval);
-      let x = f() in
-      ignore(Unix.alarm 0);
-      x
-    end
-  with Timeout -> 
-    begin 
       log "timeout (we abort)";
+      (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
       raise Timeout;
     end
-  | e -> 
+  | e ->
      (* subtil: important to disable the alarm before relaunching the exn,
       * otherwise the alarm is still running.
-      * 
-      * robust?: and if alarm launched after the log (...) ? 
+      *
+      * robust?: and if alarm launched after the log (...) ?
       * Maybe signals are disabled when process an exception handler ?
       *)
-      begin 
+      begin
         ignore(Unix.alarm 0);
         (* log ("exn while in transaction (we abort too, even if ...) = " ^
-           Printexc.to_string e); 
+           Printexc.to_string e);
         *)
         log "exn while in timeout_function";
         raise e
@@ -3430,15 +3581,20 @@ let timeout_function_opt timeoutvalopt f =
   match timeoutvalopt with
   | None -> f()
   | 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 *)
 
-let _temp_files_created = ref [] 
+let _temp_files_created = ref ([] : filename list)
 
 (* ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c" *)
-let new_temp_file prefix suffix = 
+let new_temp_file prefix suffix =
   let processid = i_to_s (Unix.getpid ()) in
   let tmp_file = Filename.temp_file (prefix ^ "-" ^ processid ^ "-") suffix in
   push2 tmp_file _temp_files_created;
@@ -3446,25 +3602,33 @@ let new_temp_file prefix suffix =
 
 
 let save_tmp_files = ref false
-let erase_temp_files () = 
+let erase_temp_files () =
   if not !save_tmp_files then begin
-    !_temp_files_created +> List.iter (fun s -> 
+    !_temp_files_created +> List.iter (fun s ->
       (* pr2 ("erasing: " ^ s); *)
-      command2 ("rm -f " ^ s)
+      remove_file s
     );
     _temp_files_created := []
   end
 
+let erase_this_temp_file f =
+  if not !save_tmp_files then begin
+    _temp_files_created :=
+      List.filter (function x -> not (x =$= f)) !_temp_files_created;
+    remove_file f
+  end
+
+
 (* now in prelude: exception UnixExit of int *)
-let exn_to_real_unixexit f = 
-  try f() 
+let exn_to_real_unixexit f =
+  try f()
   with UnixExit x -> exit x
 
 
 
 
-let uncat xs file = 
-  with_open_outfile file (fun (pr,_chan) -> 
+let uncat xs file =
+  with_open_outfile file (fun (pr,_chan) ->
     xs +> List.iter (fun s -> pr s; pr "\n");
 
   )
@@ -3487,29 +3651,29 @@ let safe_tl l = try List.tl l with _ -> []
 let push l v =
   l := v :: !l
 
-let rec zip xs ys = 
+let rec zip xs ys =
   match (xs,ys) with
   | ([],[]) -> []
   | ([],_) -> failwith "zip: not same length"
   | (_,[]) -> failwith "zip: not same length"
   | (x::xs,y::ys) -> (x,y)::zip xs ys
 
-let rec zip_safe xs ys = 
+let rec zip_safe xs ys =
   match (xs,ys) with
   | ([],_) -> []
   | (_,[]) -> []
   | (x::xs,y::ys) -> (x,y)::zip_safe xs ys
 
-let rec unzip zs = 
-  List.fold_right (fun e (xs, ys)    -> 
+let rec unzip zs =
+  List.fold_right (fun e (xs, ys)    ->
     (fst e::xs), (snd e::ys)) zs ([],[])
 
 
-let map_withkeep f xs = 
+let map_withkeep f xs =
   xs +> List.map (fun x -> f x, x)
 
 (* now in prelude
- * let rec take n xs = 
+ * let rec take n xs =
  * match (n,xs) with
  * | (0,_) -> []
  * | (_,[]) -> failwith "take: not enough"
@@ -3537,7 +3701,7 @@ let rec drop_while p = function
   | x::xs -> if p x then drop_while p xs else x::xs	
 
 
-let rec drop_until p xs = 
+let rec drop_until p xs =
   drop_while (fun x -> not (p x)) xs
 let _ = example (drop_until (fun x -> x =|= 3) [1;2;3;4;5] =*= [3;4;5])
 
@@ -3545,11 +3709,11 @@ let _ = example (drop_until (fun x -> x =|= 3) [1;2;3;4;5] =*= [3;4;5])
 let span p xs = (take_while p xs, drop_while p xs)
 
 
-let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) = 
+let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) =
  fun p -> function
   | []    -> ([], [])
-  | x::xs -> 
-      if p x then 
+  | x::xs ->
+      if p x then
 	let (l1, l2) = span p xs in
 	(x::l1, l2)
       else ([], x::xs)
@@ -3558,16 +3722,16 @@ let _ = example ((span (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2])))
 let rec groupBy eq l =
   match l with
   | [] -> []
-  | x::xs -> 
+  | x::xs ->
       let (xs1,xs2) = List.partition (fun x' -> eq x x') xs in
       (x::xs1)::(groupBy eq xs2)
 
 let rec group_by_mapped_key fkey l =
   match l with
   | [] -> []
-  | x::xs -> 
-      let k = fkey x in 
-      let (xs1,xs2) = List.partition (fun x' -> let k2 = fkey x' in k=*=k2) xs 
+  | x::xs ->
+      let k = fkey x in
+      let (xs1,xs2) = List.partition (fun x' -> let k2 = fkey x' in k=*=k2) xs
       in
       (k, (x::xs1))::(group_by_mapped_key fkey xs2)
 
@@ -3575,81 +3739,82 @@ let rec group_by_mapped_key fkey l =
 
 
 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 *)
-   | x::xs -> 
-       if f x 
-       then aux_filter (x::acc) xs
-       else (x, List.rev acc)::aux_filter [] xs
+ fun f xs ->
+   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) 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])])
 
 let (group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list)=
- fun f xs -> 
+ fun f xs ->
    let rec aux_filter grouped_acc acc = function
-   | [] -> 
+   | [] ->
        List.rev grouped_acc, List.rev acc
-   | x::xs -> 
-       if f x 
-       then 
+   | x::xs ->
+       if f x
+       then
          aux_filter ((List.rev acc,x)::grouped_acc) [] xs
-       else 
+       else
          aux_filter grouped_acc (x::acc) xs
    in
    aux_filter [] [] xs
 
 let _ = example
-  (group_by_post (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*= 
+  (group_by_post (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
       ([([1;1],3);([2],3);[4;5],3], [6;6;6]))
 
 let (group_by_pre: ('a -> bool) -> 'a list -> 'a list * ('a * 'a list) list)=
-  fun f xs -> 
+  fun f xs ->
     let xs' = List.rev xs in
     let (ys, unclassified) = group_by_post f xs' in
     List.rev unclassified,
     ys +> List.rev +> List.map (fun (xs, x) -> x, List.rev xs )
 
 let _ = example
-  (group_by_pre (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*= 
+  (group_by_pre (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
       ([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)
-let _ = example (split_when (fun x -> x =|= 3) 
+  | x::xs ->
+      if p x then
+        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]))
 
 
 (* not so easy to come up with ... used in aComment for split_paragraph *)
-let rec split_gen_when_aux f acc xs = 
+let rec split_gen_when_aux f acc xs =
   match xs with
-  | [] -> 
+  | [] ->
       if null acc
       then []
       else [List.rev acc]
-  | (x::xs) -> 
+  | (x::xs) ->
       (match f (x::xs) with
-      | None -> 
-          split_gen_when_aux f (x::acc) xs 
-      | Some (rest) -> 
+      | None ->
+          split_gen_when_aux f (x::acc) xs
+      | Some (rest) ->
           let before = List.rev acc in
           if null before
           then split_gen_when_aux f [] rest
           else before::split_gen_when_aux f [] rest
       )
 (* could avoid introduce extra aux function by using ?(acc = []) *)
-let split_gen_when f xs = 
+let split_gen_when f xs =
   split_gen_when_aux f [] xs
 
 
@@ -3657,8 +3822,8 @@ let split_gen_when f xs =
 (* generate exception (Failure "tl") if there is no element satisfying p *)
 let rec (skip_until: ('a list -> bool) -> 'a list -> 'a list) = fun p xs ->
   if p xs then xs else skip_until p (List.tl xs)
-let _ = example 
-  (skip_until (function 1::2::xs -> true | _ -> false) 
+let _ = example
+  (skip_until (function 1::2::xs -> true | _ -> false)
       [1;3;4;1;2;4;5] =*= [1;2;4;5])
 
 let rec skipfirst e = function
@@ -3672,32 +3837,32 @@ let rec skipfirst e = function
  *)
 
 
-let index_list xs = 
+let index_list xs =
   if null xs then [] (* enum 0 (-1) generate an exception *)
   else zip xs (enum 0 ((List.length xs) -1))
 
-let index_list_and_total xs = 
+let index_list_and_total xs =
   let total = List.length xs in
   if null xs then [] (* enum 0 (-1) generate an exception *)
-  else zip xs (enum 0 ((List.length xs) -1)) 
+  else zip xs (enum 0 ((List.length xs) -1))
     +> List.map (fun (a,b) -> (a,b,total))
 
-let index_list_1 xs = 
+let index_list_1 xs =
   xs +> index_list +> List.map (fun (x,i) -> x, i+1)
 
 let or_list  = List.fold_left (||) false
 let and_list = List.fold_left (&&) true
 
-let avg_list xs = 
+let avg_list xs =
   let sum = sum_int xs in
   (float_of_int sum) /. (float_of_int (List.length xs))
 
 let snoc x xs = xs @ [x]
 let cons x xs = x::xs
 
-let head_middle_tail xs = 
+let head_middle_tail xs =
   match xs with
-  | x::y::xs -> 
+  | x::y::xs ->
       let head = x in
       let reversed = List.rev (y::xs) in
       let tail = List.hd reversed in
@@ -3708,29 +3873,29 @@ let head_middle_tail xs =
 let _ = assert_equal (head_middle_tail [1;2;3]) (1, [2], 3)
 let _ = assert_equal (head_middle_tail [1;3]) (1, [], 3)
 
-(* now in prelude 
- * let (++) = (@) 
+(* now in prelude
+ * let (++) = (@)
  *)
 
 (* let (++) = (@), could do that, but if load many times the common, then pb *)
 (* let (++) l1 l2 = List.fold_right (fun x acc -> x::acc) l1 l2 *)
 
-let remove x xs = 
+let remove x xs =
   let newxs = List.filter (fun y -> y <> x) xs in
   assert (List.length newxs =|= List.length xs - 1);
   newxs
 
 
-let exclude p xs = 
+let exclude p xs =
   List.filter (fun x -> not (p x)) xs
 
-(* now in prelude 
+(* now in prelude
 *)
 
-let fold_k f lastk acc xs = 
+let fold_k f lastk acc xs =
   let rec fold_k_aux acc = function
     | [] -> lastk acc
-    | x::xs -> 
+    | x::xs ->
         f acc x (fun acc -> fold_k_aux acc xs)
   in
   fold_k_aux acc xs
@@ -3785,16 +3950,16 @@ let filter_index f l =
 (* pixel *)
 let do_withenv doit f env l =
   let r_env = ref env in
-  let l' = doit (fun e -> 
+  let l' = doit (fun e ->
     let e', env' = f !r_env e in
     r_env := env' ; e'
   ) l in
   l', !r_env
 
-(* now in prelude: 
+(* now in prelude:
  * let fold_left_with_index f acc = ...
  *)
-  
+
 let map_withenv      f env e = do_withenv List.map f env e
 
 let rec collect_accu f accu = function
@@ -3808,7 +3973,7 @@ let collect f l = List.rev (collect_accu f [] l)
 let rec fpartition p l =
   let rec part yes no = function
   | [] -> (List.rev yes, List.rev no)
-  | x :: l -> 
+  | x :: l ->
       (match p x with
       |	None -> part yes (x :: no) l
       |	Some v -> part (v :: yes) no l) in
@@ -3852,8 +4017,8 @@ let minimum l = foldl1 min l
 
 (* do a map tail recursive, and result is reversed, it is a tail recursive map => efficient *)
 let map_eff_rev = fun f l ->
-  let rec map_eff_aux acc = 
-    function 
+  let rec map_eff_aux acc =
+    function
       |	[]    -> acc
       |	x::xs -> map_eff_aux ((f x)::acc) xs
   in
@@ -3874,15 +4039,15 @@ let rec uniq = function
   | [] -> []
   | e::l -> if List.mem e l then uniq l else e :: uniq l
 
-let has_no_duplicate xs = 
+let has_no_duplicate xs =
   List.length xs =|= List.length (uniq xs)
 let is_set_as_list = has_no_duplicate
 
 
-let rec get_duplicates xs = 
+let rec get_duplicates xs =
   match xs with
   | [] -> []
-  | x::xs -> 
+  | x::xs ->
       if List.mem x xs
       then x::get_duplicates xs (* todo? could x from xs to avoid double dups?*)
       else get_duplicates xs
@@ -3904,22 +4069,22 @@ let rec (return_when: ('a -> 'b option) -> 'a list -> 'b) = fun p -> function
   | [] -> raise Not_found
   | x::xs -> (match p x with None -> return_when p xs | Some b -> b)
 
-let rec splitAt n xs = 
+let rec splitAt n xs =
   if n =|= 0 then ([],xs)
-  else 
+  else
     (match xs with
     | []      -> ([],[])
     | (x::xs) -> let (a,b) = splitAt (n-1) xs in (x::a, b)
     )
 
-let pack n xs = 
+let pack n xs =
   let rec pack_aux l i = function
     | [] -> failwith "not on a boundary"
     | [x] -> if i =|= n then [l++[x]] else failwith "not on a boundary"
-    | x::xs -> 
-        if i =|= n 
-        then (l++[x])::(pack_aux [] 1 xs) 
-        else pack_aux (l++[x]) (i+1) xs 
+    | x::xs ->
+        if i =|= n
+        then (l++[x])::(pack_aux [] 1 xs)
+        else pack_aux (l++[x]) (i+1) xs
   in
   pack_aux [] 1 xs
 
@@ -3928,9 +4093,9 @@ let min_with f = function
   | e :: l ->
       let rec min_with_ min_val min_elt = function
 	| [] -> min_elt
-	| e::l -> 
+	| e::l ->
 	    let val_ = f e in
-	    if val_ < min_val 
+	    if val_ < min_val
 	    then min_with_ val_ e l
 	    else min_with_ min_val min_elt l
       in min_with_ (f e) e l
@@ -3939,18 +4104,18 @@ let two_mins_with f = function
   | e1 :: e2 :: l ->
       let rec min_with_ min_val min_elt min_val2 min_elt2 = function
 	| [] -> min_elt, min_elt2
-	| e::l -> 
+	| e::l ->
 	    let val_ = f e in
-	    if val_ < min_val2 
+	    if val_ < min_val2
 	    then
 	      if val_ < min_val
 	      then min_with_ val_ e min_val min_elt l
 	      else min_with_ min_val min_elt val_ e l
 	    else min_with_ min_val min_elt min_val2 min_elt2 l
-      in 
+      in
       let v1 = f e1 in
       let v2 = f e2 in
-      if v1 < v2 then min_with_ v1 e1 v2 e2 l else min_with_ v2 e2 v1 e1 l 
+      if v1 < v2 then min_with_ v1 e1 v2 e2 l else min_with_ v2 e2 v1 e1 l
   | _ -> raise Not_found
 
 let grep_with_previous f = function
@@ -3970,8 +4135,8 @@ let iter_with_previous f = function
       in iter_with_previous_ e l
 
 
-let iter_with_before_after f xs = 
-  let rec aux before_rev after = 
+let iter_with_before_after f xs =
+  let rec aux before_rev after =
     match after with
     | [] -> ()
     | x::xs ->
@@ -4011,7 +4176,7 @@ let rec (permutation: 'a list -> 'a list list) = function
   | [] -> []
   | [x] -> [[x]]
   | x::xs -> List.flatten (List.map (insert_in x) (permutation xs))
-(* permutation [1;2;3] = 
+(* permutation [1;2;3] =
  * [[1; 2; 3]; [2; 1; 3]; [2; 3; 1]; [1; 3; 2]; [3; 1; 2]; [3; 2; 1]]
  *)
 
@@ -4023,54 +4188,54 @@ let rec remove_elem_pos pos xs =
   | n, x::xs -> x::(remove_elem_pos (n-1) xs)
 
 let rec insert_elem_pos (e, pos) xs =
-  match (pos, xs) with 
-  | 0, xs -> e::xs 
+  match (pos, xs) with
+  | 0, xs -> e::xs
   | n, x::xs -> x::(insert_elem_pos (e, (n-1)) xs)
   | n, [] -> failwith "insert_elem_pos"
 
-let rec uncons_permut xs = 
+let rec uncons_permut xs =
   let indexed = index_list xs in
   indexed +> List.map (fun (x, pos) -> (x, pos),  remove_elem_pos pos xs)
-let _ = 
-  example 
-    (uncons_permut ['a';'b';'c'] =*= 
+let _ =
+  example
+    (uncons_permut ['a';'b';'c'] =*=
      [('a', 0),  ['b';'c'];
       ('b', 1),  ['a';'c'];
       ('c', 2),  ['a';'b']
      ])
 
-let rec uncons_permut_lazy xs = 
+let rec uncons_permut_lazy xs =
   let indexed = index_list xs in
-  indexed +> List.map (fun (x, pos) -> 
-    (x, pos),  
+  indexed +> List.map (fun (x, pos) ->
+    (x, pos),
     lazy (remove_elem_pos pos xs)
   )
-        
-    
-    
+
+
+
 
 (* pixel *)
 let rec map_flatten f l =
-  let rec map_flatten_aux accu = function    
+  let rec map_flatten_aux accu = function
     | [] -> accu
     | e :: l -> map_flatten_aux (List.rev (f e) ++ accu) l
   in List.rev (map_flatten_aux [] l)
 
 
-let rec repeat e n = 
+let rec repeat e n =
     let rec repeat_aux acc = function
       | 0 -> acc
       | n when n < 0 -> failwith "repeat"
       | n -> repeat_aux (e::acc) (n-1) in
     repeat_aux [] n
 
-let rec map2 f = function 
+let rec map2 f = function
   | [] -> []
   | x::xs -> let r = f x in r::map2 f xs
 
-let rec map3 f l = 
+let rec map3 f l =
   let rec map3_aux acc = function
-    | [] -> acc 
+    | [] -> acc
     | x::xs -> map3_aux (f x::acc) xs in
   map3_aux [] l
 
@@ -4078,21 +4243,21 @@ let rec map3 f l =
 let tails2 xs = map rev (inits (rev xs))
 let res = tails2 [1;2;3;4]
 let res = tails [1;2;3;4]
-let id x = x 
+let id x = x
 *)
 
-let pack_sorted same xs = 
-    let rec pack_s_aux acc xs = 
+let pack_sorted same xs =
+    let rec pack_s_aux acc xs =
       match (acc,xs) with
       |	((cur,rest),[]) -> cur::rest
-      |	((cur,rest), y::ys) -> 
+      |	((cur,rest), y::ys) ->
 	  if same (List.hd cur) y then pack_s_aux (y::cur, rest) ys
 	  else pack_s_aux ([y], cur::rest) ys
     in pack_s_aux ([List.hd xs],[]) (List.tl xs) +> List.rev
 let test = pack_sorted (=*=) [1;1;1;2;2;3;4]
 
 
-let rec keep_best f = 
+let rec keep_best f =
   let rec partition e = function
     | [] -> e, []
     | e' :: l ->
@@ -4101,48 +4266,48 @@ let rec keep_best f =
 	| Some e'' -> partition e'' l
   in function
   | [] -> []
-  | e::l -> 
+  | e::l ->
       let (e', l') = partition e l in
       e' :: keep_best f l'
 
 let rec sorted_keep_best f = function
   | [] -> []
   | [a] -> [a]
-  | a :: b :: l -> 
+  | a :: b :: l ->
       match f a b with
       |	None -> a :: sorted_keep_best f (b :: l)
       |	Some e -> sorted_keep_best f (e :: l)
 
 
 
-let (cartesian_product: 'a list -> 'b list -> ('a * 'b) list) = fun xs ys -> 
+let (cartesian_product: 'a list -> 'b list -> ('a * 'b) list) = fun xs ys ->
   xs +> List.map (fun x ->  ys +> List.map (fun y -> (x,y)))
      +> List.flatten
 
-let _ = assert_equal 
-    (cartesian_product [1;2] ["3";"4";"5"]) 
+let _ = assert_equal
+    (cartesian_product [1;2] ["3";"4";"5"])
     [1,"3";1,"4";1,"5";  2,"3";2,"4";2,"5"]
 
-let sort_prof a b = 
+let sort_prof a b =
   profile_code "Common.sort_by_xxx" (fun () -> List.sort a b)
 
-let sort_by_val_highfirst xs = 
+let sort_by_val_highfirst xs =
   sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs
-let sort_by_val_lowfirst xs = 
+let sort_by_val_lowfirst xs =
   sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs
 
-let sort_by_key_highfirst xs = 
+let sort_by_key_highfirst xs =
   sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
-let sort_by_key_lowfirst xs = 
+let sort_by_key_lowfirst xs =
   sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs
 
 let _ = example (sort_by_key_lowfirst [4, (); 7,()] =*= [4,(); 7,()])
 let _ = example (sort_by_key_highfirst [4,(); 7,()] =*= [7,(); 4,()])
 
 
-let sortgen_by_key_highfirst xs = 
+let sortgen_by_key_highfirst xs =
   sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
-let sortgen_by_key_lowfirst xs = 
+let sortgen_by_key_lowfirst xs =
   sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs
 
 (*----------------------------------*)
@@ -4150,7 +4315,7 @@ let sortgen_by_key_lowfirst xs =
 (* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ...      *)
 (* mais pas p2;p3                                                            *)
 (* (aop) *)
-let surEnsemble  liste_el liste_liste_el = 
+let surEnsemble  liste_el liste_liste_el =
   List.filter
     (function liste_elbis ->
       List.for_all (function el -> List.mem el liste_elbis) liste_el
@@ -4164,7 +4329,7 @@ let surEnsemble  liste_el liste_liste_el =
 let rec realCombinaison = function
   | []  -> []
   | [a] -> [[a]]
-  | a::l  -> 
+  | a::l  ->
       let res  = realCombinaison l in
       let res2 = List.map (function x -> a::x) res in
       res2 ++ res ++ [[a]]
@@ -4185,25 +4350,25 @@ let rec combinaison = function
 (* ces listes, on ne fait rien                                               *)
 let rec insere elem = function
   | []   -> [[elem]]
-  | a::l -> 
+  | a::l ->
       if (List.mem elem a) then a::l
       else a::(insere elem l)
 
 let rec insereListeContenant lis el = function
   | []   -> [el::lis]
-  | a::l -> 
-      if List.mem el a then 
+  | a::l ->
+      if List.mem el a then
 	(List.append lis a)::l
       else a::(insereListeContenant lis el l)
 
 (* fusionne les listes contenant et1 et et2  dans la liste de liste*)
 let rec fusionneListeContenant (et1, et2) = function
   | []   -> [[et1; et2]]
-  | a::l -> 
+  | a::l ->
       (* si les deux sont deja dedans alors rien faire *)
       if List.mem et1 a then
 	if List.mem et2 a then a::l
-	else 
+	else
 	  insereListeContenant a et2 l
       else if List.mem et2 a then
 	insereListeContenant a et1 l
@@ -4228,7 +4393,7 @@ let array_find_index_via_elem f a =
 
 
 
-type idx = Idx of int 
+type idx = Idx of int
 let next_idx (Idx i) = (Idx (i+1))
 let int_of_idx (Idx i) = i
 
@@ -4246,65 +4411,65 @@ let array_find_index_typed f a =
 
 type 'a matrix = 'a array array
 
-let map_matrix f mat = 
+let map_matrix f mat =
   mat +> Array.map (fun arr -> arr +> Array.map f)
 
-let (make_matrix_init: 
-        nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) = 
+let (make_matrix_init:
+        nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) =
  fun ~nrow ~ncolumn f ->
-  Array.init nrow (fun i -> 
-    Array.init ncolumn (fun j -> 
+  Array.init nrow (fun i ->
+    Array.init ncolumn (fun j ->
       f i j
     )
   )
 
-let iter_matrix f m = 
-  Array.iteri (fun i e -> 
-    Array.iteri (fun j x -> 
+let iter_matrix f m =
+  Array.iteri (fun i e ->
+    Array.iteri (fun j x ->
       f i j x
     ) e
   ) m
 
-let nb_rows_matrix m = 
+let nb_rows_matrix m =
   Array.length m
 
 let nb_columns_matrix m =
   assert(Array.length m > 0);
   Array.length m.(0)
-  
+
 (* check all nested arrays have the same size *)
 let invariant_matrix m =
   raise Todo
 
-let (rows_of_matrix: 'a matrix -> 'a list list) = fun m -> 
+let (rows_of_matrix: 'a matrix -> 'a list list) = fun m ->
   Array.to_list m +> List.map Array.to_list
-  
-let (columns_of_matrix: 'a matrix -> 'a list list) = fun m -> 
+
+let (columns_of_matrix: 'a matrix -> 'a list list) = fun m ->
   let nbcols = nb_columns_matrix m in
   let nbrows = nb_rows_matrix m in
-  (enum 0 (nbcols -1)) +> List.map (fun j -> 
-    (enum 0 (nbrows -1)) +> List.map (fun i -> 
+  (enum 0 (nbcols -1)) +> List.map (fun j ->
+    (enum 0 (nbrows -1)) +> List.map (fun i ->
       m.(i).(j)
     ))
 
 
-let all_elems_matrix_by_row m = 
-  rows_of_matrix m +> List.flatten 
+let all_elems_matrix_by_row m =
+  rows_of_matrix m +> List.flatten
 
 
-let ex_matrix1 = 
+let ex_matrix1 =
   [|
     [|0;1;2|];
     [|3;4;5|];
     [|6;7;8|];
   |]
-let ex_rows1 = 
+let ex_rows1 =
   [
     [0;1;2];
     [3;4;5];
     [6;7;8];
   ]
-let ex_columns1 = 
+let ex_columns1 =
   [
     [0;3;6];
     [1;4;7];
@@ -4327,7 +4492,7 @@ open Bigarray
 *)
 
 
-(* for the string_of auto generation of camlp4 
+(* for the string_of auto generation of camlp4
 val b_array_string_of_t : 'a -> 'b -> string
 val bigarray_string_of_int16_unsigned_elt : 'a -> string
 val bigarray_string_of_c_layout : 'a -> string
@@ -4345,18 +4510,18 @@ type 'a set = 'a list
   (* with sexp *)
 
 let (empty_set: 'a set) = []
-let (insert_set: 'a -> 'a set -> 'a set) = fun x xs -> 
-  if List.mem x xs 
-  then (* let _ = print_string "warning insert: already exist" in *) 
-    xs 
+let (insert_set: 'a -> 'a set -> 'a set) = fun x xs ->
+  if List.mem x xs
+  then (* let _ = print_string "warning insert: already exist" in *)
+    xs
   else x::xs
 
-let is_set xs = 
+let is_set xs =
   has_no_duplicate xs
 
 let (single_set: 'a -> 'a set) = fun x -> insert_set x empty_set
-let (set: 'a list -> 'a set) = fun xs -> 
-  xs +> List.fold_left (flip insert_set) empty_set 
+let (set: 'a list -> 'a set) = fun xs ->
+  xs +> List.fold_left (flip insert_set) empty_set
 
 let (exists_set: ('a -> bool) -> 'a set -> bool) = List.exists
 let (forall_set: ('a -> bool) -> 'a set -> bool) = List.for_all
@@ -4371,11 +4536,11 @@ let iter_set = List.iter
 
 let (top_set: 'a set -> 'a) = List.hd
 
-let (inter_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> 
+let (inter_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
   s1 +> fold_set (fun acc x -> if member_set x s2 then insert_set x acc else acc) empty_set
-let (union_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> 
+let (union_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
   s2 +> fold_set (fun acc x -> if member_set x s1 then acc else insert_set x acc) s1
-let (minus_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> 
+let (minus_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
   s1 +> filter_set  (fun x -> not (member_set x s2))
 
 
@@ -4385,12 +4550,12 @@ let big_union_set f xs = xs +> map_set f +> fold_set union_set empty_set
 
 let (card_set: 'a set -> int) = List.length
 
-let (include_set: 'a set -> 'a set -> bool) = fun s1 s2 -> 
+let (include_set: 'a set -> 'a set -> bool) = fun s1 s2 ->
   (s1 +> forall_set (fun p -> member_set p s2))
 
 let equal_set s1 s2 = include_set s1 s2 && include_set s2 s1
 
-let (include_set_strict: 'a set -> 'a set -> bool) = fun s1 s2 -> 
+let (include_set_strict: 'a set -> 'a set -> bool) = fun s1 s2 ->
   (card_set s1 < card_set s2) && (include_set s1 s2)
 
 let ($*$) = inter_set
@@ -4402,7 +4567,7 @@ let ($<=$) = include_set
 let ($=$) = equal_set
 
 (* as $+$ but do not check for memberness, allow to have set of func *)
-let ($@$) = fun a b -> a @ b 
+let ($@$) = fun a b -> a @ b
 
 let rec nub = function
     [] -> []
@@ -4412,7 +4577,7 @@ let rec nub = function
 (* Set as normal list *)
 (*****************************************************************************)
 (*
-let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 -> 
+let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 ->
   List.fold_left (fun acc x -> if List.mem x l1 then acc else x::acc) l1 l2
 
 let insert_normal x xs = union xs [x]
@@ -4424,7 +4589,7 @@ let inter l1 l2 = List.fold_left (fun acc x -> if List.mem x l2 then x::acc else
 
 let union_list =  List.fold_left union []
 
-let uniq lis = 
+let uniq lis =
   List.fold_left (function acc -> function el -> union [el] acc) [] lis
 
 (* pixel *)
@@ -4435,7 +4600,7 @@ let rec non_uniq = function
 let rec inclu lis1 lis2 =
   List.for_all (function el -> List.mem el lis2) lis1
 
-let equivalent lis1 lis2 = 
+let equivalent lis1 lis2 =
   (inclu lis1 lis2) && (inclu lis2 lis1)
 
 *)
@@ -4451,7 +4616,7 @@ let equivalent lis1 lis2 =
 (*
 let rec insert x = function
   | [] -> [x]
-  | y::ys -> 
+  | y::ys ->
       if x = y then y::ys
       else (if x < y then x::y::ys else y::(insert x ys))
 
@@ -4460,9 +4625,9 @@ let rec intersect x y =
   match(x,y) with
   | [], y -> []
   | x,  [] -> []
-  | x::xs, y::ys -> 
+  | x::xs, y::ys ->
       if x = y then x::(intersect xs ys)
-      else 
+      else
 	(if x < y then intersect xs (y::ys)
 	else intersect (x::xs) ys
 	)
@@ -4477,11 +4642,11 @@ type ('a,'b) assoc  = ('a * 'b) list
 
 
 let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
-  xs +> List.fold_left (fun acc (k, v) -> 
-    (fun k' -> 
+  xs +> List.fold_left (fun acc (k, v) ->
+    (fun k' ->
       if k =*= k' then v else acc k'
     )) (fun k -> failwith "no key in this assoc")
-(* simpler: 
+(* simpler:
 let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
   fun k -> List.assoc k xs
 *)
@@ -4501,7 +4666,7 @@ let lookup = assoc
 let del_assoc key xs = xs +> List.filter (fun (k,v) -> k <> key)
 let replace_assoc (key, v) xs = insert_assoc (key, v) (del_assoc key xs)
 
-let apply_assoc key f xs = 
+let apply_assoc key f xs =
   let old = assoc key xs in
   replace_assoc (key, f old) xs
 
@@ -4510,10 +4675,10 @@ let big_union_assoc f xs = xs +> map_assoc f +> fold_assoc union_set empty_set
 (* todo: pb normally can suppr fun l -> .... l but if do that, then strange type _a
  => assoc_map is strange too => equal dont work
 *)
-let (assoc_reverse: (('a * 'b) list) -> (('b * 'a) list)) = fun l -> 
+let (assoc_reverse: (('a * 'b) list) -> (('b * 'a) list)) = fun l ->
   List.map (fun(x,y) -> (y,x)) l
 
-let (assoc_map: (('a * 'b) list) -> (('a * 'b) list) -> (('a * 'a) list)) = 
+let (assoc_map: (('a * 'b) list) -> (('a * 'b) list) -> (('a * 'a) list)) =
  fun l1 l2 ->
   let (l1bis, l2bis) = (assoc_reverse l1, assoc_reverse l2) in
   List.map (fun (x,y) -> (y, List.assoc x l2bis )) l1bis
@@ -4522,25 +4687,25 @@ let rec (lookup_list: 'a -> ('a , 'b) assoc list -> 'b) = fun el -> function
   | [] -> raise Not_found
   | (xs::xxs) -> try List.assoc el xs with Not_found -> lookup_list el xxs
 
-let (lookup_list2: 'a -> ('a , 'b) assoc list -> ('b * int)) = fun el xxs -> 
+let (lookup_list2: 'a -> ('a , 'b) assoc list -> ('b * int)) = fun el xxs ->
   let rec lookup_l_aux i = function
   | [] -> raise Not_found
-  | (xs::xxs) -> 
-      try let res = List.assoc el xs in (res,i) 
+  | (xs::xxs) ->
+      try let res = List.assoc el xs in (res,i)
       with Not_found -> lookup_l_aux (i+1) xxs
   in lookup_l_aux 0 xxs
 
-let _ = example 
+let _ = example
   (lookup_list2 "c" [["a",1;"b",2];["a",1;"b",3];["a",1;"c",7]] =*= (7,2))
 
 
-let assoc_option  k l = 
+let assoc_option  k l =
   optionise (fun () -> List.assoc k l)
 
 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));
+  try List.assoc k l
+  with Not_found ->
+    pr2 (spf "pb assoc_with_err_msg: %s" (Dumper.dump k));
     raise Not_found
 
 (*****************************************************************************)
@@ -4551,7 +4716,7 @@ let assoc_with_err_msg k l =
 module IntMap = Map.Make
     (struct
       type t = int
-      let compare = compare 
+      let compare = compare
     end)
 let intmap_to_list m = IntMap.fold (fun id v acc -> (id, v) :: acc) m []
 let intmap_string_of_t f a = "<Not Yet>"
@@ -4559,7 +4724,7 @@ let intmap_string_of_t f a = "<Not Yet>"
 module IntIntMap = Map.Make
     (struct
       type t = int * int
-      let compare = compare 
+      let compare = compare
 end)
 
 let intintmap_to_list m = IntIntMap.fold (fun id v acc -> (id, v) :: acc) m []
@@ -4571,7 +4736,7 @@ let intintmap_string_of_t f a = "<Not Yet>"
 (*****************************************************************************)
 
 (* il parait que better  when choose a prime *)
-let hcreate () = Hashtbl.create 401 
+let hcreate () = Hashtbl.create 401
 let hadd (k,v) h = Hashtbl.add h k v
 let hmem k h = Hashtbl.mem h k
 let hfind k h = Hashtbl.find h k
@@ -4581,14 +4746,14 @@ let hfold = Hashtbl.fold
 let hremove k h = Hashtbl.remove h k
 
 
-let hash_to_list h = 
-  Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] 
-  +> List.sort compare 
+let hash_to_list h =
+  Hashtbl.fold (fun k v acc -> (k,v)::acc) h []
+  +> List.sort compare
 
-let hash_to_list_unsorted h = 
-  Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] 
+let hash_to_list_unsorted h =
+  Hashtbl.fold (fun k v acc -> (k,v)::acc) h []
 
-let hash_of_list xs = 
+let hash_of_list xs =
   let h = Hashtbl.create 101 in
   begin
     xs +> List.iter (fun (k, v) -> Hashtbl.add h k v);
@@ -4597,21 +4762,21 @@ let hash_of_list xs =
 
 let _  =
   let h = Hashtbl.create 101 in
-  Hashtbl.add h "toto" 1; 
+  Hashtbl.add h "toto" 1;
   Hashtbl.add h "toto" 1;
   assert(hash_to_list h =*= ["toto",1; "toto",1])
- 
 
-let hfind_default key value_if_not_found h = 
+
+let hfind_default key value_if_not_found h =
   try Hashtbl.find h key
-  with Not_found -> 
+  with Not_found ->
     (Hashtbl.add h key (value_if_not_found ()); Hashtbl.find h key)
 
 (* not as easy as Perl  $h->{key}++; but still possible *)
-let hupdate_default key op value_if_not_found h = 
+let hupdate_default key op value_if_not_found h =
   let old = hfind_default key value_if_not_found h in
   Hashtbl.replace h key (op old)
-  
+
 
 let hfind_option key h =
   optionise (fun () -> Hashtbl.find h key)
@@ -4624,80 +4789,80 @@ let hfind_option key h =
 (* Hash sets *)
 (*****************************************************************************)
 
-type 'a hashset = ('a, bool) Hashtbl.t 
+type 'a hashset = ('a, bool) Hashtbl.t
   (* with sexp *)
 
 
-let hash_hashset_add k e h = 
+let hash_hashset_add k e h =
   match optionise (fun () -> Hashtbl.find h k) with
   | Some hset -> Hashtbl.replace hset e true
-  | None -> 
+  | None ->
       let hset = Hashtbl.create 11 in
       begin
         Hashtbl.add h k hset;
         Hashtbl.replace hset e true;
       end
 
-let hashset_to_set baseset h = 
- h +> hash_to_list +> List.map fst +> (fun xs -> baseset#fromlist xs) 
+let hashset_to_set baseset h =
+ h +> hash_to_list +> List.map fst +> (fun xs -> baseset#fromlist xs)
 
 let hashset_to_list h = hash_to_list h +> List.map fst
 
-let hashset_of_list xs = 
+let hashset_of_list xs =
   xs +> List.map (fun x -> x, true) +> hash_of_list
 
 
 
-let hkeys h = 
+let hkeys h =
   let hkey = Hashtbl.create 101 in
   h +> Hashtbl.iter (fun k v -> Hashtbl.replace hkey k true);
   hashset_to_list hkey
 
 
 
-let group_assoc_bykey_eff2 xs = 
-  let h = Hashtbl.create 101 in 
+let group_assoc_bykey_eff2 xs =
+  let h = Hashtbl.create 101 in
   xs +> List.iter (fun (k, v) -> Hashtbl.add h k v);
   let keys = hkeys h in
   keys +> List.map (fun k -> k, Hashtbl.find_all h k)
 
-let group_assoc_bykey_eff xs = 
-  profile_code2 "Common.group_assoc_bykey_eff" (fun () -> 
+let group_assoc_bykey_eff xs =
+  profile_code2 "Common.group_assoc_bykey_eff" (fun () ->
     group_assoc_bykey_eff2 xs)
-  
 
-let test_group_assoc () = 
+
+let test_group_assoc () =
   let xs = enum 0 10000 +> List.map (fun i -> i_to_s i, i) in
   let xs = ("0", 2)::xs in
 (*    let _ys = xs +> Common.groupBy (fun (a,resa) (b,resb) -> a =$= b)  *)
-  let ys = xs +> group_assoc_bykey_eff 
+  let ys = xs +> group_assoc_bykey_eff
   in
   pr2_gen ys
 
 
-let uniq_eff xs = 
+let uniq_eff xs =
   let h = Hashtbl.create 101 in
-  xs +> List.iter (fun k -> 
+  xs +> List.iter (fun k ->
     Hashtbl.add h k true
   );
   hkeys h
 
 
 
-let diff_two_say_set_eff xs1 xs2 = 
+let diff_two_say_set_eff xs1 xs2 =
   let h1 = hashset_of_list xs1 in
   let h2 = hashset_of_list xs2 in
-  
+
   let hcommon = Hashtbl.create 101 in
   let honly_in_h1 = Hashtbl.create 101 in
   let honly_in_h2 = Hashtbl.create 101 in
-  
-  h1 +> Hashtbl.iter (fun k _ -> 
+
+  h1 +> Hashtbl.iter (fun k _ ->
     if Hashtbl.mem h2 k
     then Hashtbl.replace hcommon k true
     else Hashtbl.add honly_in_h1 k true
   );
-  h2 +> Hashtbl.iter (fun k _ -> 
+  h2 +> Hashtbl.iter (fun k _ ->
     if Hashtbl.mem h1 k
     then Hashtbl.replace hcommon k true
     else Hashtbl.add honly_in_h2 k true
@@ -4706,7 +4871,7 @@ let diff_two_say_set_eff xs1 xs2 =
   hashset_to_list honly_in_h1,
   hashset_to_list honly_in_h2
 
-  
+
 (*****************************************************************************)
 (* Stack *)
 (*****************************************************************************)
@@ -4723,13 +4888,13 @@ let top_option = function
   | x::xs -> Some x
 
 
-  
+
 
 (* now in prelude:
  * let push2 v l = l := v :: !l
  *)
 
-let pop2 l = 
+let pop2 l =
   let v = List.hd !l in
   begin
     l := List.tl !l;
@@ -4747,32 +4912,32 @@ let pop2 l =
 
 type 'a undo_stack = 'a list * 'a list (* redo *)
 
-let (empty_undo_stack: 'a undo_stack) = 
+let (empty_undo_stack: 'a undo_stack) =
   [], []
 
 (* push erase the possible redo *)
-let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) -> 
-  x::undo, [] 
+let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) ->
+  x::undo, []
 
-let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) -> 
-  List.hd undo 
+let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) ->
+  List.hd undo
 
-let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> 
+let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
   match undo with
   | [] ->  failwith "empty undo stack"
-  | x::xs -> 
+  | x::xs ->
       xs, x::redo
 
-let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> 
+let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
   match redo with
   | [] -> failwith "empty redo, nothing to redo"
-  | x::xs -> 
+  | x::xs ->
       x::undo, xs
 
-let redo_undo x = undo_pop x 
+let redo_undo x = undo_pop x
 
 
-let top_undo_option = fun (undo, redo) -> 
+let top_undo_option = fun (undo, redo) ->
   match undo with
   | [] -> None
   | x::xs -> Some x
@@ -4791,8 +4956,8 @@ type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)
 type 'a tree = Tree of 'a * ('a tree) list
 
 let rec (tree_iter: ('a -> unit) -> 'a tree -> unit) = fun f tree ->
-  match tree with 
-  | Tree (node, xs) -> 
+  match tree with
+  | Tree (node, xs) ->
       f node;
       xs +> List.iter (tree_iter f)
 
@@ -4803,32 +4968,32 @@ let rec (tree_iter: ('a -> unit) -> 'a tree -> unit) = fun f tree ->
 
 (* no empty tree, must have one root at list *)
 
-type 'a treeref = 
-  | NodeRef of 'a * 'a treeref list ref 
+type 'a treeref =
+  | NodeRef of 'a * 'a treeref list ref
 
-let treeref_children_ref tree = 
+let treeref_children_ref tree =
   match tree with
   | NodeRef (n, x) -> x
 
 
 
-let rec (treeref_node_iter: 
-(*   (('a * ('a, 'b) treeref list ref) -> unit) -> 
+let rec (treeref_node_iter:
+(*   (('a * ('a, 'b) treeref list ref) -> unit) ->
    ('a, 'b) treeref -> unit
-*) 'a) 
- = 
- fun f tree -> 
+*) 'a)
+ =
+ fun f tree ->
   match tree with
 (*  | LeafRef _ -> ()*)
-  | NodeRef (n, xs) -> 
+  | NodeRef (n, xs) ->
       f (n, xs);
       !xs +> List.iter (treeref_node_iter f)
 
 
-let find_treeref f tree = 
+let find_treeref f tree =
   let res = ref [] in
 
-  tree +> treeref_node_iter (fun (n, xs) -> 
+  tree +> treeref_node_iter (fun (n, xs) ->
     if f (n,xs)
     then push2 (n, xs) res;
   );
@@ -4837,16 +5002,16 @@ let find_treeref f tree =
   | [] -> raise Not_found
   | x::y::zs -> raise Multi_found
 
-let rec (treeref_node_iter_with_parents: 
- (*  (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) -> 
-   ('a, 'b) treeref -> unit) 
+let rec (treeref_node_iter_with_parents:
+ (*  (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) ->
+   ('a, 'b) treeref -> unit)
  *) 'a)
- = 
- fun f tree -> 
-  let rec aux acc tree = 
+ =
+ fun f tree ->
+  let rec aux acc tree =
     match tree with
 (*    | LeafRef _ -> ()*)
-    | NodeRef (n, xs) -> 
+    | NodeRef (n, xs) ->
         f (n, xs) acc ;
         !xs +> List.iter (aux (n::acc))
   in
@@ -4854,36 +5019,36 @@ let rec (treeref_node_iter_with_parents:
 
 
 (* ---------------------------------------------------------------------- *)
-(* Leaf can seem redundant, but sometimes want to directly see if 
+(* Leaf can seem redundant, but sometimes want to directly see if
  * a children is a leaf without looking if the list is empty.
  *)
-type ('a, 'b) treeref2 = 
-  | NodeRef2 of 'a * ('a, 'b) treeref2 list ref 
+type ('a, 'b) treeref2 =
+  | NodeRef2 of 'a * ('a, 'b) treeref2 list ref
   | LeafRef2 of 'b
 
 
-let treeref2_children_ref tree = 
+let treeref2_children_ref tree =
   match tree with
   | LeafRef2 _ -> failwith "treeref_tail: leaf"
   | NodeRef2 (n, x) -> x
 
 
 
-let rec (treeref_node_iter2: 
-   (('a * ('a, 'b) treeref2 list ref) -> unit) -> 
-   ('a, 'b) treeref2 -> unit) = 
- fun f tree -> 
+let rec (treeref_node_iter2:
+   (('a * ('a, 'b) treeref2 list ref) -> unit) ->
+   ('a, 'b) treeref2 -> unit) =
+ fun f tree ->
   match tree with
   | LeafRef2 _ -> ()
-  | NodeRef2 (n, xs) -> 
+  | NodeRef2 (n, xs) ->
       f (n, xs);
       !xs +> List.iter (treeref_node_iter2 f)
 
 
-let find_treeref2 f tree = 
+let find_treeref2 f tree =
   let res = ref [] in
 
-  tree +> treeref_node_iter2 (fun (n, xs) -> 
+  tree +> treeref_node_iter2 (fun (n, xs) ->
     if f (n,xs)
     then push2 (n, xs) res;
   );
@@ -4895,14 +5060,14 @@ let find_treeref2 f tree =
 
 
 
-let rec (treeref_node_iter_with_parents2: 
-  (('a * ('a, 'b) treeref2 list ref) -> ('a list) -> unit) -> 
-   ('a, 'b) treeref2 -> unit) = 
- fun f tree -> 
-  let rec aux acc tree = 
+let rec (treeref_node_iter_with_parents2:
+  (('a * ('a, 'b) treeref2 list ref) -> ('a list) -> unit) ->
+   ('a, 'b) treeref2 -> unit) =
+ fun f tree ->
+  let rec aux acc tree =
     match tree with
     | LeafRef2 _ -> ()
-    | NodeRef2 (n, xs) -> 
+    | NodeRef2 (n, xs) ->
         f (n, xs) acc ;
         !xs +> List.iter (aux (n::acc))
   in
@@ -4920,10 +5085,10 @@ let rec (treeref_node_iter_with_parents2:
 
 
 
-let find_treeref_with_parents_some f tree = 
+let find_treeref_with_parents_some f tree =
   let res = ref [] in
 
-  tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> 
+  tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
     match f (n,xs) parents with
     | Some v -> push2 v res;
     | None -> ()
@@ -4933,10 +5098,10 @@ let find_treeref_with_parents_some f tree =
   | [] -> raise Not_found
   | x::y::zs -> raise Multi_found
 
-let find_multi_treeref_with_parents_some f tree = 
+let find_multi_treeref_with_parents_some f tree =
   let res = ref [] in
 
-  tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> 
+  tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
     match f (n,xs) parents with
     | Some v -> push2 v res;
     | None -> ()
@@ -4944,51 +5109,51 @@ let find_multi_treeref_with_parents_some f tree =
   match !res with
   | [v] -> !res
   | [] -> raise Not_found
-  | x::y::zs -> !res 
+  | x::y::zs -> !res
 
 
 (*****************************************************************************)
 (* Graph. Have a look too at Ograph_*.mli  *)
 (*****************************************************************************)
-(* todo: generalise to put in common (need 'edge (and 'c ?), 
- * and take in param a display func, cos caml sux, no overloading of show :( 
+(* todo: generalise to put in common (need 'edge (and 'c ?),
+ * and take in param a display func, cos caml sux, no overloading of show :(
  * Simple impelemntation. Can do also matrix, or adjacent list, or pointer(ref)
  * todo: do some check (dont exist already, ...)
  *)
 
 type 'node graph = ('node set) * (('node * 'node) set)
 
-let (add_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) -> 
+let (add_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) ->
   (node::nodes, arcs)
 
-let (del_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) -> 
-  (nodes $-$ set [node], arcs) 
-(* could do more job:   
+let (del_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) ->
+  (nodes $-$ set [node], arcs)
+(* could do more job:
   let _ = assert (successors node (nodes, arcs) = empty) in
    +> List.filter (fun (src, dst) -> dst != node))
 *)
-let (add_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) -> 
+let (add_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) ->
   (nodes, set [arc] $+$ arcs)
 
-let (del_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) -> 
+let (del_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) ->
   (nodes, arcs +> List.filter (fun a -> not (arc =*= a)))
 
-let (successors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) -> 
+let (successors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) ->
   arcs +> List.filter (fun (src, dst) -> src =*= x) +> List.map snd
 
-let (predecessors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) -> 
+let (predecessors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) ->
   arcs +> List.filter (fun (src, dst) -> dst =*= x) +> List.map fst
 
 let (nodes: 'a graph -> 'a set) = fun (nodes, arcs) -> nodes
 
 (* pre: no cycle *)
-let rec (fold_upward: ('b -> 'a -> 'b) -> 'a set -> 'b -> 'a graph  -> 'b) = 
- fun f xs acc graph -> 
+let rec (fold_upward: ('b -> 'a -> 'b) -> 'a set -> 'b -> 'a graph  -> 'b) =
+ fun f xs acc graph ->
   match xs with
   | [] -> acc
-  | x::xs -> (f acc x) 
+  | x::xs -> (f acc x)
         +> (fun newacc -> fold_upward f (graph +> predecessors x) newacc graph)
-        +> (fun newacc -> fold_upward f xs newacc graph) 
+        +> (fun newacc -> fold_upward f xs newacc graph)
    (* TODO avoid already visited *)
 
 let empty_graph = ([], [])
@@ -4996,22 +5161,22 @@ let empty_graph = ([], [])
 
 
 (*
-let (add_arcs_toward: int -> (int list) -> 'a graph -> 'a graph) = fun i xs -> 
+let (add_arcs_toward: int -> (int list) -> 'a graph -> 'a graph) = fun i xs ->
   function
     (nodes, arcs) -> (nodes, (List.map (fun j -> (j,i) ) xs)++arcs)
 let (del_arcs_toward: int -> (int list) -> 'a graph -> 'a graph)= fun i xs g ->
     List.fold_left (fun acc el -> del_arc (el, i) acc) g xs
-let (add_arcs_from: int -> (int list) -> 'a graph -> 'a graph) = fun i xs -> 
+let (add_arcs_from: int -> (int list) -> 'a graph -> 'a graph) = fun i xs ->
  function
     (nodes, arcs) -> (nodes, (List.map (fun j -> (i,j) ) xs)++arcs)
 
 
-let (del_node: (int * 'node) -> 'node graph -> 'node graph) = fun node -> 
- function (nodes, arcs) -> 
+let (del_node: (int * 'node) -> 'node graph -> 'node graph) = fun node ->
+ function (nodes, arcs) ->
   let newnodes = List.filter (fun a -> not (node = a)) nodes in
     if newnodes = nodes then (raise Not_found) else (newnodes, arcs)
-let (replace_node: int -> 'node -> 'node graph -> 'node graph) = fun i n -> 
- function (nodes, arcs) -> 
+let (replace_node: int -> 'node -> 'node graph -> 'node graph) = fun i n ->
+ function (nodes, arcs) ->
   let newnodes = List.filter (fun (j,_) -> not (i = j)) nodes in
     ((i,n)::newnodes, arcs)
 let (get_node: int -> 'node graph -> 'node) = fun i -> function
@@ -5019,33 +5184,33 @@ let (get_node: int -> 'node graph -> 'node) = fun i -> function
 
 let (get_free: 'a graph -> int) = function
     (nodes, arcs) -> (maximum (List.map fst nodes))+1
-(* require no cycle !! 
+(* require no cycle !!
   TODO if cycle check that we have already visited a node *)
 let rec (succ_all: int -> 'a graph -> (int list)) = fun i -> function
-    (nodes, arcs) as g -> 
+    (nodes, arcs) as g ->
       let direct = succ i g in
       union direct (union_list (List.map (fun i -> succ_all i g) direct))
 let rec (pred_all: int -> 'a graph -> (int list)) = fun i -> function
-    (nodes, arcs) as g -> 
+    (nodes, arcs) as g ->
       let direct = pred i g in
       union direct (union_list (List.map (fun i -> pred_all i g) direct))
 (* require that the nodes are different !! *)
 let rec (equal: 'a graph -> 'a graph -> bool) = fun g1 g2 ->
   let ((nodes1, arcs1),(nodes2, arcs2)) = (g1,g2) in
-  try 
+  try
    (* do 2 things, check same length and to assoc *)
-    let conv = assoc_map nodes1 nodes2 in 
-    List.for_all (fun (i1,i2) -> 
+    let conv = assoc_map nodes1 nodes2 in
+    List.for_all (fun (i1,i2) ->
        List.mem (List.assoc i1 conv, List.assoc i2 conv) arcs2)
-     arcs1 
+     arcs1
       && (List.length arcs1 = List.length arcs2)
     (* could think that only forall is needed, but need check same lenth too*)
   with _ -> false
 
-let (display: 'a graph -> ('a -> unit) -> unit) = fun g display_func -> 
-  let rec aux depth i = 
+let (display: 'a graph -> ('a -> unit) -> unit) = fun g display_func ->
+  let rec aux depth i =
     print_n depth " ";
-    print_int i; print_string "->"; display_func (get_node i g); 
+    print_int i; print_string "->"; display_func (get_node i g);
     print_string "\n";
     List.iter (aux (depth+2)) (succ i g)
   in aux 0 1
@@ -5053,10 +5218,10 @@ let (display: 'a graph -> ('a -> unit) -> unit) = fun g display_func ->
 let (display_dot: 'a graph -> ('a -> string) -> unit)= fun (nodes,arcs) func ->
   let file = open_out "test.dot" in
   output_string file "digraph misc {\n" ;
-  List.iter (fun (n, node) -> 
+  List.iter (fun (n, node) ->
     output_int file n; output_string file " [label=\"";
     output_string file (func node); output_string file " \"];\n"; ) nodes;
-  List.iter (fun (i1,i2) ->  output_int file i1 ; output_string file " -> " ; 
+  List.iter (fun (i1,i2) ->  output_int file i1 ; output_string file " -> " ;
     output_int file i2 ; output_string file " ;\n"; ) arcs;
   output_string file "}\n" ;
   close_out file;
@@ -5067,25 +5232,25 @@ let (display_dot: 'a graph -> ('a -> string) -> unit)= fun (nodes,arcs) func ->
  *)
 
 (* todo: mettre diff(modulo = !!) en rouge *)
-let (display_dot2: 'a graph -> 'a graph -> ('a -> string) -> unit) = 
+let (display_dot2: 'a graph -> 'a graph -> ('a -> string) -> unit) =
   fun (nodes1, arcs1) (nodes2, arcs2) func ->
   let file = open_out "test.dot" in
   output_string file "digraph misc {\n" ;
   output_string file "rotate = 90;\n";
   List.iter (fun (n, node) ->
-    output_string file "100"; output_int file n; 
+    output_string file "100"; output_int file n;
     output_string file " [label=\"";
     output_string file (func node); output_string file " \"];\n"; ) nodes1;
   List.iter (fun (n, node) ->
-    output_string file "200"; output_int file n; 
+    output_string file "200"; output_int file n;
     output_string file " [label=\"";
     output_string file (func node); output_string file " \"];\n"; ) nodes2;
-  List.iter (fun (i1,i2) -> 
-    output_string file "100"; output_int file i1 ; output_string file " -> " ; 
-    output_string file "100"; output_int file i2 ; output_string file " ;\n"; 
-    ) 
+  List.iter (fun (i1,i2) ->
+    output_string file "100"; output_int file i1 ; output_string file " -> " ;
+    output_string file "100"; output_int file i2 ; output_string file " ;\n";
+    )
    arcs1;
-  List.iter (fun (i1,i2) -> 
+  List.iter (fun (i1,i2) ->
     output_string file "200"; output_int file i1 ; output_string file " -> " ;
     output_string file "200"; output_int file i2 ; output_string file " ;\n"; )
    arcs2;
@@ -5120,6 +5285,12 @@ let head = List.hd
 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) *)
 (*****************************************************************************)
@@ -5129,23 +5300,23 @@ type point = vector
 type color = vector (* color(0-1) *)
 
 (* todo: factorise *)
-let (dotproduct: vector * vector -> float) = 
+let (dotproduct: vector * vector -> float) =
   fun ((x1,y1,z1),(x2,y2,z2)) -> (x1*.x2 +. y1*.y2 +. z1*.z2)
-let (vector_length: vector -> float) = 
+let (vector_length: vector -> float) =
   fun (x,y,z) -> sqrt (square x +. square y +. square z)
-let (minus_point: point * point -> vector) = 
+let (minus_point: point * point -> vector) =
   fun ((x1,y1,z1),(x2,y2,z2)) -> ((x1 -. x2),(y1 -. y2),(z1 -. z2))
-let (distance: point * point -> float) = 
+let (distance: point * point -> float) =
   fun (x1, x2) -> vector_length (minus_point (x2,x1))
-let (normalise: vector -> vector) = 
-  fun (x,y,z) -> 
+let (normalise: vector -> vector) =
+  fun (x,y,z) ->
     let len = vector_length (x,y,z) in (x /. len, y /. len, z /. len)
-let (mult_coeff: vector -> float -> vector) = 
+let (mult_coeff: vector -> float -> vector) =
   fun (x,y,z) c -> (x *. c, y *. c, z *. c)
-let (add_vector: vector -> vector -> vector) = 
+let (add_vector: vector -> vector -> vector) =
   fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in
   (x1+.x2, y1+.y2, z1+.z2)
-let (mult_vector: vector -> vector -> vector) = 
+let (mult_vector: vector -> vector -> vector) =
   fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in
   (x1*.x2, y1*.y2, z1*.z2)
 let sum_vector = List.fold_left add_vector (0.0,0.0,0.0)
@@ -5165,13 +5336,13 @@ let (write_ppm: int -> int -> (pixel list) -> string -> unit) = fun
      output_string chan ((string_of_int width)  ^ "\n");
      output_string chan ((string_of_int height) ^ "\n");
      output_string chan "255\n";
-     List.iter (fun (r,g,b) -> 
+     List.iter (fun (r,g,b) ->
        List.iter (fun byt -> output_byte chan byt) [r;g;b]
 	       ) xs;
      close_out chan
     end
-    
-let test_ppm1 () = write_ppm 100 100 
+
+let test_ppm1 () = write_ppm 100 100
     ((generate (50*100) (1,45,100)) ++ (generate (50*100) (1,1,100)))
     "img.ppm"
 
@@ -5181,53 +5352,53 @@ let test_ppm1 () = write_ppm 100 100
 type diff = Match | BnotinA | AnotinB
 
 let (diff: (int -> int -> diff -> unit)-> (string list * string list) -> unit)=
-  fun f (xs,ys) -> 
+  fun f (xs,ys) ->
     let file1 = "/tmp/diff1-" ^ (string_of_int (Unix.getuid ())) in
     let file2 = "/tmp/diff2-" ^ (string_of_int (Unix.getuid ())) in
     let fileresult = "/tmp/diffresult-" ^ (string_of_int (Unix.getuid ())) in
     write_file file1 (unwords xs);
     write_file file2 (unwords ys);
-    command2 
+    command2
       ("diff --side-by-side -W 1 " ^ file1 ^ " " ^ file2 ^ " > " ^ fileresult);
     let res = cat fileresult in
     let a = ref 0 in
     let b = ref 0 in
-    res +> List.iter (fun s -> 
+    res +> List.iter (fun s ->
       match s with
       | ("" | " ") -> f !a !b Match; incr a; incr b;
       | ">" -> 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 3)
     )
-(*    
-let _ = 
-  diff 
+(*
+let _ =
+  diff
     ["0";"a";"b";"c";"d";    "f";"g";"h";"j";"q";            "z"]
-    [    "a";"b";"c";"d";"e";"f";"g";"i";"j";"k";"r";"x";"y";"z"]  
-   (fun x y -> pr "match") 
-   (fun x y -> pr "a_not_in_b") 
-   (fun x y -> pr "b_not_in_a") 
+    [    "a";"b";"c";"d";"e";"f";"g";"i";"j";"k";"r";"x";"y";"z"]
+   (fun x y -> pr "match")
+   (fun x y -> pr "a_not_in_b")
+   (fun x y -> pr "b_not_in_a")
 *)
 
-let (diff2: (int -> int -> diff -> unit) -> (string * string) -> unit) = 
- fun f (xstr,ystr) -> 
+let (diff2: (int -> int -> diff -> unit) -> (string * string) -> unit) =
+ fun f (xstr,ystr) ->
     write_file "/tmp/diff1" xstr;
     write_file "/tmp/diff2" ystr;
-    command2 
-     ("diff --side-by-side --left-column -W 1 " ^ 
+    command2
+     ("diff --side-by-side --left-column -W 1 " ^
       "/tmp/diff1 /tmp/diff2 > /tmp/diffresult");
     let res = cat "/tmp/diffresult" in
     let a = ref 0 in
     let b = ref 0 in
-    res +> List.iter (fun s -> 
+    res +> List.iter (fun s ->
       match s with
       | "(" -> f !a !b Match; incr a; incr b;
       | ">" -> 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)
     )
 
 
@@ -5236,7 +5407,7 @@ let (diff2: (int -> int -> diff -> unit) -> (string * string) -> unit) =
 (*****************************************************************************)
 
 let parserCommon lexbuf parserer lexer =
-  try 
+  try
     let result = parserer lexer lexbuf in
     result
   with Parsing.Parse_error ->
@@ -5249,14 +5420,14 @@ let parserCommon lexbuf parserer lexer =
 
 (* marche pas ca neuneu *)
 (*
-let getDoubleParser parserer lexer string = 
+let getDoubleParser parserer lexer string =
   let lexbuf1 = Lexing.from_string string in
   let chan = open_in string in
   let lexbuf2 = Lexing.from_channel chan in
   (parserCommon lexbuf1 parserer lexer  , parserCommon lexbuf2 parserer lexer )
 *)
 
-let getDoubleParser parserer lexer = 
+let getDoubleParser parserer lexer =
   (
    (function string ->
      let lexbuf1 = Lexing.from_string string in
@@ -5274,10 +5445,10 @@ let getDoubleParser parserer lexer =
 (*****************************************************************************)
 
 (* cf parser_combinators.ml
- * 
- * Could also use ocaml stream. but not backtrack and forced to do LL, 
+ *
+ * Could also use ocaml stream. but not backtrack and forced to do LL,
  * so combinators are better.
- * 
+ *
  *)
 
 
@@ -5292,28 +5463,28 @@ type parse_info = {
     line: int;
     column: int;
     file: filename;
-  } 
+  }
   (* with sexp *)
 
-let fake_parse_info = { 
+let fake_parse_info = {
   charpos = -1; str = "";
   line = -1; column = -1; file = "";
 }
 
-let string_of_parse_info x = 
+let string_of_parse_info x =
   spf "%s at %s:%d:%d" x.str x.file x.line x.column
-let string_of_parse_info_bis x = 
+let string_of_parse_info_bis x =
   spf "%s:%d:%d" x.file x.line x.column
 
-let (info_from_charpos2: int -> filename -> (int * int * string)) = 
+let (info_from_charpos2: int -> filename -> (int * int * string)) =
  fun charpos filename ->
 
   (* Currently lexing.ml does not handle the line number position.
-   * Even if there is some fields in the lexing structure, they are not 
+   * Even if there is some fields in the lexing structure, they are not
    * maintained by the lexing engine :( So the following code does not work:
-   *   let pos = Lexing.lexeme_end_p lexbuf in 
-   *   sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum  
-   *      (pos.pos_cnum - pos.pos_bol) in 
+   *   let pos = Lexing.lexeme_end_p lexbuf in
+   *   sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum
+   *      (pos.pos_cnum - pos.pos_bol) in
    * Hence this function to overcome the previous limitation.
    *)
   let chan = open_in filename in
@@ -5337,19 +5508,21 @@ let (info_from_charpos2: int -> filename -> (int * int * string)) =
 	  charpos_to_pos_aux !posl;
 	end
     | None -> (!linen, charpos - !posl, "\n")
-  in 
+  in
   let res = charpos_to_pos_aux 0 in
   close_in chan;
   res
 
-let info_from_charpos a b = 
+let info_from_charpos a b =
   profile_code "Common.info_from_charpos" (fun () -> info_from_charpos2 a b)
 
 
 
-let (full_charpos_to_pos2: filename -> (int * int) array ) = fun filename ->
+let full_charpos_to_pos2 = fun filename ->
+
+  let size = (filesize filename + 2) in
 
-    let arr = Array.create (filesize filename + 2) (0,0) in
+    let arr = Array.create size  (0,0) in
 
     let chan = open_in filename in
 
@@ -5362,54 +5535,111 @@ let (full_charpos_to_pos2: filename -> (int * int) array ) = fun filename ->
        incr line;
 
        (* '... +1 do'  cos input_line dont return the trailing \n *)
-       for i = 0 to (slength s - 1) + 1 do 
+       for i = 0 to (slength s - 1) + 1 do
          arr.(!charpos + i) <- (!line, i);
        done;
        charpos := !charpos + slength s + 1;
        full_charpos_to_pos_aux();
-       
-     with End_of_file -> 
+
+     with End_of_file ->
        for i = !charpos to Array.length arr - 1 do
          arr.(i) <- (!line, 0);
        done;
        ();
-    in 
-    begin 
+    in
+    begin
       full_charpos_to_pos_aux ();
       close_in chan;
       arr
     end
 let full_charpos_to_pos a =
   profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a)
-    
-let test_charpos file = 
-  full_charpos_to_pos file +> dump +> pr2
+
+let test_charpos file =
+  full_charpos_to_pos file +> Dumper.dump +> pr2
 
 
 
-let complete_parse_info filename table x = 
-  { x with 
+let complete_parse_info filename table x =
+  { x with
     file = filename;
     line   = fst (table.(x.charpos));
     column = snd (table.(x.charpos));
   }
 
+
+
+let full_charpos_to_pos_large2 = fun filename ->
+
+  let size = (filesize filename + 2) in
+
+    (* old: let arr = Array.create size  (0,0) in *)
+    let arr1 = Bigarray.Array1.create
+      Bigarray.int Bigarray.c_layout size in
+    let arr2 = Bigarray.Array1.create
+      Bigarray.int Bigarray.c_layout size in
+    Bigarray.Array1.fill arr1 0;
+    Bigarray.Array1.fill arr2 0;
+
+    let chan = open_in filename in
+
+    let charpos   = ref 0 in
+    let line  = ref 0 in
+
+    let rec full_charpos_to_pos_aux () =
+       let s = (input_line chan) in
+       incr line;
+
+       (* '... +1 do'  cos input_line dont return the trailing \n *)
+       for i = 0 to (slength s - 1) + 1 do
+         (* old: arr.(!charpos + i) <- (!line, i); *)
+         arr1.{!charpos + i} <- (!line);
+         arr2.{!charpos + i} <- i;
+       done;
+       charpos := !charpos + slength s + 1;
+       full_charpos_to_pos_aux() in
+    begin
+      (try
+	full_charpos_to_pos_aux ();
+      with End_of_file ->
+	for i = !charpos to (* old: Array.length arr *)
+          Bigarray.Array1.dim arr1 - 1 do
+         (* old: arr.(i) <- (!line, 0); *)
+          arr1.{i} <- !line;
+          arr2.{i} <- 0;
+	done;
+	());
+      close_in chan;
+      (fun i -> arr1.{i}, arr2.{i})
+    end
+let full_charpos_to_pos_large a =
+  profile_code "Common.full_charpos_to_pos_large"
+    (fun () -> full_charpos_to_pos_large2 a)
+
+
+let complete_parse_info_large filename table x =
+  { x with
+    file = filename;
+    line   = fst (table (x.charpos));
+    column = snd (table (x.charpos));
+  }
+
 (*---------------------------------------------------------------------------*)
-(* Decalage is here to handle stuff such as cpp which include file and who 
+(* Decalage is here to handle stuff such as cpp which include file and who
  * can make shift.
  *)
 let (error_messagebis: filename -> (string * int) -> int -> string)=
  fun filename (lexeme, lexstart) decalage ->
 
   let charpos = lexstart      + decalage in
-  let tok = lexeme in 
+  let tok = lexeme in
   let (line, pos, linecontent) =  info_from_charpos charpos filename in
   sprintf "File \"%s\", line %d, column %d,  charpos = %d
     around = '%s', whole content = %s"
     filename line pos charpos tok (chop linecontent)
 
-let error_message = fun filename (lexeme, lexstart) -> 
-  try error_messagebis filename (lexeme, lexstart) 0    
+let error_message = fun filename (lexeme, lexstart) ->
+  try error_messagebis filename (lexeme, lexstart) 0
   with
     End_of_file ->
       ("PB in Common.error_message, position " ^ i_to_s lexstart ^
@@ -5417,18 +5647,18 @@ let error_message = fun filename (lexeme, lexstart) ->
 
 
 
-let error_message_short = fun filename (lexeme, lexstart) -> 
-  try 
+let error_message_short = fun filename (lexeme, lexstart) ->
+  try
   let charpos = lexstart in
   let (line, pos, linecontent) =  info_from_charpos charpos filename in
   sprintf "File \"%s\", line %d"  filename line
 
-  with End_of_file -> 
+  with End_of_file ->
     begin
       ("PB in Common.error_message, position " ^ i_to_s lexstart ^
           " given out of file:" ^ filename);
     end
-    
+
 
 
 (*****************************************************************************)
@@ -5437,17 +5667,17 @@ let error_message_short = fun filename (lexeme, lexstart) ->
 
 (* todo: keep also size of file, compute md5sum ? cos maybe the file
  * has changed!.
- * 
+ *
  * todo: could also compute the date, or some version info of the program,
  * can record the first date when was found a OK, the last date where
- * was ok, and then first date when found fail. So the 
+ * was ok, and then first date when found fail. So the
  * Common.Ok would have more information that would be passed
  * to the Common.Pb of date * date * date * string   peut etre.
- * 
+ *
  * todo? maybe use plain text file instead of marshalling.
  *)
 
-type score_result = Ok | Pb of string 
+type score_result = Ok | Pb of string
  (* with sexp *)
 type score = (string (* usually a filename *), score_result) Hashtbl.t
  (* with sexp *)
@@ -5456,45 +5686,49 @@ type score_list = (string (* usually a filename *) * score_result) list
 
 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 = 
+let regression_testing_vs newscore bestscore =
 
   let newbestscore = empty_score () in
 
-  let allres = 
+  let allres =
     (hash_to_list newscore +> List.map fst)
       $+$
     (hash_to_list bestscore +> List.map fst)
   in
-  begin 
-    allres +> List.iter (fun res -> 
-      match 
+  begin
+    allres +> List.iter (fun res ->
+      match
         optionise (fun () -> Hashtbl.find newscore res),
         optionise (fun () -> Hashtbl.find bestscore res)
       with
-      | None, None -> raise Impossible
-      | Some x, None -> 
+      | None, None -> raise (Impossible 5)
+      | Some x, None ->
           Printf.printf "new test file appeared: %s\n" res;
           Hashtbl.add newbestscore res x;
-      | None, Some x -> 
+      | None, Some x ->
           Printf.printf "old test file disappeared: %s\n" res;
-      | Some newone, Some bestone -> 
+      | Some newone, Some bestone ->
           (match newone, bestone with
-          | Ok, Ok -> 
+          | Ok, Ok ->
               Hashtbl.add newbestscore res Ok
-          | Pb x, Ok -> 
+          | Pb x, Ok ->
               Printf.printf
 		"PBBBBBBBB: a test file does not work anymore!!! : %s\n" res;
               Printf.printf "Error : %s\n" x;
               Hashtbl.add newbestscore res Ok
-          | Ok, Pb x -> 
+          | Ok, Pb x ->
               Printf.printf "Great: a test file now works: %s\n" res;
               Hashtbl.add newbestscore res Ok
-          | Pb x, Pb y -> 
+          | Pb x, Pb y ->
               Hashtbl.add newbestscore res (Pb x);
               if not (x =$= y)
-              then begin 
+              then begin
                 Printf.printf
 		  "Semipb: still error but not same error : %s\n" res;
                 Printf.printf "%s\n" (chop ("Old error: " ^ y));
@@ -5506,13 +5740,13 @@ let regression_testing_vs newscore bestscore =
     newbestscore
   end
 
-let regression_testing newscore best_score_file = 
+let regression_testing newscore best_score_file =
 
   pr2 ("regression file: "^ best_score_file);
-  let (bestscore : score) = 
+  let (bestscore : score) =
     if not (Sys.file_exists best_score_file)
     then write_value (empty_score()) best_score_file;
-    get_value best_score_file 
+    get_value best_score_file
   in
   let newbestscore = regression_testing_vs newscore bestscore in
   write_value newbestscore (best_score_file ^ ".old");
@@ -5522,27 +5756,27 @@ let regression_testing newscore best_score_file =
 
 
 
-let string_of_score_result v = 
-  match v with 
-  | Ok -> "Ok" 
+let string_of_score_result v =
+  match v with
+  | Ok -> "Ok"
   | Pb s -> "Pb: " ^ s
 
-let total_scores score = 
+let total_scores score =
   let total = hash_to_list score +> List.length in
   let good  = hash_to_list score +> List.filter
     (fun (s, v) -> v =*= Ok) +> List.length in
   good, total
-   
 
-let print_total_score score = 
+
+let print_total_score score =
   pr2 "--------------------------------";
   pr2 "total score";
   pr2 "--------------------------------";
   let (good, total) = total_scores score in
   pr2 (sprintf "good = %d/%d" good total)
 
-let print_score score = 
-  score +> hash_to_list +> List.iter (fun (k, v) -> 
+let print_score score =
+  score +> hash_to_list +> List.iter (fun (k, v) ->
     pr2 (sprintf "% s --> %s" k (string_of_score_result v))
   );
   print_total_score score;
@@ -5560,33 +5794,33 @@ let print_score score =
 type ('a, 'b) scoped_env = ('a, 'b) assoc list
 
 (*
-let rec lookup_env f env = 
-  match env with 
+let rec lookup_env f env =
+  match env with
   | [] -> raise Not_found
   | []::zs -> lookup_env f zs
-  | (x::xs)::zs -> 
+  | (x::xs)::zs ->
       match f x with
       | None -> lookup_env f (xs::zs)
       | Some y -> y
 
-let member_env_key k env = 
-  try 
+let member_env_key k env =
+  try
     let _ = lookup_env (fun (k',v) -> if k = k' then Some v else None) env in
     true
   with Not_found -> false
 
 *)
 
-let rec lookup_env k env = 
-  match env with 
+let rec lookup_env k env =
+  match env with
   | [] -> raise Not_found
   | []::zs -> lookup_env k zs
-  | ((k',v)::xs)::zs -> 
+  | ((k',v)::xs)::zs ->
       if k =*= k'
-      then v 
+      then v
       else lookup_env k (xs::zs)
 
-let member_env_key k env = 
+let member_env_key k env =
   match optionise (fun () -> lookup_env k env) with
   | None -> false
   | Some _ -> true
@@ -5595,14 +5829,14 @@ let member_env_key k env =
 let new_scope scoped_env = scoped_env := []::!scoped_env
 let del_scope scoped_env = scoped_env := List.tl !scoped_env
 
-let do_in_new_scope scoped_env f = 
+let do_in_new_scope scoped_env f =
   begin
     new_scope scoped_env;
     let res = f() in
     del_scope scoped_env;
     res
   end
-  
+
 let add_in_scope scoped_env def =
   let (current, older) = uncons !scoped_env in
   scoped_env := (def::current)::older
@@ -5624,33 +5858,41 @@ let empty_scoped_h_env () = {
   scoped_h = Hashtbl.create 101;
   scoped_list = [[]];
 }
-let clone_scoped_h_env x = 
+let clone_scoped_h_env x =
   { scoped_h = Hashtbl.copy x.scoped_h;
     scoped_list = x.scoped_list;
   }
 
-let rec lookup_h_env k env = 
-  Hashtbl.find env.scoped_h k 
+let rec lookup_h_env k env =
+  Hashtbl.find env.scoped_h k
 
-let member_h_env_key k env = 
+let member_h_env_key k env =
   match optionise (fun () -> lookup_h_env k env) with
   | None -> false
   | Some _ -> true
 
 
-let new_scope_h scoped_env = 
+let new_scope_h scoped_env =
   scoped_env := {!scoped_env with scoped_list = []::!scoped_env.scoped_list}
-let del_scope_h scoped_env = 
+
+let del_scope_h scoped_env =
   begin
     List.hd !scoped_env.scoped_list +> List.iter (fun (k, v) ->
       Hashtbl.remove !scoped_env.scoped_h k
     );
-    scoped_env := {!scoped_env with scoped_list = 
+    scoped_env := {!scoped_env with scoped_list =
         List.tl !scoped_env.scoped_list
     }
   end
 
-let do_in_new_scope_h scoped_env f = 
+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;
     let res = f() in
@@ -5658,16 +5900,16 @@ let do_in_new_scope_h scoped_env f =
     res
   end
 
-(*  
+(*
 let add_in_scope scoped_env def =
   let (current, older) = uncons !scoped_env in
   scoped_env := (def::current)::older
 *)
 
-let add_in_scope_h x (k,v) = 
+let add_in_scope_h x (k,v) =
   begin
     Hashtbl.add !x.scoped_h k v;
-    x := { !x with scoped_list = 
+    x := { !x with scoped_list =
         ((k,v)::(List.hd !x.scoped_list))::(List.tl !x.scoped_list);
     };
   end
@@ -5678,13 +5920,13 @@ let add_in_scope_h x (k,v) =
 
 (* let ansi_terminal = ref true *)
 
-let (_execute_and_show_progress_func:  (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref) 
- = ref 
-  (fun a b -> 
+let (_execute_and_show_progress_func:  (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref)
+ = ref
+  (fun a b ->
     failwith "no execute  yet, have you included common_extra.cmo?"
   )
 
- 
+
 
 let execute_and_show_progress len f =
     !_execute_and_show_progress_func len f
@@ -5700,27 +5942,27 @@ let execute_and_show_progress len f =
 
 let _init_random = Random.self_init ()
 (*
-let random_insert i l = 
+let random_insert i l =
     let p = Random.int (length l +1)
-    in let rec insert i p l = 
+    in let rec insert i p l =
       if (p = 0) then i::l else (hd l)::insert i (p-1) (tl l)
     in insert i p l
 
-let rec randomize_list = function 
+let rec randomize_list = function
   []  -> []
   | a::l -> random_insert a (randomize_list l)
 *)
-let random_list xs = 
-  List.nth xs (Random.int (length xs))                                           
+let random_list xs =
+  List.nth xs (Random.int (length xs))
 
 (* todo_opti: use fisher/yates algorithm.
- * ref: http://en.wikipedia.org/wiki/Knuth_shuffle 
- * 
- * public static void shuffle (int[] array) 
+ * ref: http://en.wikipedia.org/wiki/Knuth_shuffle
+ *
+ * public static void shuffle (int[] array)
  * {
  *  Random rng = new Random ();
  *  int n = array.length;
- *  while (--n > 0) 
+ *  while (--n > 0)
  *  {
  *    int k = rng.nextInt(n + 1);  // 0 <= k <= n (!)
  *    int temp = array[n];
@@ -5730,7 +5972,7 @@ let random_list xs =
  * }
 
  *)
-let randomize_list xs = 
+let randomize_list xs =
   let permut = permutation xs in
   random_list permut
 
@@ -5739,8 +5981,8 @@ let randomize_list xs =
 let random_subset_of_list num xs =
   let array = Array.of_list xs in
   let len = Array.length array in
-    
-  let h = Hashtbl.create 101 in 
+
+  let h = Hashtbl.create 101 in
   let cnt = ref num in
   while !cnt > 0 do
     let x = Random.int len in
@@ -5759,64 +6001,64 @@ let random_subset_of_list num xs =
 (* Flags and actions *)
 (*****************************************************************************)
 
-(* I put it inside a func as it can help to give a chance to 
- * change the globals before getting the options as some 
+(* I put it inside a func as it can help to give a chance to
+ * change the globals before getting the options as some
  * options sometimes may want to show the default value.
  *)
-let cmdline_flags_devel () = 
+let cmdline_flags_devel () =
   [
-    "-debugger",         Arg.Set debugger , 
+    "-debugger",         Arg.Set debugger ,
     "   option to set if launched inside ocamldebug";
-    "-profile",          Arg.Unit (fun () -> profile := PALL), 
+    "-profile",          Arg.Unit (fun () -> profile := PALL),
     "   gather timing information about important functions";
   ]
 let cmdline_flags_verbose () =
   [
-    "-verbose_level",  Arg.Set_int verbose_level, 
+    "-verbose_level",  Arg.Set_int verbose_level,
     " <int> guess what";
-    "-disable_pr2_once",     Arg.Set disable_pr2_once, 
+    "-disable_pr2_once",     Arg.Set disable_pr2_once,
     "   to print more messages";
-    "-show_trace_profile",          Arg.Set show_trace_profile, 
+    "-show_trace_profile",          Arg.Set show_trace_profile,
     "   show trace";
   ]
 
-let cmdline_flags_other () = 
+let cmdline_flags_other () =
   [
-    "-nocheck_stack",      Arg.Clear check_stack, 
+    "-nocheck_stack",      Arg.Clear check_stack,
     " ";
     "-batch_mode", Arg.Set _batch_mode,
     " no interactivity"
   ]
 
 (* potentially other common options but not yet integrated:
-   
-  "-timeout",        Arg.Set_int timeout, 
+
+  "-timeout",        Arg.Set_int timeout,
   "  <sec> interrupt LFS or buggy external plugins";
 
   (* can't be factorized because of the $ cvs stuff, we want the date
    * of the main.ml file, not common.ml
    *)
-  "-version",   Arg.Unit (fun () -> 
+  "-version",   Arg.Unit (fun () ->
     pr2 "version: _dollar_Date: 2008/06/14 00:54:22 _dollar_";
     raise (Common.UnixExit 0)
-    ), 
+    ),
   "   guess what";
 
-  "-shorthelp", Arg.Unit (fun () -> 
+  "-shorthelp", Arg.Unit (fun () ->
     !short_usage_func();
     raise (Common.UnixExit 0)
-  ), 
+  ),
   "    see short list of options";
-  "-longhelp", Arg.Unit (fun () -> 
+  "-longhelp", Arg.Unit (fun () ->
     !long_usage_func();
     raise (Common.UnixExit 0)
-    ), 
-  "-help", Arg.Unit (fun () -> 
+    ),
+  "-help", Arg.Unit (fun () ->
     !long_usage_func();
     raise (Common.UnixExit 0)
   ),
   " ";
-  "--help", Arg.Unit (fun () -> 
+  "--help", Arg.Unit (fun () ->
     !long_usage_func();
     raise (Common.UnixExit 0)
   ),
@@ -5824,7 +6066,7 @@ let cmdline_flags_other () =
 
 *)
 
-let cmdline_actions () = 
+let cmdline_actions () =
   [
     "-test_check_stack", "  <limit>",
     mk_action_1_arg test_check_stack_size;
@@ -5836,7 +6078,7 @@ let cmdline_actions () =
 (*****************************************************************************)
 (* stuff put here cos of of forward definition limitation of ocaml *)
 
-    
+
 (* Infix trick, seen in jane street lib and harrop's code, and maybe in GMP *)
 module Infix = struct
   let (+>) = (+>)
@@ -5845,15 +6087,15 @@ module Infix = struct
 end
 
 
-let main_boilerplate f = 
-  if not (!Sys.interactive) then 
-    exn_to_real_unixexit (fun () -> 
+let main_boilerplate f =
+  if not (!Sys.interactive) then
+    exn_to_real_unixexit (fun () ->
 
-      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ -> 
+      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ ->
         pr2 "C-c intercepted, will do some cleaning before exiting";
         (* But if do some try ... with e -> and if do not reraise the exn,
          * the bubble never goes at top and so I cant really C-c.
-         * 
+         *
          * A solution would be to not raise, but do the erase_temp_file in the
          * syshandler, here, and then exit.
          * The current solution is to not do some wild  try ... with e
@@ -5864,21 +6106,22 @@ let main_boilerplate f =
       ));
 
       (* The finalize below makes it tedious to go back to exn when use
-       * 'back' in the debugger. Hence this special case. But the 
-       * Common.debugger will be set in main(), so too late, so 
+       * 'back' in the debugger. Hence this special case. But the
+       * Common.debugger will be set in main(), so too late, so
        * have to be quicker
        *)
       if Sys.argv +> Array.to_list +> List.exists (fun x -> x =$= "-debugger")
       then debugger := true;
 
-      finalize          (fun ()-> 
-        pp_do_in_zero_box (fun () -> 
+      finalize          (fun ()->
+        pp_do_in_zero_box (fun () ->
           f(); (* <---- here it is *)
         ))
-       (fun()-> 
-         if !profile <> PNONE 
+       (fun()->
+         if !profile <> PNONE
          then pr2 (profile_diagnostic ());
          erase_temp_files ();
+	 clear_pr2_once()
        )
     )
 (* let _ = if not !Sys.interactive then (main ()) *)
@@ -5890,30 +6133,58 @@ let md5sum_of_string s =
       (Filename.quote s)
   in
   match cmd_to_list com with
-  | [s] -> 
+  | [s] ->
       (*pr2 s;*)
       s
   | _ -> failwith "md5sum_of_string wrong output"
 
 
+
+let with_pr2_to_string f =
+  let file = new_temp_file "pr2" "out" in
+  redirect_stdout_stderr file f;
+  cat file
+
+(* julia: convert something printed using format to print into a string *)
+let format_to_string f =
+  let (nm,o) = Filename.open_temp_file "format_to_s" ".out" in
+  Format.set_formatter_out_channel o;
+  let _ = f() in
+  Format.print_newline();
+  Format.print_flush();
+  Format.set_formatter_out_channel stdout;
+  close_out o;
+  let i = open_in nm in
+  let lines = ref [] in
+  let rec loop _ =
+    let cur = input_line i in
+    lines := cur :: !lines;
+    loop() in
+  (try loop() with End_of_file -> ());
+  close_in i;
+  command2 ("rm -f " ^ nm);
+  String.concat "\n" (List.rev !lines)
+
+
+
 (*****************************************************************************)
 (* Misc/test *)
 (*****************************************************************************)
 
-let (generic_print: 'a -> string -> string) = fun v typ -> 
+let (generic_print: 'a -> string -> string) = fun v typ ->
   write_value v "/tmp/generic_print";
-  command2 
+  command2
    ("printf 'let (v:" ^ typ ^ ")= Common.get_value \"/tmp/generic_print\" " ^
      " in v;;' " ^
-     " | calc.top > /tmp/result_generic_print"); 
-   cat "/tmp/result_generic_print" 
+     " | calc.top > /tmp/result_generic_print");
+   cat "/tmp/result_generic_print"
    +> drop_while (fun e -> not (e =~ "^#.*")) +> tail
    +> unlines
-   +> (fun s -> 
-       if (s =~ ".*= \\(.+\\)") 
-       then matched1 s 
+   +> (fun s ->
+       if (s =~ ".*= \\(.+\\)")
+       then matched1 s
        else "error in generic_print, not good format:" ^ s)
-   
+
 (* let main () = pr (generic_print [1;2;3;4] "int list") *)
 
 class ['a] olist (ys: 'a list) =
@@ -5921,13 +6192,13 @@ class ['a] olist (ys: 'a list) =
     val xs = ys
     method view = xs
 (*    method fold f a = List.fold_left f a xs *)
-    method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b = 
+    method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b =
       fun f accu -> List.fold_left f accu xs
   end
 
 
 (* let _ = write_value ((new setb[])#add 1) "/tmp/test" *)
-let typing_sux_test () = 
+let typing_sux_test () =
    let x = Obj.magic [1;2;3] in
    let f1 xs = List.iter print_int xs in
    let f2 xs = List.iter print_string xs in