Imported Upstream version 8.5~beta1+dfsg

129 files changed, 11135 insertions, 5426 deletions

diff --git a/lib/aux_file.ml b/lib/aux_file.ml
new file mode 100644
index 00000000..c9018c9e
--- /dev/null
+++ b/lib/aux_file.ml
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* The file format is a header
+ *     ("COQAUX%d %s %s\n" version hex_hash path)
+ * followed by an arbitrary number of entries
+ *     ("%d %d %s %S\n" loc_begin loc_end key value)  *)
+
+open Filename
+
+let version = 1
+
+let oc = ref None
+
+let aux_file_name_for vfile =
+  dirname vfile ^ "/." ^ chop_extension(basename vfile) ^ ".aux"
+
+let mk_absolute vfile =
+  let vfile = CUnix.remove_path_dot vfile in
+  if Filename.is_relative vfile then CUnix.correct_path vfile (Sys.getcwd ())
+  else vfile
+
+let start_aux_file_for vfile =
+  let vfile = mk_absolute vfile in
+  oc := Some (open_out (aux_file_name_for vfile));
+  Printf.fprintf (Option.get !oc) "COQAUX%d %s %s\n"
+    version (Digest.to_hex (Digest.file vfile)) vfile
+
+let stop_aux_file () =
+  close_out (Option.get !oc);
+  oc := None
+
+let recording () = not (Option.is_empty !oc)
+
+module H = Map.Make(struct type t = int * int let compare = compare end)
+module M = Map.Make(String)
+type data = string M.t
+type aux_file = data H.t
+
+let empty_aux_file = H.empty
+
+let get aux loc key = M.find key (H.find (Loc.unloc loc) aux)
+
+let record_in_aux_at loc key v =
+  Option.iter (fun oc ->
+    let i, j = Loc.unloc loc in
+    Printf.fprintf oc "%d %d %s %S\n" i j key v)
+  !oc
+
+let current_loc = ref Loc.ghost
+
+let record_in_aux_set_at loc = current_loc := loc
+
+let record_in_aux key v = record_in_aux_at !current_loc key v
+
+let set h loc k v =
+  let m = try H.find loc h with Not_found -> M.empty in
+  H.add loc (M.add k v m) h
+
+let load_aux_file_for vfile =
+  let vfile = mk_absolute vfile in
+  let ret3 x y z = x, y, z in
+  let ret4 x y z t = x, y, z, t in
+  let h = ref empty_aux_file in
+  let add loc k v = h := set !h loc k v in
+  let aux_fname = aux_file_name_for vfile in
+  try
+    let ic = open_in aux_fname in
+    let ver, hash, fname = Scanf.fscanf ic "COQAUX%d %s %s\n" ret3 in
+    if ver <> version then raise (Failure "aux file version mismatch");
+    if fname <> vfile then
+      raise (Failure "aux file name mismatch");
+    let only_dummyloc = Digest.to_hex (Digest.file vfile) <> hash in
+    while true do
+      let i, j, k, v = Scanf.fscanf ic "%d %d %s %S\n" ret4 in
+      if not only_dummyloc || (i = 0 && j = 0) then add (i,j) k v;
+    done;
+    raise End_of_file
+  with
+  | End_of_file -> !h
+  | Sys_error s | Scanf.Scan_failure s
+  | Failure s | Invalid_argument s ->
+     Flags.if_verbose
+       Pp.msg_warning Pp.(str"Loading file "++str aux_fname++str": "++str s);
+     empty_aux_file
+
+let set h loc k v = set h (Loc.unloc loc) k v
diff --git a/lib/aux_file.mli b/lib/aux_file.mli
new file mode 100644
index 00000000..e340fc65
--- /dev/null
+++ b/lib/aux_file.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type aux_file
+
+val load_aux_file_for : string -> aux_file
+val get : aux_file -> Loc.t -> string -> string
+val empty_aux_file : aux_file
+val set : aux_file -> Loc.t -> string -> string -> aux_file
+
+val start_aux_file_for : string -> unit
+val stop_aux_file : unit -> unit 
+val recording : unit -> bool
+
+val record_in_aux_at : Loc.t -> string -> string -> unit
+val record_in_aux : string -> string -> unit
+val record_in_aux_set_at : Loc.t -> unit
diff --git a/lib/backtrace.ml b/lib/backtrace.ml
new file mode 100644
index 00000000..b3b8bdea
--- /dev/null
+++ b/lib/backtrace.ml
@@ -0,0 +1,116 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+type raw_frame =
+| Known_location of bool   (* is_raise *)
+  * string (* filename *)
+  * int    (* line number *)
+  * int    (* start char *)
+  * int    (* end char *)
+| Unknown_location of bool (*is_raise*)
+
+type location = {
+  loc_filename : string;
+  loc_line : int;
+  loc_start : int;
+  loc_end : int;
+}
+
+type frame = { frame_location : location option; frame_raised : bool; }
+
+external get_exception_backtrace: unit -> raw_frame array option
+  = "caml_get_exception_backtrace"
+
+type t = raw_frame array list
+(** List of partial raw stack frames, in reverse order *)
+
+let empty = []
+
+let of_raw = function
+| Unknown_location r ->
+  { frame_location = None; frame_raised = r; }
+| Known_location (r, file, line, st, en) ->
+  let loc = {
+    loc_filename = file;
+    loc_line = line;
+    loc_start = st;
+    loc_end = en;
+  } in
+  { frame_location = Some loc; frame_raised = r; }
+
+let rec repr_aux accu = function
+| [] -> accu
+| fragment :: stack ->
+  let len = Array.length fragment in
+  let rec append accu i =
+    if i = len then accu
+    else append (of_raw fragment.(i) :: accu) (succ i)
+  in
+  repr_aux (append accu 0) stack
+
+let repr bt = repr_aux [] (List.rev bt)
+
+let push stack = match get_exception_backtrace () with
+| None -> []
+| Some frames -> frames :: stack
+
+(** Utilities *)
+
+let print_frame frame =
+  let raise = if frame.frame_raised then "raise" else "frame" in
+  match frame.frame_location with
+  | None -> Printf.sprintf "%s @ unknown" raise
+  | Some loc ->
+    Printf.sprintf "%s @ file \"%s\", line %d, characters %d-%d"
+      raise loc.loc_filename loc.loc_line loc.loc_start loc.loc_end
+
+(** Exception manipulation *)
+
+let backtrace : t Exninfo.t = Exninfo.make ()
+
+let is_recording = ref false
+
+let record_backtrace b =
+  let () = Printexc.record_backtrace b in
+  is_recording := b
+
+let get_backtrace e =
+  Exninfo.get e backtrace
+
+let add_backtrace e =
+  if !is_recording then
+    (** This must be the first function call, otherwise the stack may be
+        destroyed *)
+    let current = get_exception_backtrace () in
+    let info = Exninfo.info e in
+    begin match current with
+    | None -> (e, info)
+    | Some fragment ->
+      let bt = match get_backtrace info with
+      | None -> []
+      | Some bt -> bt
+      in
+      let bt = fragment :: bt in
+      (e, Exninfo.add info backtrace bt)
+    end
+  else
+    let info = Exninfo.info e in
+    (e, info)
+
+let app_backtrace ~src ~dst =
+  if !is_recording then
+    match get_backtrace src with
+    | None -> dst
+    | Some bt ->
+      match get_backtrace dst with
+      | None ->
+        Exninfo.add dst backtrace bt
+      | Some nbt ->
+        let bt = bt @ nbt in
+        Exninfo.add dst backtrace bt
+  else dst
diff --git a/lib/backtrace.mli b/lib/backtrace.mli
new file mode 100644
index 00000000..dd82165b
--- /dev/null
+++ b/lib/backtrace.mli
@@ -0,0 +1,96 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** * Low-level management of OCaml backtraces.
+
+  Currently, OCaml manages its backtraces in a very imperative way. That is to
+  say, it only keeps track of the stack destroyed by the last raised exception.
+  So we have to be very careful when using this module not to do silly things.
+
+  Basically, you need to manually handle the reraising of exceptions. In order
+  to do so, each time the backtrace is lost, you must [push] the stack fragment.
+  This essentially occurs whenever a [with] handler is crossed.
+
+*)
+
+(** {5 Backtrace information} *)
+
+type location = {
+  loc_filename : string;
+  loc_line : int;
+  loc_start : int;
+  loc_end : int;
+}
+(** OCaml debugging information for function calls. *)
+
+type frame = { frame_location : location option; frame_raised : bool; }
+(** A frame contains two informations: its optional physical location, and
+    whether it raised the exception or let it pass through. *)
+
+type t
+(** Type of backtraces. They're essentially stack of frames. *)
+
+val empty : t
+(** Empty frame stack. *)
+
+val push : t -> t
+(** Add the current backtrace information to a given backtrace. *)
+
+val repr : t -> frame list
+(** Represent a backtrace as a list of frames. Leftmost element is the outermost
+    call. *)
+
+(** {5 Utilities} *)
+
+val print_frame : frame -> string
+(** Represent a frame. *)
+
+(** {5 Exception handling} *)
+
+val record_backtrace : bool -> unit
+(** Whether to activate the backtrace recording mechanism. Note that it will
+    only work whenever the program was compiled with the [debug] flag. *)
+
+val get_backtrace : Exninfo.info -> t option
+(** Retrieve the optional backtrace coming with the exception. *)
+
+val add_backtrace : exn -> Exninfo.iexn
+(** Add the current backtrace information to the given exception.
+
+    The intended use case is of the form: {[
+
+    try foo
+      with
+      | Bar -> bar
+      | err -> let err = add_backtrace err in baz
+
+    ]}
+
+    WARNING: any intermediate code between the [with] and the handler may
+    modify the backtrace. Yes, that includes [when] clauses. Ideally, what you
+    should do is something like: {[
+
+    try foo
+      with err ->
+        let err = add_backtrace err in
+        match err with
+        | Bar -> bar
+        | err -> baz
+
+    ]}
+
+    I admit that's a bit heavy, but there is not much to do...
+
+*)
+
+val app_backtrace : src:Exninfo.info -> dst:Exninfo.info -> Exninfo.info
+(** Append the backtrace from [src] to [dst]. The returned exception is [dst]
+    except for its backtrace information. This is targeted at container
+    exceptions, that is, exceptions that contain exceptions. This way, one can
+    transfer the backtrace from the container to the underlying exception, as if
+    the latter was the one originally raised. *)
diff --git a/lib/bigint.ml b/lib/bigint.ml
index 42a71f83..e739c7a1 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -43,11 +43,11 @@ let size =
 
 let format_size =
   (* How to parametrize a printf format *)
-  if size = 4 then Printf.sprintf "%04d"
-  else if size = 9 then Printf.sprintf "%09d"
+  if Int.equal size 4 then Printf.sprintf "%04d"
+  else if Int.equal size 9 then Printf.sprintf "%09d"
   else fun n ->
     let rec aux j l n =
-      if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
+      if Int.equal j size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
     in String.concat "" (aux 0 [] n)
 
 (* The base is 10^size *)
@@ -63,27 +63,31 @@ module ArrayInt = struct
 
 (* Basic numbers *)
 let zero = [||]
-let neg_one = [|-1|]
+
+let is_zero = function
+| [||] -> true
+| _ -> false
 
 (* An array is canonical when
    - it is empty
    - it is [|-1|]
    - its first bloc is in [-base;-1[U]0;base[
      and the other blocs are in [0;base[. *)
-
+(*
 let canonical n =
   let ok x = (0 <= x && x < base) in
-  let rec ok_tail k = (k = 0) || (ok n.(k) && ok_tail (k-1)) in
-  let ok_init x = (-base <= x && x < base && x <> -1 && x <> 0)
+  let rec ok_tail k = (Int.equal k 0) || (ok n.(k) && ok_tail (k-1)) in
+  let ok_init x = (-base <= x && x < base && not (Int.equal x (-1)) && not (Int.equal x 0))
   in
-  (n = [||]) || (n = [|-1|]) ||
+  (is_zero n) || (match n with [|-1|] -> true | _ -> false) ||
     (ok_init n.(0) && ok_tail (Array.length n - 1))
+*)
 
 (* [normalize_pos] : removing initial blocks of 0 *)
 
 let normalize_pos n =
   let k = ref 0 in
-  while !k < Array.length n & n.(!k) = 0 do incr k done;
+  while !k < Array.length n && Int.equal n.(!k) 0 do incr k done;
   Array.sub n !k (Array.length n - !k)
 
 (* [normalize_neg] : avoid (-1) as first bloc.
@@ -92,32 +96,32 @@ let normalize_pos n =
 
 let normalize_neg n =
   let k = ref 1 in
-  while !k < Array.length n & n.(!k) = base - 1 do incr k done;
+  while !k < Array.length n && Int.equal n.(!k) (base - 1) do incr k done;
   let n' = Array.sub n !k (Array.length n - !k) in
-  if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
+  if Int.equal (Array.length n') 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
 
 (* [normalize] : avoid 0 and (-1) as first bloc.
    input: an array with first bloc in [-base;base[ and others in [0;base[
    output: a canonical array *)
 
-let rec normalize n =
-  if Array.length n = 0 then n
-  else if n.(0) = -1 then normalize_neg n
-  else if n.(0) = 0 then normalize_pos n
+let normalize n =
+  if Int.equal (Array.length n) 0 then n
+  else if Int.equal n.(0) (-1) then normalize_neg n
+  else if Int.equal n.(0) 0 then normalize_pos n
   else n
 
 (* Opposite (expects and returns canonical arrays) *)
 
 let neg m =
-  if m = zero then zero else
+  if is_zero m then zero else
   let n = Array.copy m in
   let i = ref (Array.length m - 1) in
-  while !i > 0 & n.(!i) = 0 do decr i done;
-  if !i = 0 then begin
+  while !i > 0 && Int.equal n.(!i) 0 do decr i done;
+  if Int.equal !i 0 then begin
     n.(0) <- - n.(0);
     (* n.(0) cannot be 0 since m is canonical *)
-    if n.(0) = -1 then normalize_neg n
-    else if n.(0) = base then (n.(0) <- 0; Array.append [| 1 |] n)
+    if Int.equal n.(0) (-1) then normalize_neg n
+    else if Int.equal n.(0) base then (n.(0) <- 0; Array.append [| 1 |] n)
     else n
   end else begin
     (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *)
@@ -132,10 +136,10 @@ let neg m =
 
 let push_carry r j =
   let j = ref j in
-  while !j > 0 & r.(!j) < 0 do
+  while !j > 0 && r.(!j) < 0 do
     r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1
   done;
-  while !j > 0 & r.(!j) >= base do
+  while !j > 0 && r.(!j) >= base do
     r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1
   done;
   (* here r.(0) could be in [-2*base;2*base-1] *)
@@ -144,7 +148,7 @@ let push_carry r j =
   else normalize r (* in case r.(0) is 0 or -1 *)
 
 let add_to r a j =
-  if a = zero then r else begin
+  if is_zero a then r else begin
   for i = Array.length r - 1 downto j+1 do
     r.(i) <- r.(i) + a.(i-j);
     if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1)
@@ -158,7 +162,7 @@ let add n m =
   if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d)
 
 let sub_to r a j =
-  if a = zero then r else begin
+  if is_zero a then r else begin
   for i = Array.length r - 1 downto j+1 do
     r.(i) <- r.(i) - a.(i-j);
     if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1)
@@ -172,10 +176,10 @@ let sub n m =
   if d >= 0 then sub_to (Array.copy n) m d
   else let r = neg m in add_to r n (Array.length r - Array.length n)
 
-let rec mult m n =
-  if m = zero or n = zero then zero else
+let mult m n =
+  if is_zero m || is_zero n then zero else
   let l = Array.length m + Array.length n in
-  let r = Array.create l 0 in
+  let r = Array.make l 0 in
   for i = Array.length m - 1 downto 0 do
     for j = Array.length n - 1 downto 0 do
       let p = m.(i) * n.(j) + r.(i+j+1) in
@@ -184,49 +188,62 @@ let rec mult m n =
         then (p + 1) / base - 1, (p + 1) mod base + base - 1
         else p / base, p mod base in
       r.(i+j+1) <- s;
-      if q <> 0 then r.(i+j) <- r.(i+j) + q;
+      if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q;
     done
   done;
   normalize r
 
 (* Comparisons *)
 
-let is_strictly_neg n = n<>[||] && n.(0) < 0
-let is_strictly_pos n = n<>[||] && n.(0) > 0
-let is_neg_or_zero n = n=[||] or n.(0) < 0
-let is_pos_or_zero n = n=[||] or n.(0) > 0
+let is_strictly_neg n = not (is_zero n) && n.(0) < 0
+let is_strictly_pos n = not (is_zero n) && n.(0) > 0
+let is_neg_or_zero n = is_zero n || n.(0) < 0
+let is_pos_or_zero n = is_zero n || n.(0) > 0
+
+(* Is m without its i first blocs less then n without its j first blocs ?
+   Invariant : |m|-i = |n|-j *)
 
 let rec less_than_same_size m n i j =
   i < Array.length m &&
-  (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1)))
+  (m.(i) < n.(j) || (Int.equal m.(i) n.(j) && less_than_same_size m n (i+1) (j+1)))
 
 let less_than m n =
   if is_strictly_neg m then
-    is_pos_or_zero n or Array.length m > Array.length n
-      or (Array.length m = Array.length n && less_than_same_size m n 0 0)
+    is_pos_or_zero n || Array.length m > Array.length n
+      || (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0)
   else
-    is_strictly_pos n && (Array.length m < Array.length n or
-    (Array.length m = Array.length n && less_than_same_size m n 0 0))
+    is_strictly_pos n && (Array.length m < Array.length n ||
+    (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0))
 
 (* For this equality test it is critical that n and m are canonical *)
 
-let equal m n = (m = n)
+let rec array_eq len v1 v2 i =
+  if Int.equal len i then true
+  else
+    Int.equal v1.(i) v2.(i) && array_eq len v1 v2 (succ i)
+
+let equal m n =
+  let lenm = Array.length m in
+  let lenn = Array.length n in
+  (Int.equal lenm lenn) && (array_eq lenm m n 0)
+
+(* Is m without its k top blocs less than n ? *)
 
 let less_than_shift_pos k m n =
   (Array.length m - k < Array.length n)
-  or (Array.length m - k = Array.length n && less_than_same_size m n k 0)
+  || (Int.equal (Array.length m - k) (Array.length n) && less_than_same_size m n k 0)
 
 let rec can_divide k m d i =
-  (i = Array.length d) or
-  (m.(k+i) > d.(i)) or
-  (m.(k+i) = d.(i) && can_divide k m d (i+1))
+  (Int.equal i (Array.length d)) ||
+  (m.(k+i) > d.(i)) ||
+  (Int.equal m.(k+i) d.(i) && can_divide k m d (i+1))
 
 (* For two big nums m and d and a small number q,
    computes m - d * q * base^(|m|-|d|-k) in-place (in m).
    Both m d and q are positive. *)
 
 let sub_mult m d q k =
-  if q <> 0 then
+  if not (Int.equal q 0) then
   for i = Array.length d - 1 downto 0 do
     let v = d.(i) * q in
     m.(k+i) <- m.(k+i) - v mod base;
@@ -249,17 +266,17 @@ let euclid m d =
   let isnegm, m =
     if is_strictly_neg m then (-1),neg m else 1,Array.copy m in
   let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in
-  if d = zero then raise Division_by_zero;
+  if is_zero d then raise Division_by_zero;
   let q,r =
     if less_than m d then (zero,m) else
     let ql = Array.length m - Array.length d in
-    let q = Array.create (ql+1) 0 in
+    let q = Array.make (ql+1) 0 in
     let i = ref 0 in
     while not (less_than_shift_pos !i m d) do
-      if m.(!i)=0 then incr i else
+      if Int.equal m.(!i) 0 then incr i else
       if can_divide !i m d 0 then begin
         let v =
-          if Array.length d > 1 && d.(0) <> m.(!i) then
+          if Array.length d > 1 && not (Int.equal d.(0) m.(!i)) then
             (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1)
           else
             m.(!i) / d.(0) in
@@ -276,30 +293,30 @@ let euclid m d =
       end
     done;
     (normalize q, normalize m) in
-  (if isnegd * isnegm = -1 then neg q else q),
-  (if isnegm = -1 then neg r else r)
+  (if Int.equal (isnegd * isnegm) (-1) then neg q else q),
+  (if Int.equal isnegm (-1) then neg r else r)
 
 (* Parsing/printing ordinary 10-based numbers *)
 
 let of_string s =
   let len = String.length s in
-  let isneg = len > 1 & s.[0] = '-' in
+  let isneg = len > 1 && s.[0] == '-' in
   let d = ref (if isneg then 1 else 0) in
-  while !d < len && s.[!d] = '0' do incr d done;
-  if !d = len then zero else
+  while !d < len && s.[!d] == '0' do incr d done;
+  if Int.equal !d len then zero else
   let r = (len - !d) mod size in
   let h = String.sub s (!d) r in
-  let e = if h<>"" then 1 else 0 in
+  let e = match h with "" -> 0 | _ -> 1 in
   let l = (len - !d) / size in
-  let a = Array.create (l + e) 0 in
-  if e=1 then a.(0) <- int_of_string h;
-  for i=1 to l do
+  let a = Array.make (l + e) 0 in
+  if Int.equal e 1 then a.(0) <- int_of_string h;
+  for i = 1 to l do
     a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size)
   done;
   if isneg then neg a else a
 
 let to_string_pos sgn n =
-   if Array.length n = 0 then "0" else
+   if Int.equal (Array.length n) 0 then "0" else
      sgn ^
      String.concat ""
       (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n)))
@@ -337,7 +354,7 @@ let mkarray n =
   t
 
 let ints_of_int n =
-  if n = 0 then [| |]
+  if Int.equal n 0 then [| |]
   else if small n then [| n |]
   else mkarray n
 
@@ -346,8 +363,8 @@ let of_int n =
 
 let of_ints n =
   let n = normalize n in (* TODO: using normalize here seems redundant now *)
-  if n = zero then Obj.repr 0 else
-  if Array.length n = 1 then Obj.repr n.(0) else
+  if is_zero n then Obj.repr 0 else
+  if Int.equal (Array.length n) 1 then Obj.repr n.(0) else
   Obj.repr n
 
 let coerce_to_int = (Obj.magic : Obj.t -> int)
@@ -361,7 +378,7 @@ let int_of_ints =
   let maxi = mkarray max_int and mini = mkarray min_int in
   fun t ->
     let l = Array.length t in
-    if (l > 3) || (l = 3 && (less_than maxi t || less_than t mini))
+    if (l > 3) || (Int.equal l 3 && (less_than maxi t || less_than t mini))
     then failwith "Bigint.to_int: too large";
     let sum = ref 0 in
     let pow = ref 1 in
@@ -379,28 +396,28 @@ let app_pair f (m, n) =
   (f m, f n)
 
 let add m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then of_int (coerce_to_int m + coerce_to_int n)
   else of_ints (add (to_ints m) (to_ints n))
 
 let sub m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then of_int (coerce_to_int m - coerce_to_int n)
   else of_ints (sub (to_ints m) (to_ints n))
 
 let mult m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then of_int (coerce_to_int m * coerce_to_int n)
   else of_ints (mult (to_ints m) (to_ints n))
 
 let euclid m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then app_pair of_int
     (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n)
   else app_pair of_ints (euclid (to_ints m) (to_ints n))
 
 let less_than m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then coerce_to_int m < coerce_to_int n
   else less_than (to_ints m) (to_ints n)
 
@@ -420,14 +437,17 @@ let mult_2 n = add n n
 
 let div2_with_rest n =
   let (q,b) = euclid n two in
-  (q, b = one)
+  (q, b == one)
 
 let is_strictly_neg n = is_strictly_neg (to_ints n)
 let is_strictly_pos n = is_strictly_pos (to_ints n)
 let is_neg_or_zero n = is_neg_or_zero (to_ints n)
 let is_pos_or_zero n = is_pos_or_zero (to_ints n)
 
-let equal m n = (m = n)
+let equal m n =
+  if Obj.is_block m && Obj.is_block n then
+    ArrayInt.equal (Obj.obj m) (Obj.obj n)
+  else m == n
 
 (* spiwack: computes n^m *)
 (* The basic idea of the algorithm is that n^(2m) = (n^2)^m *)
@@ -441,7 +461,7 @@ let pow  =
       odd_rest
     else
       let quo = m lsr 1 (* i.e. m/2 *)
-      and odd = (m land 1) <> 0 in
+      and odd = not (Int.equal (m land 1) 0) in
       pow_aux
 	(if odd then mult n odd_rest else odd_rest)
 	(mult n n)
diff --git a/lib/bigint.mli b/lib/bigint.mli
index dd2cdea6..02e3c1ad 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,6 +11,8 @@
 type bigint
 
 val of_string : string -> bigint
+(** May raise a Failure just as [int_of_string] on non-numerical strings *)
+
 val to_string : bigint -> string
 
 val of_int : int -> bigint
diff --git a/lib/cArray.ml b/lib/cArray.ml
new file mode 100644
index 00000000..16034543
--- /dev/null
+++ b/lib/cArray.ml
@@ -0,0 +1,528 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+module type S = module type of Array
+
+module type ExtS =
+sig
+  include S
+  val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+  val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
+  val is_empty : 'a array -> bool
+  val exists : ('a -> bool) -> 'a array -> bool
+  val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+  val for_all : ('a -> bool) -> 'a array -> bool
+  val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+  val for_all3 : ('a -> 'b -> 'c -> bool) ->
+    'a array -> 'b array -> 'c array -> bool
+  val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+    'a array -> 'b array -> 'c array -> 'd array -> bool
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+  val findi : (int -> 'a -> bool) -> 'a array -> int option
+  val hd : 'a array -> 'a
+  val tl : 'a array -> 'a array
+  val last : 'a array -> 'a
+  val cons : 'a -> 'a array -> 'a array
+  val rev : 'a array -> unit
+  val fold_right_i :
+    (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+  val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val fold_right2 :
+    ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+  val fold_left2 :
+    ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left3 :
+    ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
+  val fold_left2_i :
+    (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val map_to_list : ('a -> 'b) -> 'a array -> 'b list
+  val map_of_list : ('a -> 'b) -> 'a list -> 'b array
+  val chop : int -> 'a array -> 'a array * 'a array
+  val smartmap : ('a -> 'a) -> 'a array -> 'a array
+  val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array
+  val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+  val map_left : ('a -> 'b) -> 'a array -> 'b array
+  val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+  val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
+  val fold_map2' :
+    ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+  val distinct : 'a array -> bool
+  val rev_of_list : 'a list -> 'a array
+  val rev_to_list : 'a array -> 'a list
+  val filter_with : bool list -> 'a array -> 'a array
+end
+
+include Array
+
+let uget = Array.unsafe_get
+
+(* Arrays *)
+
+let compare cmp v1 v2 =
+  if v1 == v2 then 0
+  else
+    let len = Array.length v1 in
+    let c = Int.compare len (Array.length v2) in
+    if c <> 0 then c else
+      let rec loop i =
+        if i < 0 then 0
+        else
+          let x = uget v1 i in
+          let y = uget v2 i in
+          let c = cmp x y in
+          if c <> 0 then c
+          else loop (i - 1)
+      in
+      loop (len - 1)
+
+let equal cmp t1 t2 =
+  if t1 == t2 then true else
+    let len = Array.length t1 in
+    if not (Int.equal len (Array.length t2)) then false
+    else
+      let rec aux i =
+        if i < 0 then true
+        else
+          let x = uget t1 i in
+          let y = uget t2 i in
+          cmp x y && aux (pred i)
+      in
+      aux (len - 1)
+
+let is_empty array = Int.equal (Array.length array) 0
+
+let exists f v =
+  let rec exrec = function
+    | -1 -> false
+    | n -> f (uget v n) || (exrec (n-1))
+  in
+  exrec ((Array.length v)-1)
+
+let exists2 f v1 v2 =
+  let rec exrec = function
+    | -1 -> false
+    | n -> f (uget v1 n) (uget v2 n) || (exrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && exrec (lv1-1)
+
+let for_all f v =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v n) in
+      ans && (allrec (n-1))
+  in
+  allrec ((Array.length v)-1)
+
+let for_all2 f v1 v2 =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v1 n) (uget v2 n) in
+      ans && (allrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && allrec (pred lv1)
+
+let for_all3 f v1 v2 v3 =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v1 n)
+        (uget v2 n) (uget v3 n)
+      in
+      ans && (allrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
+
+let for_all4 f v1 v2 v3 v4 =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v1 n)
+        (uget v2 n) (uget v3 n) (uget v4 n)
+      in
+      ans && (allrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 &&
+  lv1 = Array.length v3 &&
+  lv1 = Array.length v4 &&
+  allrec (pred lv1)
+
+let for_all_i f i v =
+  let len = Array.length v in
+  let rec allrec i n =
+    n = len || f i (uget v n) && allrec (i+1) (n+1) in
+  allrec i 0
+
+exception Found of int
+
+let findi (pred: int -> 'a -> bool) (arr: 'a array) : int option =
+  try
+    for i=0 to Array.length arr - 1 do
+      if pred i (uget arr i) then raise (Found i) done;
+    None
+  with Found i -> Some i
+
+let hd v =
+  match Array.length v with
+    | 0 -> failwith "Array.hd"
+    | _ -> uget v 0
+
+let tl v =
+  match Array.length v with
+    | 0 -> failwith "Array.tl"
+    | n -> Array.sub v 1 (pred n)
+
+let last v =
+  match Array.length v with
+    | 0 -> failwith "Array.last"
+    | n -> uget v (pred n)
+
+let cons e v =
+  let len = Array.length v in
+  let ans = Array.make (Array.length v + 1) e in
+  let () = Array.blit v 0 ans 1 len in
+  ans
+
+let rev t =
+  let n=Array.length t in
+    if n <=0 then ()
+    else
+      for i = 0 to pred (n/2) do
+        let tmp = uget t ((pred n)-i) in
+        Array.unsafe_set t ((pred n)-i) (uget t i);
+        Array.unsafe_set t i tmp
+      done
+
+let fold_right_i f v a =
+  let rec fold a n =
+    if n=0 then a
+    else
+      let k = n-1 in
+      fold (f k (uget v k) a) k in
+  fold a (Array.length v)
+
+let fold_left_i f v a =
+  let n = Array.length a in
+  let rec fold i v = if i = n then v else fold (succ i) (f i v (uget a i)) in
+  fold 0 v
+
+let fold_right2 f v1 v2 a =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n=0 then a
+    else
+      let k = n-1 in
+      fold (f (uget v1 k) (uget v2 k) a) k in
+  if Array.length v2 <> lv1 then invalid_arg "Array.fold_right2";
+  fold a lv1
+
+let fold_left2 f a v1 v2 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a else fold (f a (uget v1 n) (uget v2 n)) (succ n)
+  in
+  if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2";
+  fold a 0
+
+let fold_left2_i f a v1 v2 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a else fold (f n a (uget v1 n) (uget v2 n)) (succ n)
+  in
+  if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2";
+  fold a 0
+
+let fold_left3 f a v1 v2 v3 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a
+    else fold (f a (uget v1 n) (uget v2 n) (uget v3 n)) (succ n)
+  in
+  if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
+    invalid_arg "Array.fold_left2";
+  fold a 0
+
+let fold_left_from n f a v =
+  let len = Array.length v in
+  let () = if n < 0 then invalid_arg "Array.fold_left_from" in
+  let rec fold a n =
+    if n >= len then a else fold (f a (uget v n)) (succ n)
+  in
+  fold a n
+
+let rev_of_list = function
+| [] -> [| |]
+| x :: l ->
+  let len = List.length l in
+  let ans = Array.make (succ len) x in
+  let rec set i = function
+  | [] -> ()
+  | x :: l ->
+    Array.unsafe_set ans i x;
+    set (pred i) l
+  in
+  let () = set (len - 1) l in
+  ans
+
+let map_to_list f v =
+  List.map f (Array.to_list v)
+
+let map_of_list f l =
+  let len = List.length l in
+  let rec fill i v = function
+  | [] -> ()
+  | x :: l ->
+    Array.unsafe_set v i (f x);
+    fill (succ i) v l
+  in
+  match l with
+  | [] -> [||]
+  | x :: l ->
+    let ans = Array.make len (f x) in
+    let () = fill 1 ans l in
+    ans
+
+let chop n v =
+  let vlen = Array.length v in
+  if n > vlen then failwith "Array.chop";
+  (Array.sub v 0 n, Array.sub v n (vlen-n))
+
+(* If none of the elements is changed by f we return ar itself.
+   The while loop looks for the first such an element.
+   If found, we break here and the new array is produced,
+   but f is not re-applied to elements that are already checked *)
+let smartmap f (ar : 'a array) =
+  let len = Array.length ar in
+  let i = ref 0 in
+  let break = ref true in
+  let temp = ref None in
+  while !break && (!i < len) do
+    let v = Array.unsafe_get ar !i in
+    let v' = f v in
+    if v == v' then incr i
+    else begin
+      break := false;
+      temp := Some v';
+    end
+  done;
+  if !i < len then begin
+    (** The array is not the same as the original one *)
+    let ans : 'a array = Array.copy ar in
+    let v = match !temp with None -> assert false | Some x -> x in
+    Array.unsafe_set ans !i v;
+    incr i;
+    while !i < len do
+      let v = Array.unsafe_get ar !i in
+      let v' = f v in
+      if v != v' then Array.unsafe_set ans !i v';
+      incr i
+    done;
+    ans
+  end else ar
+
+(** Same as [smartmap] but threads a state meanwhile *)
+let smartfoldmap f accu (ar : 'a array) =
+  let len = Array.length ar in
+  let i = ref 0 in
+  let break = ref true in
+  let r = ref accu in
+  (** This variable is never accessed unset *)
+  let temp = ref None in
+  while !break && (!i < len) do
+    let v = Array.unsafe_get ar !i in
+    let (accu, v') = f !r v in
+    r := accu;
+    if v == v' then incr i
+    else begin
+      break := false;
+      temp := Some v';
+    end
+  done;
+  if !i < len then begin
+    let ans : 'a array = Array.copy ar in
+    let v = match !temp with None -> assert false | Some x -> x in
+    Array.unsafe_set ans !i v;
+    incr i;
+    while !i < len do
+      let v = Array.unsafe_get ar !i in
+      let (accu, v') = f !r v in
+      r := accu;
+      if v != v' then Array.unsafe_set ans !i v';
+      incr i
+    done;
+    !r, ans
+  end else !r, ar
+
+let map2 f v1 v2 =
+  let len1 = Array.length v1 in
+  let len2 = Array.length v2 in
+  let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in
+  if Int.equal len1 0 then
+    [| |]
+  else begin
+    let res = Array.make len1 (f (uget v1 0) (uget v2 0)) in
+    for i = 1 to pred len1 do
+      Array.unsafe_set res i (f (uget v1 i) (uget v2 i))
+    done;
+    res
+  end
+
+let map2_i f v1 v2 =
+  let len1 = Array.length v1 in
+  let len2 = Array.length v2 in
+  let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in
+  if Int.equal len1 0 then
+    [| |]
+  else begin
+    let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0)) in
+    for i = 1 to pred len1 do
+      Array.unsafe_set res i (f i (uget v1 i) (uget v2 i))
+    done;
+    res
+  end
+
+let map3 f v1 v2 v3 =
+  let len1 = Array.length v1 in
+  let () =
+    if len1 <> Array.length v2 || len1 <> Array.length v3
+    then invalid_arg "Array.map3"
+  in
+  if Int.equal len1 0 then
+    [| |]
+  else begin
+    let res = Array.make len1 (f (uget v1 0) (uget v2 0) (uget v3 0)) in
+    for i = 1 to pred len1 do
+      Array.unsafe_set res i (f (uget v1 i) (uget v2 i) (uget v3 i))
+    done;
+    res
+  end
+
+let map_left f a = (* Ocaml does not guarantee Array.map is LR *)
+  let l = Array.length a in (* (even if so), then we rewrite it *)
+  if Int.equal l 0 then [||] else begin
+    let r = Array.make l (f (uget a 0)) in
+    for i = 1 to l - 1 do
+      Array.unsafe_set r i (f (uget a i))
+    done;
+    r
+  end
+
+let iter2 f v1 v2 =
+  let len1 = Array.length v1 in
+  let len2 = Array.length v2 in
+  let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in
+  for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) done
+
+let pure_functional = false
+
+let fold_map' f v e =
+if pure_functional then
+  let (l,e) =
+    Array.fold_right
+      (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
+      v ([],e) in
+  (Array.of_list l,e)
+else
+  let e' = ref e in
+  let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
+  (v',!e')
+
+let fold_map f e v =
+  let e' = ref e in
+  let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in
+  (!e',v')
+
+let fold_map2' f v1 v2 e =
+  let e' = ref e in
+  let v' =
+    map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
+  in
+  (v',!e')
+
+
+let distinct v =
+  let visited = Hashtbl.create 23 in
+  try
+    Array.iter
+      (fun x ->
+        if Hashtbl.mem visited x then raise Exit
+        else Hashtbl.add visited x x)
+      v;
+    true
+  with Exit -> false
+
+let rev_to_list a =
+  let rec tolist i res =
+    if i >= Array.length a then res else tolist (i+1) (uget a i :: res) in
+  tolist 0 []
+
+let filter_with filter v =
+  Array.of_list (CList.filter_with filter (Array.to_list v))
+
+module Fun1 =
+struct
+
+  let map f arg v = match v with
+  | [| |] -> [| |]
+  | _ ->
+    let len = Array.length v in
+    let x0 = Array.unsafe_get v 0 in
+    let ans = Array.make len (f arg x0) in
+    for i = 1 to pred len do
+      let x = Array.unsafe_get v i in
+      Array.unsafe_set ans i (f arg x)
+    done;
+    ans
+
+  let smartmap f arg (ar : 'a array) =
+    let len = Array.length ar in
+    let i = ref 0 in
+    let break = ref true in
+    let temp = ref None in
+    while !break && (!i < len) do
+      let v = Array.unsafe_get ar !i in
+      let v' = f arg v in
+      if v == v' then incr i
+      else begin
+        break := false;
+        temp := Some v';
+      end
+    done;
+    if !i < len then begin
+      (** The array is not the same as the original one *)
+      let ans : 'a array = Array.copy ar in
+      let v = match !temp with None -> assert false | Some x -> x in
+      Array.unsafe_set ans !i v;
+      incr i;
+      while !i < len do
+        let v = Array.unsafe_get ar !i in
+        let v' = f arg v in
+        if v != v' then Array.unsafe_set ans !i v';
+        incr i
+      done;
+      ans
+    end else ar
+
+  let iter f arg v =
+    let len = Array.length v in
+    for i = 0 to pred len do
+      let x = uget v i in
+      f arg x
+    done
+
+end
diff --git a/lib/cArray.mli b/lib/cArray.mli
new file mode 100644
index 00000000..39c35e2d
--- /dev/null
+++ b/lib/cArray.mli
@@ -0,0 +1,132 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+module type S = module type of Array
+
+module type ExtS =
+sig
+  include S
+  val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+  (** First size comparison, then lexicographic order. *)
+
+  val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
+  (** Lift equality to array type. *)
+
+  val is_empty : 'a array -> bool
+  (** True whenever the array is empty. *)
+
+  val exists : ('a -> bool) -> 'a array -> bool
+  (** As [List.exists] but on arrays. *)
+
+  val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+
+  val for_all : ('a -> bool) -> 'a array -> bool
+  val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+  val for_all3 : ('a -> 'b -> 'c -> bool) ->
+    'a array -> 'b array -> 'c array -> bool
+  val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+    'a array -> 'b array -> 'c array -> 'd array -> bool
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+
+  val findi : (int -> 'a -> bool) -> 'a array -> int option
+
+  val hd : 'a array -> 'a
+  (** First element of an array, or [Failure "Array.hd"] if empty. *)
+
+  val tl : 'a array -> 'a array
+  (** Remaining part of [hd], or [Failure "Array.tl"] if empty. *)
+
+  val last : 'a array -> 'a
+  (** Last element of an array, or [Failure "Array.last"] if empty. *)
+
+  val cons : 'a -> 'a array -> 'a array
+  (** Append an element on the left. *)
+
+  val rev : 'a array -> unit
+  (** In place reversal. *)
+
+  val fold_right_i :
+    (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+  val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val fold_right2 :
+    ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+  val fold_left2 :
+    ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left3 :
+    ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
+  val fold_left2_i :
+    (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+
+  val map_to_list : ('a -> 'b) -> 'a array -> 'b list
+  (** Composition of [map] and [to_list]. *)
+
+  val map_of_list : ('a -> 'b) -> 'a list -> 'b array
+  (** Composition of [map] and [of_list]. *)
+
+  val chop : int -> 'a array -> 'a array * 'a array
+  (** [chop i a] returns [(a1, a2)] s.t. [a = a1 + a2] and [length a1 = n].
+      Raise [Failure "Array.chop"] if [i] is not a valid index. *)
+
+  val smartmap : ('a -> 'a) -> 'a array -> 'a array
+  (** [smartmap f a] behaves as [map f a] but returns [a] instead of a copy when
+      [f x == x] for all [x] in [a]. *)
+
+  val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array
+  (** Same as [smartmap] but threads an additional state left-to-right. *)
+
+  val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+
+  val map_left : ('a -> 'b) -> 'a array -> 'b array
+  (** As [map] but guaranteed to be left-to-right. *)
+
+  val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+  (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *)
+
+  val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
+  val fold_map2' :
+    ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+
+  val distinct : 'a array -> bool
+  (** Return [true] if every element of the array is unique (for default 
+      equality). *)
+
+  val rev_of_list : 'a list -> 'a array
+  (** [rev_of_list l] is equivalent to [Array.of_list (List.rev l)]. *)
+
+  val rev_to_list : 'a array -> 'a list
+  (** [rev_to_list a] is equivalent to [List.rev (List.of_array a)]. *)
+
+  val filter_with : bool list -> 'a array -> 'a array
+  (** [filter_with b a] selects elements of [a] whose corresponding element in
+      [b] is [true].  Raise [Invalid_argument _] when sizes differ. *)
+
+end
+
+include ExtS
+
+module Fun1 :
+sig
+  val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array
+  (** [Fun1.map f x v = map (f x) v] *)
+
+  val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array
+  (** [Fun1.smartmap f x v = smartmap (f x) v] *)
+
+  val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit
+  (** [Fun1.iter f x v = iter (f x) v] *)
+
+end
+(** The functions defined in this module are the same as the main ones, except
+    that they are all higher-order, and their function arguments have an
+    additional parameter. This allows us to prevent closure creation in critical
+    cases. *)
diff --git a/lib/cList.ml b/lib/cList.ml
new file mode 100644
index 00000000..0ac372d8
--- /dev/null
+++ b/lib/cList.ml
@@ -0,0 +1,785 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+type 'a cmp = 'a -> 'a -> int
+type 'a eq = 'a -> 'a -> bool
+
+module type S = module type of List
+
+module type ExtS =
+sig
+  include S
+  val compare : 'a cmp -> 'a list cmp
+  val equal : 'a eq -> 'a list eq
+  val is_empty : 'a list -> bool
+  val init : int -> (int -> 'a) -> 'a list
+  val mem_f : 'a eq -> 'a -> 'a list -> bool
+  val add_set : 'a eq -> 'a -> 'a list -> 'a list
+  val eq_set : 'a eq -> 'a list -> 'a list -> bool
+  val intersect : 'a eq -> 'a list -> 'a list -> 'a list
+  val union : 'a eq -> 'a list -> 'a list -> 'a list
+  val unionq : 'a list -> 'a list -> 'a list
+  val subtract : 'a eq -> 'a list -> 'a list -> 'a list
+  val subtractq : 'a list -> 'a list -> 'a list
+  val interval : int -> int -> int list
+  val make : int -> 'a -> 'a list
+  val assign : 'a list -> int -> 'a -> 'a list
+  val distinct : 'a list -> bool
+  val distinct_f : 'a cmp -> 'a list -> bool
+  val duplicates : 'a eq -> 'a list -> 'a list
+  val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+  val map_filter : ('a -> 'b option) -> 'a list -> 'b list
+  val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+  val filter_with : bool list -> 'a list -> 'a list
+  val smartmap : ('a -> 'a) -> 'a list -> 'a list
+  val map_left : ('a -> 'b) -> 'a list -> 'b list
+  val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+  val map2_i :
+    (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+  val map4 :
+    ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
+  val filteri :
+    (int -> 'a -> bool) -> 'a list -> 'a list
+  val smartfilter : ('a -> bool) -> 'a list -> 'a list
+  val index : 'a eq -> 'a -> 'a list -> int
+  val index0 : 'a eq -> 'a -> 'a list -> int
+  val iteri :  (int -> 'a -> unit) -> 'a list -> unit
+  val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c
+  val fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
+  val fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+  val fold_right_and_left :
+      ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
+  val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
+  val except : 'a eq -> 'a -> 'a list -> 'a list
+  val remove : 'a eq -> 'a -> 'a list -> 'a list
+  val remove_first : ('a -> bool) -> 'a list -> 'a list
+  val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+  val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+  val sep_last : 'a list -> 'a * 'a list
+  val find_map : ('a -> 'b option) -> 'a list -> 'b
+  val uniquize : 'a list -> 'a list
+  val sort_uniquize : 'a cmp -> 'a list -> 'a list
+  val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+  val subset : 'a list -> 'a list -> bool
+  val chop : int -> 'a list -> 'a list * 'a list
+  exception IndexOutOfRange
+  val goto : int -> 'a list -> 'a list * 'a list
+  val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+  val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+  val firstn : int -> 'a list -> 'a list
+  val last : 'a list -> 'a
+  val lastn : int -> 'a list -> 'a list
+  val skipn : int -> 'a list -> 'a list
+  val skipn_at_least : int -> 'a list -> 'a list
+  val addn : int -> 'a -> 'a list -> 'a list
+  val prefix_of : 'a eq -> 'a list -> 'a list -> bool
+  val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list
+  val drop_last : 'a list -> 'a list
+  val map_append : ('a -> 'b list) -> 'a list -> 'b list
+  val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+  val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+  val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
+  val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+  val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b
+  val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list
+  val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool
+  val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+  val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
+  val combinations : 'a list list -> 'a list list
+  val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+  val cartesians_filter :
+    ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
+  val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list
+
+  module type MonoS = sig
+    type elt
+    val equal : elt list -> elt list -> bool
+    val mem : elt -> elt list -> bool
+    val assoc : elt -> (elt * 'a) list -> 'a
+    val mem_assoc : elt -> (elt * 'a) list -> bool
+    val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+    val mem_assoc_sym : elt -> ('a * elt) list -> bool
+  end
+
+end
+
+include List
+
+(** Tail-rec implementation of usual functions. This is a well-known trick used
+    in, for instance, ExtLib and Batteries. *)
+
+type 'a cell = {
+  head : 'a;
+  mutable tail : 'a list;
+}
+
+external cast : 'a cell -> 'a list = "%identity"
+
+let rec map_loop f p = function
+| [] -> ()
+| x :: l ->
+  let c = { head = f x; tail = [] } in
+  p.tail <- cast c;
+  map_loop f c l
+
+let map f = function
+| [] -> []
+| x :: l ->
+  let c = { head = f x; tail = [] } in
+  map_loop f c l;
+  cast c
+
+let rec map2_loop f p l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+  let c = { head = f x y; tail = [] } in
+  p.tail <- cast c;
+  map2_loop f c l1 l2
+| _ -> invalid_arg "List.map2"
+
+let map2 f l1 l2 = match l1, l2 with
+| [], [] -> []
+| x :: l1, y :: l2 ->
+  let c = { head = f x y; tail = [] } in
+  map2_loop f c l1 l2;
+  cast c
+| _ -> invalid_arg "List.map2"
+
+let rec append_loop p tl = function
+| [] -> p.tail <- tl
+| x :: l ->
+  let c = { head = x; tail = [] } in
+  p.tail <- cast c;
+  append_loop c tl l
+
+let append l1 l2 = match l1 with
+| [] -> l2
+| x :: l ->
+  let c = { head = x; tail = [] } in
+  append_loop c l2 l;
+  cast c
+
+let rec copy p = function
+| [] -> p
+| x :: l ->
+  let c = { head = x; tail = [] } in
+  p.tail <- cast c;
+  copy c l
+
+let rec init_loop len f p i =
+  if Int.equal i len then ()
+  else
+    let c = { head = f i; tail = [] } in
+    p.tail <- cast c;
+    init_loop len f c (succ i)
+
+let init len f =
+  if len < 0 then invalid_arg "List.init"
+  else if Int.equal len 0 then []
+  else
+    let c = { head = f 0; tail = [] } in
+    init_loop len f c 1;
+    cast c
+
+let rec concat_loop p = function
+| [] -> ()
+| x :: l -> concat_loop (copy p x) l
+
+let concat l =
+  let dummy = { head = Obj.magic 0; tail = [] } in
+  concat_loop dummy l;
+  dummy.tail
+
+let flatten = concat
+
+let rec split_loop p q = function
+| [] -> ()
+| (x, y) :: l ->
+  let cl = { head = x; tail = [] } in
+  let cr = { head = y; tail = [] } in
+  p.tail <- cast cl;
+  q.tail <- cast cr;
+  split_loop cl cr l
+
+let split = function
+| [] -> [], []
+| (x, y) :: l ->
+  let cl = { head = x; tail = [] } in
+  let cr = { head = y; tail = [] } in
+  split_loop cl cr l;
+  (cast cl, cast cr)
+
+let rec combine_loop p l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+  let c = { head = (x, y); tail = [] } in
+  p.tail <- cast c;
+  combine_loop c l1 l2
+| _ -> invalid_arg "List.combine"
+
+let combine l1 l2 = match l1, l2 with
+| [], [] -> []
+| x :: l1, y :: l2 ->
+  let c = { head = (x, y); tail = [] } in
+  combine_loop c l1 l2;
+  cast c
+| _ -> invalid_arg "List.combine"
+
+let rec filter_loop f p = function
+| [] -> ()
+| x :: l ->
+  if f x then
+    let c = { head = x; tail = [] } in
+    let () = p.tail <- cast c in
+    filter_loop f c l
+  else
+    filter_loop f p l
+
+let filter f l =
+  let c = { head = Obj.magic 0; tail = [] } in
+  filter_loop f c l;
+  c.tail
+
+(** FIXME: Already present in OCaml 4.00 *)
+
+let rec map_i_loop f i p = function
+| [] -> ()
+| x :: l ->
+  let c = { head = f i x; tail = [] } in
+  p.tail <- cast c;
+  map_i_loop f (succ i) c l
+
+let map_i f i = function
+| [] -> []
+| x :: l ->
+  let c = { head = f i x; tail = [] } in
+  map_i_loop f (succ i) c l;
+  cast c
+
+(** Extensions of OCaml Stdlib *)
+
+let rec compare cmp l1 l2 =
+  if l1 == l2 then 0 else
+  match l1,l2 with
+      [], [] -> 0
+    | _::_, [] -> 1
+    | [], _::_ -> -1
+    | x1::l1, x2::l2 ->
+        (match cmp x1 x2 with
+           | 0 -> compare cmp l1 l2
+           | c -> c)
+
+let rec equal cmp l1 l2 =
+  l1 == l2 ||
+  match l1, l2 with
+    | [], [] -> true
+    | x1 :: l1, x2 :: l2 ->
+      cmp x1 x2 && equal cmp l1 l2
+    | _ -> false
+
+let is_empty = function
+| [] -> true
+| _ -> false
+
+let mem_f cmp x l = List.exists (cmp x) l
+
+let intersect cmp l1 l2 =
+  filter (fun x -> mem_f cmp x l2) l1
+
+let union cmp l1 l2 =
+  let rec urec = function
+    | [] -> l2
+    | a::l -> if mem_f cmp a l2 then urec l else a::urec l
+  in
+  urec l1
+
+let subtract cmp l1 l2 =
+  if is_empty l2 then l1
+  else List.filter (fun x -> not (mem_f cmp x l2)) l1
+
+let unionq l1 l2 = union (==) l1 l2
+let subtractq l1 l2 = subtract (==) l1 l2
+
+let interval n m =
+  let rec interval_n (l,m) =
+    if n > m then l else interval_n (m::l, pred m)
+  in
+  interval_n ([], m)
+
+let addn n v =
+  let rec aux n l =
+    if Int.equal n 0 then l
+    else aux (pred n) (v :: l)
+  in
+  if n < 0 then invalid_arg "List.addn"
+  else aux n
+
+let make n v = addn n v []
+
+let assign l n e =
+  let rec assrec stk l i = match l, i with
+    | ((h::t), 0) -> List.rev_append stk (e :: t)
+    | ((h::t), n) -> assrec (h :: stk) t (pred n)
+    | ([], _) -> failwith "List.assign"
+  in
+  assrec [] l n
+
+let rec smartmap f l = match l with
+    [] -> l
+  | h::tl ->
+      let h' = f h and tl' = smartmap f tl in
+        if h'==h && tl'==tl then l
+        else h'::tl'
+
+let map_left = map
+
+let map2_i f i l1 l2 =
+  let rec map_i i = function
+    | ([], []) -> []
+    | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
+    | (_, _) -> invalid_arg "map2_i"
+  in
+  map_i i (l1,l2)
+
+let map3 f l1 l2 l3 =
+  let rec map = function
+    | ([], [], []) -> []
+    | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
+    | (_, _, _) -> invalid_arg "map3"
+  in
+  map (l1,l2,l3)
+
+let map4 f l1 l2 l3 l4 =
+  let rec map = function
+    | ([], [], [], []) -> []
+    | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
+    | (_, _, _, _) -> invalid_arg "map4"
+  in
+  map (l1,l2,l3,l4)
+
+let rec smartfilter f l = match l with
+    [] -> l
+  | h::tl ->
+      let tl' = smartfilter f tl in
+        if f h then
+          if tl' == tl then l
+          else h :: tl'
+        else tl'
+
+let rec index_f f x l n = match l with
+| [] -> raise Not_found
+| y :: l -> if f x y then n else index_f f x l (succ n)
+
+let index f x l = index_f f x l 1
+
+let index0 f x l = index_f f x l 0
+
+let fold_left_until f accu s =
+  let rec aux accu = function
+    | [] -> accu
+    | x :: xs -> match f accu x with CSig.Stop x -> x | CSig.Cont i -> aux i xs in
+  aux accu s
+
+let fold_right_i f i l =
+  let rec it_f i l a = match l with
+    | [] -> a
+    | b::l -> f (i-1) b (it_f (i-1) l a)
+  in
+  it_f (List.length l + i) l
+
+let fold_left_i f =
+  let rec it_list_f i a = function
+    | [] -> a
+    | b::l -> it_list_f (i+1) (f i a b) l
+  in
+  it_list_f
+
+let rec fold_left3 f accu l1 l2 l3 =
+  match (l1, l2, l3) with
+    ([], [], []) -> accu
+  | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3
+  | (_, _, _) -> invalid_arg "List.fold_left3"
+
+(* [fold_right_and_left f [a1;...;an] hd =
+   f (f (... (f (f hd
+                   an
+                   [an-1;...;a1])
+              an-1
+              [an-2;...;a1])
+         ...)
+        a2
+        [a1])
+     a1
+     []] *)
+
+let fold_right_and_left f l hd =
+  let rec aux tl = function
+    | [] -> hd
+    | a::l -> let hd = aux (a::tl) l in f hd a tl
+   in aux [] l
+
+let iteri f l = fold_left_i (fun i _ x -> f i x) 0 () l
+
+let for_all_i p =
+  let rec for_all_p i = function
+    | [] -> true
+    | a::l -> p i a && for_all_p (i+1) l
+  in
+  for_all_p
+
+let except cmp x l = List.filter (fun y -> not (cmp x y)) l
+
+let remove = except (* Alias *)
+
+let rec remove_first p = function
+  | b::l when p b -> l
+  | b::l -> b::remove_first p l
+  | [] -> raise Not_found
+
+let insert p v l =
+  let rec insrec = function
+    | [] -> [v]
+    | h::tl -> if p v h then v::h::tl else h::insrec tl
+  in
+  insrec l
+
+let add_set cmp x l = if mem_f cmp x l then l else x :: l
+
+(** List equality up to permutation (but considering multiple occurrences) *)
+
+let eq_set cmp l1 l2 =
+  let rec aux l1 = function
+  | [] -> is_empty l1
+  | a::l2 -> aux (remove_first (cmp a) l1) l2 in
+  try aux l1 l2 with Not_found -> false
+
+let for_all2eq f l1 l2 =
+  try List.for_all2 f l1 l2 with Invalid_argument _ -> false
+
+let filteri p =
+  let rec filter_i_rec i = function
+    | [] -> []
+    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
+  in
+  filter_i_rec 0
+
+let rec sep_last = function
+  | [] -> failwith "sep_last"
+  | hd::[] -> (hd,[])
+  | hd::tl -> let (l,tl) = sep_last tl in (l,hd::tl)
+
+let rec find_map f = function
+| [] -> raise Not_found
+| x :: l ->
+  match f x with
+  | None -> find_map f l
+  | Some y -> y
+
+(* FIXME: we should avoid relying on the generic hash function,
+   just as we'd better avoid Pervasives.compare *)
+
+let uniquize l =
+  let visited = Hashtbl.create 23 in
+  let rec aux acc changed = function
+    | h::t -> if Hashtbl.mem visited h then aux acc true t else
+          begin
+            Hashtbl.add visited h h;
+            aux (h::acc) changed t
+          end
+    | [] -> if changed then List.rev acc else l
+  in aux [] false l
+
+(** [sort_uniquize] might be an alternative to the hashtbl-based
+    [uniquize], when the order of the elements is irrelevant *)
+
+let rec uniquize_sorted cmp = function
+  | a::b::l when Int.equal (cmp a b) 0 -> uniquize_sorted cmp (a::l)
+  | a::l -> a::uniquize_sorted cmp l
+  | [] -> []
+
+let sort_uniquize cmp l = uniquize_sorted cmp (List.sort cmp l)
+
+(* FIXME: again, generic hash function *)
+
+let distinct l =
+  let visited = Hashtbl.create 23 in
+  let rec loop = function
+    | h::t ->
+        if Hashtbl.mem visited h then false
+        else
+          begin
+            Hashtbl.add visited h h;
+            loop t
+          end
+    | [] -> true
+  in loop l
+
+let distinct_f cmp l =
+  let rec loop = function
+    | a::b::_ when Int.equal (cmp a b) 0 -> false
+    | a::l -> loop l
+    | [] -> true
+  in loop (List.sort cmp l)
+
+let rec merge_uniq cmp l1 l2 =
+  match l1, l2 with
+  | [], l2 -> l2
+  | l1, [] -> l1
+  | h1 :: t1, h2 :: t2 ->
+      let c = cmp h1 h2 in
+      if Int.equal c 0
+      then h1 :: merge_uniq cmp t1 t2
+      else if c <= 0
+      then h1 :: merge_uniq cmp t1 l2
+      else h2 :: merge_uniq cmp l1 t2
+
+let rec duplicates cmp = function
+  | [] -> []
+  | x::l ->
+      let l' = duplicates cmp l in
+      if mem_f cmp x l then add_set cmp x l' else l'
+
+let rec filter2_loop f p q l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+  if f x y then
+    let c1 = { head = x; tail = [] } in
+    let c2 = { head = y; tail = [] } in
+    let () = p.tail <- cast c1 in
+    let () = q.tail <- cast c2 in
+    filter2_loop f c1 c2 l1 l2
+  else
+    filter2_loop f p q l1 l2
+| _ -> invalid_arg "List.filter2"
+
+let filter2 f l1 l2 =
+  let c1 = { head = Obj.magic 0; tail = [] } in
+  let c2 = { head = Obj.magic 0; tail = [] } in
+  filter2_loop f c1 c2 l1 l2;
+  (c1.tail, c2.tail)
+
+let rec map_filter f = function
+  | [] -> []
+  | x::l ->
+      let l' = map_filter f l in
+      match f x with None -> l' | Some y -> y::l'
+
+let map_filter_i f =
+  let rec aux i = function
+    | [] -> []
+    | x::l ->
+      let l' = aux (succ i) l in
+        match f i x with None -> l' | Some y -> y::l'
+  in aux 0
+
+let rec filter_with filter l = match filter, l with
+| [], [] -> []
+| true :: filter, x :: l -> x :: filter_with filter l
+| false :: filter, _ :: l -> filter_with filter l
+| _ -> invalid_arg "List.filter_with"
+
+(* FIXME: again, generic hash function *)
+
+let subset l1 l2 =
+  let t2 = Hashtbl.create 151 in
+  List.iter (fun x -> Hashtbl.add t2 x ()) l2;
+  let rec look = function
+    | [] -> true
+    | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
+  in
+  look l1
+
+(** [goto i l] splits [l] into two lists [(l1,l2)] such that
+    [(List.rev l1)++l2=l] and [l1] has length [i].  It raises
+    [IndexOutOfRange] when [i] is negative or greater than the
+    length of [l]. *)
+exception IndexOutOfRange
+let goto n l =
+  let rec goto i acc = function
+    | tl when Int.equal i 0 -> (acc, tl)
+    | h::t -> goto (pred i) (h::acc) t
+    | [] -> raise IndexOutOfRange
+  in
+  goto n [] l
+
+(* [chop i l] splits [l] into two lists [(l1,l2)] such that
+   [l1++l2=l] and [l1] has length [i].
+   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
+
+let chop n l =
+  try let (h,t) = goto n l in (List.rev h,t)
+  with IndexOutOfRange -> failwith "List.chop"
+    (* spiwack: should raise [IndexOutOfRange] but I'm afraid of missing
+       a try/with when replacing the exception. *)
+
+(* [split_when p l] splits [l] into two lists [(l1,a::l2)] such that
+    [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
+    If there is no such [a], then it returns [(l,[])] instead *)
+let split_when p =
+  let rec split_when_loop x y =
+    match y with
+      | []      -> (List.rev x,[])
+      | (a::l)  -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
+  in
+  split_when_loop []
+
+let rec split3 = function
+  | [] -> ([], [], [])
+  | (x,y,z)::l ->
+      let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz)
+
+let firstn n l =
+  let rec aux acc = function
+    | (0, l) -> List.rev acc
+    | (n, (h::t)) -> aux (h::acc) (pred n, t)
+    | _ -> failwith "firstn"
+  in
+  aux [] (n,l)
+
+let rec last = function
+  | [] -> failwith "List.last"
+  | [x] -> x
+  | _ :: l -> last l
+
+let lastn n l =
+  let len = List.length l in
+  let rec aux m l =
+    if Int.equal m n then l else aux (m - 1) (List.tl l)
+  in
+  if len < n then failwith "lastn" else aux len l
+
+let rec skipn n l = match n,l with
+  | 0, _ -> l
+  | _, [] -> failwith "List.skipn"
+  | n, _::l -> skipn (pred n) l
+
+let skipn_at_least n l =
+  try skipn n l with Failure _ -> []
+
+let prefix_of cmp prefl l =
+  let rec prefrec = function
+    | (h1::t1, h2::t2) -> cmp h1 h2 && prefrec (t1,t2)
+    | ([], _) -> true
+    | _ -> false
+  in
+  prefrec (prefl,l)
+
+(** if [l=p++t] then [drop_prefix p l] is [t] else [l] *)
+
+let drop_prefix cmp p l =
+  let rec drop_prefix_rec = function
+    | (h1::tp, h2::tl) when cmp h1 h2 -> drop_prefix_rec (tp,tl)
+    | ([], tl) -> tl
+    | _ -> l
+  in
+  drop_prefix_rec (p,l)
+
+let map_append f l = List.flatten (List.map f l)
+
+let map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
+
+let share_tails l1 l2 =
+  let rec shr_rev acc = function
+    | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
+    | (l1,l2) -> (List.rev l1, List.rev l2, acc)
+  in
+  shr_rev [] (List.rev l1, List.rev l2)
+
+let rec fold_map f e = function
+  |  []  -> (e,[])
+  |  h::t ->
+       let e',h' = f e h in
+       let e'',t' = fold_map f e' t in
+         e'',h'::t'
+
+(* (* tail-recursive version of the above function *)
+let fold_map f e l =
+  let g (e,b') h =
+    let (e',h') = f e h in
+      (e',h'::b')
+  in
+  let (e',lrev) = List.fold_left g (e,[]) l in
+    (e',List.rev lrev)
+*)
+
+(* The same, based on fold_right, with the effect accumulated on the right *)
+let fold_map' f l e =
+  List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
+
+let map_assoc f = List.map (fun (x,a) -> (x,f a))
+
+let rec assoc_f f a = function
+  | (x, e) :: xs -> if f a x then e else assoc_f f a xs
+  | [] -> raise Not_found
+
+let remove_assoc_f f a l =
+  try remove_first (fun (x,_) -> f a x) l with Not_found -> l
+
+let mem_assoc_f f a l = List.exists (fun (x,_) -> f a x) l
+
+(* A generic cartesian product: for any operator (**),
+   [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
+   and so on if there are more elements in the lists. *)
+
+let cartesian op l1 l2 =
+  map_append (fun x -> List.map (op x) l2) l1
+
+(* [cartesians] is an n-ary cartesian product: it iterates
+   [cartesian] over a list of lists.  *)
+
+let cartesians op init ll =
+  List.fold_right (cartesian op) ll [init]
+
+(* combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
+
+let combinations l = cartesians (fun x l -> x::l) [] l
+
+let rec combine3 x y z = 
+  match x, y, z with
+  | [], [], [] -> []
+  | (x :: xs), (y :: ys), (z :: zs) ->
+      (x, y, z) :: combine3 xs ys zs
+  | _, _, _ -> invalid_arg "List.combine3"
+  
+(* Keep only those products that do not return None *)
+
+let cartesian_filter op l1 l2 =
+  map_append (fun x -> map_filter (op x) l2) l1
+
+(* Keep only those products that do not return None *)
+
+let cartesians_filter op init ll =
+  List.fold_right (cartesian_filter op) ll [init]
+
+(* Drop the last element of a list *)
+
+let rec drop_last = function
+  | [] -> assert false
+  | hd :: [] -> []
+  | hd :: tl -> hd :: drop_last tl
+
+(* Factorize lists of pairs according to the left argument *)
+let rec factorize_left cmp = function
+  | (a,b)::l ->
+      let al,l' = partition (fun (a',_) -> cmp a a') l in
+      (a,(b::List.map snd al)) :: factorize_left cmp l'
+  | [] -> []
+
+module type MonoS = sig
+  type elt
+  val equal : elt list -> elt list -> bool
+  val mem : elt -> elt list -> bool
+  val assoc : elt -> (elt * 'a) list -> 'a
+  val mem_assoc : elt -> (elt * 'a) list -> bool
+  val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+  val mem_assoc_sym : elt -> ('a * elt) list -> bool
+end
diff --git a/lib/cList.mli b/lib/cList.mli
new file mode 100644
index 00000000..19eeb250
--- /dev/null
+++ b/lib/cList.mli
@@ -0,0 +1,229 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+type 'a cmp = 'a -> 'a -> int
+type 'a eq = 'a -> 'a -> bool
+
+(** Module type [S] is the one from OCaml Stdlib. *)
+module type S = module type of List
+
+module type ExtS =
+sig
+  include S
+
+  val compare : 'a cmp -> 'a list cmp
+  (** Lexicographic order on lists. *)
+
+  val equal : 'a eq -> 'a list eq
+  (** Lifts equality to list type. *)
+
+  val is_empty : 'a list -> bool
+  (** Checks whether a list is empty *)
+
+  val init : int -> (int -> 'a) -> 'a list
+  (** [init n f] constructs the list [f 0; ... ; f (n - 1)]. *)
+
+  val mem_f : 'a eq -> 'a -> 'a list -> bool
+  (* Same as [List.mem], for some specific equality *)
+
+  val add_set : 'a eq -> 'a -> 'a list -> 'a list
+  (** [add_set x l] adds [x] in [l] if it is not already there, or returns [l]
+      otherwise. *)
+
+  val eq_set : 'a eq -> 'a list eq
+  (** Test equality up to permutation (but considering multiple occurrences) *)
+
+  val intersect : 'a eq -> 'a list -> 'a list -> 'a list
+  val union : 'a eq -> 'a list -> 'a list -> 'a list
+  val unionq : 'a list -> 'a list -> 'a list
+  val subtract : 'a eq -> 'a list -> 'a list -> 'a list
+  val subtractq : 'a list -> 'a list -> 'a list
+
+  val interval : int -> int -> int list
+  (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when 
+      [j <= i]. *)
+
+  val make : int -> 'a -> 'a list
+  (** [make n x] returns a list made of [n] times [x]. Raise
+      [Invalid_argument "List.make"] if [n] is negative. *)
+
+  val assign : 'a list -> int -> 'a -> 'a list
+  (** [assign l i x] set the [i]-th element of [l] to [x], starting from [0]. *)
+
+  val distinct : 'a list -> bool
+  (** Return [true] if all elements of the list are distinct. *)
+
+  val distinct_f : 'a cmp -> 'a list -> bool
+
+  val duplicates : 'a eq -> 'a list -> 'a list
+  (** Return the list of unique elements which appear at least twice. Elements
+      are kept in the order of their first appearance. *)
+
+  val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+  val map_filter : ('a -> 'b option) -> 'a list -> 'b list
+  val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+
+  val filter_with : bool list -> 'a list -> 'a list
+  (** [filter_with b a] selects elements of [a] whose corresponding element in
+      [b] is [true]. Raise [Invalid_argument _] when sizes differ. *)
+
+  val smartmap : ('a -> 'a) -> 'a list -> 'a list
+  (** [smartmap f [a1...an] = List.map f [a1...an]] but if for all i
+    [f ai == ai], then [smartmap f l == l] *)
+
+  val map_left : ('a -> 'b) -> 'a list -> 'b list
+  (** As [map] but ensures the left-to-right order of evaluation. *)
+
+  val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+  (** As [map] but with the index, which starts from [0]. *)
+
+  val map2_i :
+    (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+  val map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list ->
+    'd list -> 'e list
+  val filteri : (int -> 'a -> bool) -> 'a list -> 'a list
+
+  val smartfilter : ('a -> bool) -> 'a list -> 'a list
+  (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
+    [f ai = true], then [smartfilter f l == l] *)
+
+  val index : 'a eq -> 'a -> 'a list -> int
+  (** [index] returns the 1st index of an element in a list (counting from 1). *)
+
+  val index0 : 'a eq -> 'a -> 'a list -> int
+  (** [index0] behaves as [index] except that it starts counting at 0. *)
+
+  val iteri :  (int -> 'a -> unit) -> 'a list -> unit
+  (** As [iter] but with the index argument (starting from 0). *)
+
+  val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c
+  (** acts like [fold_left f acc s] while [f] returns
+      [Cont acc']; it stops returning [c] as soon as [f] returns [Stop c]. *)
+
+  val fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
+  val fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+  val fold_right_and_left :
+      ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
+  val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
+  val except : 'a eq -> 'a -> 'a list -> 'a list
+  val remove : 'a eq -> 'a -> 'a list -> 'a list
+
+  val remove_first : ('a -> bool) -> 'a list -> 'a list
+  (** Remove the first element satisfying a predicate, or raise [Not_found] *)
+
+  val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+  (** Insert at the (first) position so that if the list is ordered wrt to the
+      total order given as argument, the order is preserved *)
+
+  val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+  val sep_last : 'a list -> 'a * 'a list
+
+  val find_map : ('a -> 'b option) -> 'a list -> 'b
+  (** Returns the first element that is mapped to [Some _]. Raise [Not_found] if
+      there is none. *)
+
+  val uniquize : 'a list -> 'a list
+  (** Return the list of elements without duplicates.
+      This is the list unchanged if there was none. *)
+
+  val sort_uniquize : 'a cmp -> 'a list -> 'a list
+  (** Return a sorted and de-duplicated version of a list,
+      according to some comparison function. *)
+
+  val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list
+  (** Merge two sorted lists and preserves the uniqueness property. *)
+
+  val subset : 'a list -> 'a list -> bool
+
+  val chop : int -> 'a list -> 'a list * 'a list
+  (** [chop i l] splits [l] into two lists [(l1,l2)] such that
+      [l1++l2=l] and [l1] has length [i].  It raises [Failure] when [i]
+      is negative or greater than the length of [l] *)
+
+  exception IndexOutOfRange
+  val goto: int -> 'a list -> 'a list * 'a list
+  (** [goto i l] splits [l] into two lists [(l1,l2)] such that
+      [(List.rev l1)++l2=l] and [l1] has length [i].  It raises
+      [IndexOutOfRange] when [i] is negative or greater than the
+      length of [l]. *)
+
+
+  val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+  val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+  val firstn : int -> 'a list -> 'a list
+  val last : 'a list -> 'a
+  val lastn : int -> 'a list -> 'a list
+  val skipn : int -> 'a list -> 'a list
+  val skipn_at_least : int -> 'a list -> 'a list
+
+  val addn : int -> 'a -> 'a list -> 'a list
+  (** [addn n x l] adds [n] times [x] on the left of [l]. *)
+
+  val prefix_of : 'a eq -> 'a list -> 'a list -> bool
+  (** [prefix_of l1 l2] returns [true] if [l1] is a prefix of [l2], [false]
+      otherwise. *)
+
+  val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list
+  (** [drop_prefix p l] returns [t] if [l=p++t] else return [l]. *)
+
+  val drop_last : 'a list -> 'a list
+
+  val map_append : ('a -> 'b list) -> 'a list -> 'b list
+  (** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)]. *)
+
+  val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+  (** As [map_append]. Raises [Invalid_argument _] if the two lists don't have 
+      the same length. *)
+
+  val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
+
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+  (** [fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
+    where [(e_i,k_i)=f e_{i-1} l_i] *)
+
+  val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
+  val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+  val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b
+  val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list
+  val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool
+
+  val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+  (** A generic cartesian product: for any operator (**),
+    [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
+    and so on if there are more elements in the lists. *)
+
+  val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
+  (** [cartesians] is an n-ary cartesian product: it iterates
+    [cartesian] over a list of lists.  *)
+
+  val combinations : 'a list list -> 'a list list
+  (** combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
+
+  val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+
+  val cartesians_filter :
+    ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
+  (** Keep only those products that do not return None *)
+
+  val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list
+
+  module type MonoS = sig
+    type elt
+    val equal : elt list -> elt list -> bool
+    val mem : elt -> elt list -> bool
+    val assoc : elt -> (elt * 'a) list -> 'a
+    val mem_assoc : elt -> (elt * 'a) list -> bool
+    val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+    val mem_assoc_sym : elt -> ('a * elt) list -> bool
+  end
+end
+
+include ExtS
diff --git a/lib/cMap.ml b/lib/cMap.ml
new file mode 100644
index 00000000..cf590d96
--- /dev/null
+++ b/lib/cMap.ml
@@ -0,0 +1,168 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Map.S
+
+module type ExtS =
+sig
+  include Map.S
+  module Set : CSig.SetS with type elt = key
+  val update : key -> 'a -> 'a t -> 'a t
+  val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
+  val domain : 'a t -> Set.t
+  val bind : (key -> 'a) -> Set.t -> 'a t
+  val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val smartmap : ('a -> 'a) -> 'a t -> 'a t
+  val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
+  module Unsafe :
+  sig
+    val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
+  end
+end
+
+module MapExt (M : Map.OrderedType) :
+sig
+  type 'a map = 'a Map.Make(M).t
+  val update : M.t -> 'a -> 'a map -> 'a map
+  val modify : M.t -> (M.t -> 'a -> 'a) -> 'a map -> 'a map
+  val domain : 'a map -> Set.Make(M).t
+  val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map
+  val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b
+  val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b
+  val smartmap : ('a -> 'a) -> 'a map -> 'a map
+  val smartmapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map
+  module Unsafe :
+  sig
+    val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map
+  end
+end =
+struct
+  (** This unsafe module is a way to access to the actual implementations of
+      OCaml sets and maps without reimplementing them ourselves. It is quite
+      dubious that these implementations will ever be changed... Nonetheless,
+      if this happens, we can still implement a less clever version of [domain].
+  *)
+
+  type 'a map = 'a Map.Make(M).t
+  type set = Set.Make(M).t
+
+  type 'a _map =
+  | MEmpty
+  | MNode of 'a map * M.t * 'a * 'a map * int
+
+  type _set =
+  | SEmpty
+  | SNode of set * M.t * set * int
+
+  let map_prj : 'a map -> 'a _map = Obj.magic
+  let map_inj : 'a _map -> 'a map = Obj.magic
+  let set_prj : set -> _set = Obj.magic
+  let set_inj : _set -> set = Obj.magic
+
+  let rec update k v (s : 'a map) : 'a map = match map_prj s with
+  | MEmpty -> raise Not_found
+  | MNode (l, k', v', r, h) ->
+    let c = M.compare k k' in
+    if c < 0 then
+      let l' = update k v l in
+      if l == l' then s
+      else map_inj (MNode (l', k', v', r, h))
+    else if c = 0 then
+      if v' == v then s
+      else map_inj (MNode (l, k', v, r, h))
+    else
+      let r' = update k v r in
+      if r == r' then s
+      else map_inj (MNode (l, k', v', r', h))
+
+  let rec modify k f (s : 'a map) : 'a map = match map_prj s with
+  | MEmpty -> raise Not_found
+  | MNode (l, k', v, r, h) ->
+    let c = M.compare k k' in
+    if c < 0 then
+      let l' = modify k f l in
+      if l == l' then s
+      else map_inj (MNode (l', k', v, r, h))
+    else if c = 0 then
+      let v' = f k' v in
+      if v' == v then s
+      else map_inj (MNode (l, k', v', r, h))
+    else
+      let r' = modify k f r in
+      if r == r' then s
+      else map_inj (MNode (l, k', v, r', h))
+
+  let rec domain (s : 'a map) : set = match map_prj s with
+  | MEmpty -> set_inj SEmpty
+  | MNode (l, k, _, r, h) ->
+    set_inj (SNode (domain l, k, domain r, h))
+  (** This function is essentially identity, but OCaml current stdlib does not
+      take advantage of the similarity of the two structures, so we introduce
+      this unsafe loophole. *)
+
+  let rec bind f (s : set) : 'a map = match set_prj s with
+  | SEmpty -> map_inj MEmpty
+  | SNode (l, k, r, h) ->
+    map_inj (MNode (bind f l, k, f k, bind f r, h))
+  (** Dual operation of [domain]. *)
+
+  let rec fold_left f (s : 'a map) accu = match map_prj s with
+  | MEmpty -> accu
+  | MNode (l, k, v, r, h) ->
+    let accu = f k v (fold_left f l accu) in
+    fold_left f r accu
+
+  let rec fold_right f (s : 'a map) accu = match map_prj s with
+  | MEmpty -> accu
+  | MNode (l, k, v, r, h) ->
+    let accu = f k v (fold_right f r accu) in
+    fold_right f l accu
+
+  let rec smartmap f (s : 'a map) = match map_prj s with
+  | MEmpty -> map_inj MEmpty
+  | MNode (l, k, v, r, h) ->
+    let l' = smartmap f l in
+    let r' = smartmap f r in
+    let v' = f v in
+    if l == l' && r == r' && v == v' then s
+    else map_inj (MNode (l', k, v', r', h))
+
+  let rec smartmapi f (s : 'a map) = match map_prj s with
+  | MEmpty -> map_inj MEmpty
+  | MNode (l, k, v, r, h) ->
+    let l' = smartmapi f l in
+    let r' = smartmapi f r in
+    let v' = f k v in
+    if l == l' && r == r' && v == v' then s
+    else map_inj (MNode (l', k, v', r', h))
+
+  module Unsafe =
+  struct
+
+    let rec map f (s : 'a map) : 'b map = match map_prj s with
+    | MEmpty -> map_inj MEmpty
+    | MNode (l, k, v, r, h) ->
+      let (k, v) = f k v in
+      map_inj (MNode (map f l, k, v, map f r, h))
+
+  end
+
+end
+
+module Make(M : Map.OrderedType) =
+struct
+  include Map.Make(M)
+  include MapExt(M)
+end
diff --git a/lib/cMap.mli b/lib/cMap.mli
new file mode 100644
index 00000000..23d3801e
--- /dev/null
+++ b/lib/cMap.mli
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** {5 Extended version of OCaml's maps} *)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Map.S
+
+module type ExtS =
+sig
+  include Map.S
+  (** The underlying Map library *)
+
+  module Set : CSig.SetS with type elt = key
+  (** Sets used by the domain function *)
+
+  val update : key -> 'a -> 'a t -> 'a t
+  (** Same as [add], but expects the key to be present, and thus faster.
+      @raise Not_found when the key is unbound in the map. *)
+
+  val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
+  (** Apply the given function to the binding of the given key.
+      @raise Not_found when the key is unbound in the map. *)
+
+  val domain : 'a t -> Set.t
+  (** Recover the set of keys defined in the map. *)
+
+  val bind : (key -> 'a) -> Set.t -> 'a t
+  (** [bind f s] transform the set [x1; ...; xn] into [x1 := f x1; ...;
+      xn := f xn]. *)
+
+  val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** Alias for {!fold}, to easily track where we depend on fold order. *)
+
+  val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** Folding keys in decreasing order. *)
+
+  val smartmap : ('a -> 'a) -> 'a t -> 'a t
+  (** As [map] but tries to preserve sharing. *)
+
+  val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
+  (** As [mapi] but tries to preserve sharing. *)
+
+  module Unsafe :
+  sig
+    val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
+    (** As the usual [map], but also allows modifying the key of a binding.
+        It is required that the mapping function [f] preserves key equality,
+        i.e.: for all (k : key) (x : 'a), compare (fst (f k x)) k = 0. *)
+  end
+
+end
+
+module Make(M : Map.OrderedType) : ExtS with
+  type key = M.t
+  and type 'a t = 'a Map.Make(M).t
+  and module Set := Set.Make(M)
diff --git a/lib/cObj.ml b/lib/cObj.ml
new file mode 100644
index 00000000..7f3ee185
--- /dev/null
+++ b/lib/cObj.ml
@@ -0,0 +1,203 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(*s Logical and physical size of ocaml values. *)
+
+(** {6 Logical sizes} *)
+
+let c = ref 0
+let s = ref 0
+let b = ref 0
+let m = ref 0
+
+let rec obj_stats d t =
+  if Obj.is_int t then m := max d !m
+  else if Obj.tag t >= Obj.no_scan_tag then
+    if Obj.tag t = Obj.string_tag then
+      (c := !c + Obj.size t; b := !b + 1; m := max d !m)
+    else if Obj.tag t = Obj.double_tag then
+      (s := !s + 2; b := !b + 1; m := max d !m)
+    else if Obj.tag t = Obj.double_array_tag then
+      (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
+    else (b := !b + 1; m := max d !m)
+  else
+    let n = Obj.size t in
+    s := !s + n; b := !b + 1;
+    block_stats (d + 1) (n - 1) t
+
+and block_stats d i t =
+  if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
+
+let obj_stats a =
+  c := 0; s:= 0; b:= 0; m:= 0;
+  obj_stats 0 (Obj.repr a);
+  (!c, !s + !b, !m)
+
+(** {6 Physical sizes} *)
+
+(*s Pointers already visited are stored in a hash-table, where
+    comparisons are done using physical equality. *)
+
+module H = Hashtbl.Make(
+  struct
+    type t = Obj.t
+    let equal = (==)
+    let hash = Hashtbl.hash
+  end)
+
+let node_table = (H.create 257 : unit H.t)
+
+let in_table o = try H.find node_table o; true with Not_found -> false
+
+let add_in_table o = H.add node_table o ()
+
+let reset_table () = H.clear node_table
+
+(*s Objects are traversed recursively, as soon as their tags are less than
+    [no_scan_tag]. [count] records the numbers of words already visited. *)
+
+let size_of_double = Obj.size (Obj.repr 1.0)
+
+let count = ref 0
+
+let rec traverse t =
+  if not (in_table t) && Obj.is_block t then begin
+    add_in_table t;
+    let n = Obj.size t in
+    let tag = Obj.tag t in
+    if tag < Obj.no_scan_tag then
+      begin
+        count := !count + 1 + n;
+        for i = 0 to n - 1 do traverse (Obj.field t i) done
+      end
+    else if tag = Obj.string_tag then
+      count := !count + 1 + n
+    else if tag = Obj.double_tag then
+      count := !count + size_of_double
+    else if tag = Obj.double_array_tag then
+      count := !count + 1 + size_of_double * n
+    else
+      incr count
+  end
+
+(*s Sizes of objects in words and in bytes. The size in bytes is computed
+    system-independently according to [Sys.word_size]. *)
+
+let size o =
+  reset_table ();
+  count := 0;
+  traverse (Obj.repr o);
+  !count
+
+let size_b o = (size o) * (Sys.word_size / 8)
+
+let size_kb o = (size o) / (8192 / Sys.word_size)
+
+(** {6 Physical sizes with sharing} *)
+
+(** This time, all the size of objects are computed with respect
+    to a larger object containing them all, and we only count
+    the new blocks not already seen earlier in the left-to-right
+    visit of the englobing object.
+
+    The very same object could have a zero size or not, depending
+    of the occurrence we're considering in the englobing object.
+    For speaking of occurrences, we use an [int list] for a path
+    of field indexes from the outmost block to the one we're looking.
+    In the list, the leftmost integer is the field index in the deepest
+    block.
+*)
+
+(** We now store in the hashtable the size (with sharing), and
+    also the position of the first occurrence of the object *)
+
+let node_sizes = (H.create 257 : (int*int list) H.t)
+let get_size o = H.find node_sizes o
+let add_size o n pos = H.replace node_sizes o (n,pos)
+let reset_sizes () = H.clear node_sizes
+let global_object = ref (Obj.repr 0)
+
+(** [sum n f] is [f 0 + f 1 + ... + f (n-1)], evaluated from left to right *)
+
+let sum n f =
+  let rec loop k acc = if k >= n then acc else loop (k+1) (acc + f k)
+  in loop 0 0
+
+(** Recursive visit of the main object, filling the hashtable *)
+
+let rec compute_size o pos =
+  if not (Obj.is_block o) then 0
+  else
+    try
+      let _ = get_size o in 0 (* already seen *)
+    with Not_found ->
+      let n = Obj.size o in
+      add_size o (-1) pos (* temp size, for cyclic values *);
+      let tag = Obj.tag o in
+      let size =
+        if tag < Obj.no_scan_tag then
+          1 + n + sum n (fun i -> compute_size (Obj.field o i) (i::pos))
+        else if tag = Obj.string_tag then
+          1 + n
+        else if tag = Obj.double_tag then
+          size_of_double
+        else if tag = Obj.double_array_tag then
+          size_of_double * n
+        else
+          1
+      in
+      add_size o size pos;
+      size
+
+(** Provides the global object in which we'll search shared sizes *)
+
+let register_shared_size t =
+  let o = Obj.repr t in
+  reset_sizes ();
+  global_object := o;
+  ignore (compute_size o [])
+
+(** Shared size of an object with respect to the global object given
+    by the last [register_shared_size] *)
+
+let shared_size pos o =
+  if not (Obj.is_block o) then 0
+  else
+    let size,pos' =
+      try get_size o
+      with Not_found -> failwith "shared_size: unregistered structure ?"
+    in
+    match pos with
+      | Some p when p <> pos' -> 0
+      | _ -> size
+
+let shared_size_of_obj t = shared_size None (Obj.repr t)
+
+(** Shared size of the object at some positiion in the global object given
+    by the last [register_shared_size] *)
+
+let shared_size_of_pos pos =
+  let rec obj_of_pos o = function
+    | [] -> o
+    | n::pos' ->
+      let o' = obj_of_pos o pos' in
+      assert (Obj.is_block o' && n < Obj.size o');
+      Obj.field o' n
+  in
+  shared_size (Some pos) (obj_of_pos !global_object pos)
+
+
+(*s Total size of the allocated ocaml heap. *)
+
+let heap_size () =
+  let stat = Gc.stat ()
+  and control = Gc.get () in
+  let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
+  (max_words_total * (Sys.word_size / 8))
+
+let heap_size_kb () = (heap_size () + 1023) / 1024
diff --git a/lib/cObj.mli b/lib/cObj.mli
new file mode 100644
index 00000000..16933a4a
--- /dev/null
+++ b/lib/cObj.mli
@@ -0,0 +1,59 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** {6 Physical size of an ocaml value.}
+
+  These functions explore objects recursively and may allocate a lot. *)
+
+val size : 'a -> int
+(** Physical size of an object in words. *)
+
+val size_b : 'a -> int
+(** Same as [size] in bytes. *)
+
+val size_kb : 'a -> int
+(** Same as [size] in kilobytes. *)
+
+(** {6 Physical size of an ocaml value with sharing.} *)
+
+(** This time, all the size of objects are computed with respect
+    to a larger object containing them all, and we only count
+    the new blocks not already seen earlier in the left-to-right
+    visit of the englobing object. *)
+
+(** Provides the global object in which we'll search shared sizes *)
+
+val register_shared_size : 'a -> unit
+
+(** Shared size (in word) of an object with respect to the global object
+    given by the last [register_shared_size]. *)
+
+val shared_size_of_obj : 'a -> int
+
+(** Same, with an object indicated by its occurrence in the global
+    object. The very same object could have a zero size or not, depending
+    of the occurrence we're considering in the englobing object.
+    For speaking of occurrences, we use an [int list] for a path
+    of field indexes (leftmost = deepest block, rightmost = top block of the
+    global object). *)
+
+val shared_size_of_pos : int list -> int
+
+(** {6 Logical size of an OCaml value.} *)
+
+val obj_stats : 'a -> int * int * int
+(** Return the (logical) value size, the string size, and the maximum depth of
+    the object. This loops on cyclic structures. *)
+
+(** {6 Total size of the allocated ocaml heap. } *)
+
+val heap_size : unit -> int
+(** Heap size, in words. *)
+
+val heap_size_kb : unit -> int
+(** Heap size, in kilobytes. *)
diff --git a/lib/cSet.ml b/lib/cSet.ml
new file mode 100644
index 00000000..d7d5c70b
--- /dev/null
+++ b/lib/cSet.ml
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Set.S
+
+module Make(M : OrderedType)= Set.Make(M)
+
+module type HashedType =
+sig
+  type t
+  val hash : t -> int
+end
+
+module Hashcons(M : OrderedType)(H : HashedType with type t = M.t)  =
+struct
+  module Set = Make(M)
+
+  type set = Set.t
+  type _set =
+  | SEmpty
+  | SNode of set * M.t * set * int
+
+  let set_prj : set -> _set = Obj.magic
+  let set_inj : _set -> set = Obj.magic
+
+  let rec spine s accu = match set_prj s with
+  | SEmpty -> accu
+  | SNode (l, v, r, _) -> spine l ((v, r) :: accu)
+
+  let rec umap f s = match set_prj s with
+  | SEmpty -> set_inj SEmpty
+  | SNode (l, v, r, h) ->
+    let l' = umap f l in
+    let r' = umap f r in
+    let v' = f v in
+    set_inj (SNode (l', v', r', h))
+
+  let rec eqeq s1 s2 = match s1, s2 with
+  | [], [] -> true
+  | (v1, r1) :: s1, (v2, r2) :: s2 ->
+      v1 == v2 && eqeq (spine r1 s1) (spine r2 s2)
+  | _ -> false
+
+  module Hashed =
+  struct
+    open Hashset.Combine
+    type t = set
+    type u = M.t -> M.t
+    let equal s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 [])
+    let hash s = Set.fold (fun v accu -> combine (H.hash v) accu) s 0
+    let hashcons = umap
+  end
+
+  include Hashcons.Make(Hashed)
+
+end
diff --git a/lib/cSet.mli b/lib/cSet.mli
new file mode 100644
index 00000000..e5505410
--- /dev/null
+++ b/lib/cSet.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Set.S
+
+module Make(M : OrderedType) : S
+  with type elt = M.t
+  and type t = Set.Make(M).t
+
+module type HashedType =
+sig
+  type t
+  val hash : t -> int
+end
+
+module Hashcons (M : OrderedType) (H : HashedType with type t = M.t) : Hashcons.S with
+  type t = Set.Make(M).t
+  and type u = M.t -> M.t
+(** Create hash-consing for sets. The hashing function provided must be
+    compatible with the comparison function. *)
diff --git a/lib/cSig.mli b/lib/cSig.mli
new file mode 100644
index 00000000..2a8bda29
--- /dev/null
+++ b/lib/cSig.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Missing pervasive types from OCaml stdlib *)
+
+type ('a, 'b) union = Inl of 'a | Inr of 'b
+(** Union type *)
+
+type 'a until = Stop of 'a | Cont of 'a
+(** Used for browsable-until structures. *)
+
+module type SetS =
+sig
+    type elt
+    type t
+    val empty: t
+    val is_empty: t -> bool
+    val mem: elt -> t -> bool
+    val add: elt -> t -> t
+    val singleton: elt -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val compare: t -> t -> int
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val iter: (elt -> unit) -> t -> unit
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all: (elt -> bool) -> t -> bool
+    val exists: (elt -> bool) -> t -> bool
+    val filter: (elt -> bool) -> t -> t
+    val partition: (elt -> bool) -> t -> t * t
+    val cardinal: t -> int
+    val elements: t -> elt list
+    val min_elt: t -> elt
+    val max_elt: t -> elt
+    val choose: t -> elt
+    val split: elt -> t -> t * bool * t
+end
+(** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml
+    documentation for more information. *)
diff --git a/lib/cStack.ml b/lib/cStack.ml
new file mode 100644
index 00000000..4acb2930
--- /dev/null
+++ b/lib/cStack.ml
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+exception Empty = Stack.Empty
+
+type 'a t = {
+  mutable stack : 'a list;
+}
+
+let create () = { stack = [] }
+
+let push x s = s.stack <- x :: s.stack
+
+let pop = function
+  | { stack = [] } -> raise Stack.Empty
+  | { stack = x::xs } as s -> s.stack <- xs; x
+
+let top = function
+  | { stack = [] } -> raise Stack.Empty
+  | { stack = x::_ } -> x
+
+let to_list { stack = s } = s
+
+let find f s = List.find f (to_list s)
+
+let find_map f s = CList.find_map f s.stack
+
+let fold_until f accu s = CList.fold_left_until f accu s.stack
+
+let is_empty { stack = s } = s = []
+
+let iter f { stack = s } = List.iter f s
+
+let clear s = s.stack <- []
+
+let length { stack = s } = List.length s
+
diff --git a/lib/cStack.mli b/lib/cStack.mli
new file mode 100644
index 00000000..8dde1d1a
--- /dev/null
+++ b/lib/cStack.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extended interface for OCaml stacks. *)
+
+type 'a t
+
+exception Empty
+(** Alias for Stack.Empty. *)
+
+val create : unit -> 'a t
+(** Create an empty stack. *)
+
+val push : 'a -> 'a t -> unit
+(** Add an element to a stack. *)
+
+val find : ('a -> bool) -> 'a t -> 'a
+(** Find the first element satisfying the predicate.
+    @raise Not_found it there is none. *)
+
+val is_empty : 'a t -> bool
+(** Whether a stack is empty. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iterate a function over elements, from the last added one. *)
+
+val clear : 'a t -> unit
+(** Empty a stack. *)
+
+val length : 'a t -> int
+(** Length of a stack. *)
+
+val pop  : 'a t -> 'a
+(** Remove and returns the first element of the stack.
+    @raise Empty if empty. *)
+
+val top  : 'a t -> 'a
+(** Remove the first element of the stack without modifying it.
+    @raise Empty if empty. *)
+
+val to_list : 'a t -> 'a list
+(** Convert to a list. *)
+
+val find_map : ('a -> 'b option) -> 'a t -> 'b
+(** Find the first element that returns [Some _].
+    @raise Not_found it there is none. *)
+
+val fold_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a t -> 'c
+(** Like CList.fold_left_until.
+    The stack is traversed from the top and is not altered. *)
+
diff --git a/lib/cString.ml b/lib/cString.ml
new file mode 100644
index 00000000..250b7cee
--- /dev/null
+++ b/lib/cString.ml
@@ -0,0 +1,174 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type S = module type of String
+
+module type ExtS =
+sig
+  include S
+  external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+  val hash : string -> int
+  val is_empty : string -> bool
+  val explode : string -> string list
+  val implode : string list -> string
+  val strip : string -> string
+  val map : (char -> char) -> string -> string
+  val drop_simple_quotes : string -> string
+  val string_index_from : string -> int -> string -> int
+  val string_contains : where:string -> what:string -> bool
+  val plural : int -> string -> string
+  val conjugate_verb_to_be : int -> string
+  val ordinal : int -> string
+  val split : char -> string -> string list
+  val is_sub : string -> string -> int -> bool
+  module Set : Set.S with type elt = t
+  module Map : CMap.ExtS with type key = t and module Set := Set
+  module List : CList.MonoS with type elt = t
+  val hcons : string -> string
+end
+
+include String
+
+external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+
+let rec hash len s i accu =
+  if i = len then accu
+  else
+    let c = Char.code (String.unsafe_get s i) in
+    hash len s (succ i) (accu * 19 + c)
+
+let hash s =
+  let len = String.length s in
+  hash len s 0 0
+
+let explode s =
+  let rec explode_rec n =
+    if n >= String.length s then
+      []
+    else
+      String.make 1 (String.get s n) :: explode_rec (succ n)
+  in
+  explode_rec 0
+
+let implode sl = String.concat "" sl
+
+let is_blank = function
+  | ' ' | '\r' | '\t' | '\n' -> true
+  | _ -> false
+
+let is_empty s = String.length s = 0
+
+let strip s =
+  let n = String.length s in
+  let rec lstrip_rec i =
+    if i < n && is_blank s.[i] then
+      lstrip_rec (i+1)
+    else i
+  in
+  let rec rstrip_rec i =
+    if i >= 0 && is_blank s.[i] then
+      rstrip_rec (i-1)
+    else i
+  in
+  let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
+  String.sub s a (b-a+1)
+
+let map f s =
+  let l = String.length s in
+  let r = String.create l in
+  for i = 0 to (l - 1) do r.[i] <- f (s.[i]) done;
+  r
+
+let drop_simple_quotes s =
+  let n = String.length s in
+  if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s
+
+(* substring searching... *)
+
+(* gdzie = where, co = what *)
+(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
+let rec raw_is_sub gdzie gl gi co cl ci =
+  (ci>=cl) ||
+  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
+   (raw_is_sub gdzie gl (gi+1) co cl (ci+1)))
+
+let rec raw_str_index i gdzie l c co cl =
+  (* First adapt to ocaml 3.11 new semantics of index_from *)
+  if (i+cl > l) then raise Not_found;
+  (* Then proceed as in ocaml < 3.11 *)
+  let i' = String.index_from gdzie i c in
+    if (i'+cl <= l) && (raw_is_sub gdzie l i' co cl 0) then i' else
+      raw_str_index (i'+1) gdzie l c co cl
+
+let string_index_from gdzie i co =
+  if co="" then i else
+    raw_str_index i gdzie (String.length gdzie)
+      (String.unsafe_get co 0) co (String.length co)
+
+let string_contains ~where ~what =
+  try
+    let _ = string_index_from where 0 what in true
+  with
+      Not_found -> false
+
+let is_sub p s off =
+  let lp = String.length p in
+  let ls = String.length s in
+  if ls < off + lp then false
+  else
+    let rec aux i =
+      if lp <= i then true
+      else
+        let cp = String.unsafe_get p i in
+        let cs = String.unsafe_get s (off + i) in
+        if cp = cs then aux (succ i) else false
+    in
+    aux 0
+
+let plural n s = if n<>1 then s^"s" else s
+
+let conjugate_verb_to_be n = if n<>1 then "are" else "is"
+
+let ordinal n =
+  let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
+  string_of_int n ^ s
+
+(* string parsing *)
+
+let split c s =
+  let len = String.length s in
+  let rec split n =
+    try
+      let pos = String.index_from s n c in
+      let dir = String.sub s n (pos-n) in
+      dir :: split (succ pos)
+    with
+      | Not_found -> [String.sub s n (len-n)]
+  in
+  if Int.equal len 0 then [] else split 0
+
+module Self =
+struct
+  type t = string
+  let compare = compare
+end
+
+module Set = Set.Make(Self)
+module Map = CMap.Make(Self)
+
+module List = struct
+  type elt = string
+  let mem id l = List.exists (fun s -> equal id s) l
+  let assoc id l = CList.assoc_f equal id l
+  let remove_assoc id l = CList.remove_assoc_f equal id l
+  let mem_assoc id l = List.exists (fun (a,_) -> equal id a) l
+  let mem_assoc_sym id l = List.exists (fun (_,b) -> equal id b) l
+  let equal l l' = CList.equal equal l l'
+end
+
+let hcons = Hashcons.simple_hcons Hashcons.Hstring.generate Hashcons.Hstring.hcons ()
diff --git a/lib/cString.mli b/lib/cString.mli
new file mode 100644
index 00000000..4fa9e1e9
--- /dev/null
+++ b/lib/cString.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Module type [S] is the one from OCaml Stdlib. *)
+module type S = module type of String
+
+module type ExtS =
+sig
+  include S
+  (** We include the standard library *)
+
+  external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+  (** Equality on strings *)
+
+  val hash : string -> int
+  (** Hashing on strings. Should be compatible with generic one. *)
+
+  val is_empty : string -> bool
+  (** Test whether a string is empty. *)
+
+  val explode : string -> string list
+  (** [explode "x1...xn"] returns [["x1"; ...; "xn"]] *)
+
+  val implode : string list -> string
+  (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *)
+
+  val strip : string -> string
+  (** Remove the surrounding blank characters from a string *)
+
+  val map : (char -> char) -> string -> string
+  (** Apply a function on a string character-wise. *)
+
+  val drop_simple_quotes : string -> string
+  (** Remove the eventual first surrounding simple quotes of a string. *)
+
+  val string_index_from : string -> int -> string -> int
+  (** As [index_from], but takes a string instead of a char as pattern argument *)
+
+  val string_contains : where:string -> what:string -> bool
+  (** As [contains], but takes a string instead of a char as pattern argument *)
+
+  val plural : int -> string -> string
+  (** [plural n s] adds a optional 's' to the [s] when [2 <= n]. *)
+
+  val conjugate_verb_to_be : int -> string
+  (** [conjugate_verb_to_be] returns "is" when [n=1] and "are" otherwise *)
+
+  val ordinal : int -> string
+  (** Generate the ordinal number in English. *)
+
+  val split : char -> string -> string list
+  (** [split c s] splits [s] into sequences separated by [c], excluded. *)
+
+  val is_sub : string -> string -> int -> bool
+  (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *)
+
+  (** {6 Generic operations} **)
+
+  module Set : Set.S with type elt = t
+  (** Finite sets on [string] *)
+
+  module Map : CMap.ExtS with type key = t and module Set := Set
+  (** Finite maps on [string] *)
+
+  module List : CList.MonoS with type elt = t
+  (** Association lists with [string] as keys *)
+
+  val hcons : string -> string
+  (** Hashconsing on [string] *)
+
+end
+
+include ExtS
diff --git a/lib/cThread.ml b/lib/cThread.ml
new file mode 100644
index 00000000..55bb6fd6
--- /dev/null
+++ b/lib/cThread.ml
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type thread_ic = in_channel
+
+let prepare_in_channel_for_thread_friendly_io ic =
+  Unix.set_nonblock (Unix.descr_of_in_channel ic); ic
+
+let safe_wait_timed_read fd time =
+  try Thread.wait_timed_read fd time
+  with Unix.Unix_error (Unix.EINTR, _, _) ->
+    (** On Unix, the above function may raise this exception when it is
+        interrupted by a signal. (It uses Unix.select internally.) *)
+    false
+
+let thread_friendly_read_fd fd s ~off ~len =
+  let rec loop () =
+    try Unix.read fd s off len
+    with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) ->
+      while not (safe_wait_timed_read fd 1.0) do Thread.yield () done;
+      loop ()
+  in 
+    loop ()
+
+let thread_friendly_read ic s ~off ~len =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    thread_friendly_read_fd fd s ~off ~len
+  with Unix.Unix_error _ -> 0
+
+let really_read_fd fd s off len =
+  let i = ref 0 in
+  while !i < len do
+    let off = off + !i in
+    let len = len - !i in
+    let r = thread_friendly_read_fd fd s ~off ~len in
+    if r = 0 then raise End_of_file;
+    i := !i + r
+  done
+
+let thread_friendly_really_read ic s ~off ~len =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    really_read_fd fd s off len
+  with Unix.Unix_error _ -> raise End_of_file
+
+let thread_friendly_really_read_line ic =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    let b = Buffer.create 1024 in
+    let s = String.make 1 '\000' in
+    while s <> "\n" do
+      let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in
+      if n = 0 then raise End_of_file;
+      if s <> "\n" then Buffer.add_string b s;
+    done;
+    Buffer.contents b
+  with Unix.Unix_error _ -> raise End_of_file
+
+let thread_friendly_input_value ic =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    let header = String.create Marshal.header_size in
+    really_read_fd fd header 0 Marshal.header_size;
+    let body_size = Marshal.data_size header 0 in
+    let msg = String.create (body_size + Marshal.header_size) in
+    String.blit header 0 msg 0 Marshal.header_size;
+    really_read_fd fd msg Marshal.header_size body_size;
+    Marshal.from_string msg 0
+  with Unix.Unix_error _ -> raise End_of_file
+
diff --git a/lib/cThread.mli b/lib/cThread.mli
new file mode 100644
index 00000000..8b110f3f
--- /dev/null
+++ b/lib/cThread.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* As of OCaml 4.01.0 input_value and input do not quite work well
+ * with threads.  The symptom is the following.  Two threads, each
+ * of them blocked on a read (on different channels).  One is not
+ * woken up even if data is available.  When the other one gets data
+ * then the stuck one is eventually unblocked too.  Unix.select with
+ * an unbounded wait has the same problem. *)
+
+(* Use only the following functions on the channel *)
+type thread_ic
+val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic
+
+val thread_friendly_input_value : thread_ic -> 'a
+val thread_friendly_read :
+  thread_ic -> string -> off:int -> len:int -> int
+val thread_friendly_really_read :
+  thread_ic -> string -> off:int -> len:int -> unit
+val thread_friendly_really_read_line : thread_ic -> string
+
diff --git a/lib/cUnix.ml b/lib/cUnix.ml
new file mode 100644
index 00000000..4a1fc762
--- /dev/null
+++ b/lib/cUnix.ml
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Files and load path. *)
+
+type physical_path = string
+type load_path = physical_path list
+
+let physical_path_of_string s = s
+let string_of_physical_path p = p
+
+let path_to_list p =
+  let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in
+    Str.split sep p
+
+(* Some static definitions concerning filenames *)
+
+let dirsep = Filename.dir_sep (* Unix: "/" *)
+let dirsep_len = String.length dirsep
+let curdir = Filename.concat Filename.current_dir_name "" (* Unix: "./" *)
+let curdir_len = String.length curdir
+
+(* Hints to partially detects if two paths refer to the same directory *)
+
+(** cut path [p] after all the [/] that come at position [pos]. *)
+let rec cut_after_dirsep p pos =
+  if CString.is_sub dirsep p pos then
+    cut_after_dirsep p (pos + dirsep_len)
+  else
+    String.sub p pos (String.length p - pos)
+
+(** remove all initial "./" in a path unless the path is exactly "./" *)
+let rec remove_path_dot p =
+  if CString.is_sub curdir p 0 then
+    if String.length p = curdir_len
+    then Filename.current_dir_name
+    else remove_path_dot (cut_after_dirsep p curdir_len)
+  else
+    p
+
+(** If a path [p] starts with the current directory $PWD then
+    [strip_path p] returns the sub-path relative to $PWD.
+    Any leading "./" are also removed from the result. *)
+let strip_path p =
+  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
+  if CString.is_sub cwd p 0 then
+    remove_path_dot (cut_after_dirsep p (String.length cwd))
+  else
+    remove_path_dot p
+
+let canonical_path_name p =
+  let current = Sys.getcwd () in
+  try
+    Sys.chdir p;
+    let p' = Sys.getcwd () in
+    Sys.chdir current;
+    p'
+  with Sys_error _ ->
+    (* We give up to find a canonical name and just simplify it... *)
+    strip_path p
+
+let make_suffix name suffix =
+  if Filename.check_suffix name suffix then name else (name ^ suffix)
+
+let get_extension f =
+  let pos = try String.rindex f '.' with Not_found -> String.length f in
+  String.sub f pos (String.length f - pos)
+
+let correct_path f dir =
+  if Filename.is_relative f then Filename.concat dir f else f
+
+let file_readable_p name =
+  try Unix.access name [Unix.R_OK];true
+  with Unix.Unix_error (_, _, _) -> false
+
+(* As for [Unix.close_process], a [Unix.waipid] that ignores all [EINTR] *)
+
+let rec waitpid_non_intr pid =
+  try snd (Unix.waitpid [] pid)
+  with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid
+
+(** [run_command com] launches command [com] (via /bin/sh),
+    and returns the contents of stdout and stderr. If given, [~hook]
+    is called on each elements read on stdout or stderr. *)
+
+let run_command ?(hook=(fun _ ->())) c =
+  let result = Buffer.create 127 in
+  let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
+  let buff = String.make 127 ' ' in
+  let buffe = String.make 127 ' ' in
+  let n = ref 0 in
+  let ne = ref 0 in
+  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
+    !n+ !ne <> 0
+  do
+    let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r);
+    let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r);
+  done;
+  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
+
+(** [sys_command] launches program [prog] with arguments [args].
+    It behaves like [Sys.command], except that we rely on
+    [Unix.create_process], it's hardly more complex and avoids dealing
+    with shells. In particular, no need to quote arguments
+    (against whitespace or other funny chars in paths), hence no need
+    to care about the different quoting conventions of /bin/sh and cmd.exe. *)
+
+let sys_command prog args =
+  let argv = Array.of_list (prog::args) in
+  let pid = Unix.create_process prog argv Unix.stdin Unix.stdout Unix.stderr in
+  waitpid_non_intr pid
+
+(*
+  checks if two file names refer to the same (existing) file by
+  comparing their device and inode.
+  It seems that under Windows, inode is always 0, so we cannot
+  accurately check if
+
+*)
+(* Optimised for partial application (in case many candidates must be
+   compared to f1). *)
+let same_file f1 =
+  try
+    let s1 = Unix.stat f1 in
+    (fun f2 ->
+      try
+        let s2 = Unix.stat f2 in
+        s1.Unix.st_dev = s2.Unix.st_dev &&
+          if Sys.os_type = "Win32" then f1 = f2
+          else s1.Unix.st_ino = s2.Unix.st_ino
+      with
+          Unix.Unix_error _ -> false)
+  with
+      Unix.Unix_error _ -> (fun _ -> false)
diff --git a/lib/cUnix.mli b/lib/cUnix.mli
new file mode 100644
index 00000000..2d0d202d
--- /dev/null
+++ b/lib/cUnix.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** {5 System utilities} *)
+
+type physical_path = string
+type load_path = physical_path list
+
+val physical_path_of_string : string -> physical_path
+val string_of_physical_path : physical_path -> string
+
+val canonical_path_name : string -> string
+
+(** remove all initial "./" in a path *)
+val remove_path_dot : string -> string
+
+(** If a path [p] starts with the current directory $PWD then
+    [strip_path p] returns the sub-path relative to $PWD.
+    Any leading "./" are also removed from the result. *)
+val strip_path : string -> string
+
+(** correct_path f dir = dir/f if f is relative *)
+val correct_path : string -> string -> string
+
+val path_to_list : string -> string list
+
+(** [make_suffix file suf] catenate [file] with [suf] when
+    [file] does not already end with [suf]. *)
+val make_suffix : string -> string -> string
+
+(** Return the extension of a file, i.e. its smaller suffix starting
+    with "." if any, or "" otherwise. *)
+val get_extension : string -> string
+
+val file_readable_p : string -> bool
+
+(** {6 Executing commands } *)
+
+(** [run_command com] launches command [com], and returns
+    the contents of stdout and stderr. If given, [~hook]
+    is called on each elements read on stdout or stderr. *)
+
+val run_command :
+  ?hook:(string->unit) -> string -> Unix.process_status * string
+
+(** [sys_command] launches program [prog] with arguments [args].
+    It behaves like [Sys.command], except that we rely on
+    [Unix.create_process], it's hardly more complex and avoids dealing
+    with shells. In particular, no need to quote arguments
+    (against whitespace or other funny chars in paths), hence no need
+    to care about the different quoting conventions of /bin/sh and cmd.exe. *)
+
+val sys_command : string -> string list -> Unix.process_status
+
+(** A version of [Unix.waitpid] immune to EINTR exceptions *)
+
+val waitpid_non_intr : int -> Unix.process_status
+
+(** checks if two file names refer to the same (existing) file *)
+val same_file : string -> string -> bool
+
diff --git a/lib/gmapl.ml b/lib/canary.ml
index 987ff9af..23d7bd21 100644
--- a/lib/gmapl.ml
+++ b/lib/canary.ml
@@ -1,33 +1,26 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+type t = Obj.t
 
-type ('a,'b) t = ('a,'b list) Gmap.t
+let obj = Obj.new_block Obj.closure_tag 0
+  (** This is an empty closure block. In the current implementation, it is
+      sufficient to allow marshalling but forbid equality. Sadly still allows
+      hash. *)
+  (** FIXME : use custom blocks somehow. *)
 
-let empty = Gmap.empty
-let mem = Gmap.mem
-let iter = Gmap.iter
-let map = Gmap.map
-let fold = Gmap.fold
-
-let add x y m =
-  try
-    let l = Gmap.find x m in
-    Gmap.add x (y::list_except y l) m
-  with Not_found ->
-    Gmap.add x [y] m
-
-let find x m =
-  try Gmap.find x m with Not_found -> []
-
-let remove x y m =
-  let l = Gmap.find x m in
-  Gmap.add x (if List.mem y l then list_subtract l [y] else l) m
+module type Obj = sig type t end
 
+module Make(M : Obj) =
+struct
+  type canary = t
+  type t = (canary * M.t)
 
+  let prj (_, x) = x
+  let inj x = (obj, x)
+end
diff --git a/lib/gmapl.mli b/lib/canary.mli
index 5b81459b..c0ba86a7 100644
--- a/lib/gmapl.mli
+++ b/lib/canary.mli
@@ -1,21 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Maps from ['a] to lists of ['b]. *)
+type t
+(** Type of canaries. Canaries are used to ensure that an object does not use
+    generic operations. *)
 
-type ('a,'b) t
+val obj : t
+(** Canary. In the current implementation, this object is marshallable,
+    forbids generic comparison but still allows generic hashes. *)
 
-val empty : ('a,'b) t
-val mem :  'a -> ('a,'b) t -> bool
-val iter : ('a -> 'b list -> unit) -> ('a,'b) t -> unit
-val map : ('b list -> 'c list) -> ('a,'b) t -> ('a,'c) t
-val fold : ('a -> 'b list -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
+module type Obj = sig type t end
 
-val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
-val find : 'a -> ('a,'b) t -> 'b list
-val remove : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
+module Make(M : Obj) :
+sig
+  type t
+  val prj : t -> M.t
+  val inj : M.t -> t
+end
+(** Adds a canary to any type. *)
diff --git a/lib/clib.mllib b/lib/clib.mllib
new file mode 100644
index 00000000..2da81c95
--- /dev/null
+++ b/lib/clib.mllib
@@ -0,0 +1,39 @@
+Coq_config
+
+Terminal
+Canary
+Hook
+Hashset
+Hashcons
+CSet
+CMap
+Int
+HMap
+Option
+Store
+Exninfo
+Backtrace
+IStream
+Pp_control
+Flags
+Control
+Loc
+Serialize
+Deque
+CObj
+CList
+CString
+CArray
+CStack
+Util
+Stateid
+Feedback
+Pp
+Xml_lexer
+Xml_parser
+Xml_printer
+Richpp
+CUnix
+Envars
+Aux_file
+Monad
diff --git a/lib/compat.ml4 b/lib/compat.ml4
deleted file mode 100644
index 73cbc6d6..00000000
--- a/lib/compat.ml4
+++ /dev/null
@@ -1,242 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Compatibility file depending on ocaml/camlp4 version *)
-
-(** Locations *)
-
-IFDEF CAMLP5 THEN
-
-module Loc = struct
-  include Ploc
-  exception Exc_located = Exc
-  let ghost = dummy
-  let merge = encl
-end
-
-let make_loc = Loc.make_unlined
-let unloc loc = (Loc.first_pos loc, Loc.last_pos loc)
-
-ELSE
-
-module Loc = Camlp4.PreCast.Loc
-
-let make_loc (start,stop) =
-  Loc.of_tuple ("", 0, 0, start, 0, 0, stop, false)
-let unloc loc = (Loc.start_off loc, Loc.stop_off loc)
-
-END
-
-(** Misc module emulation *)
-
-IFDEF CAMLP5 THEN
-
-module PcamlSig = struct end
-
-ELSE
-
-module PcamlSig = Camlp4.Sig
-module Ast = Camlp4.PreCast.Ast
-module Pcaml = Camlp4.PreCast.Syntax
-module MLast = Ast
-module Token = struct exception Error of string end
-
-END
-
-
-(** Grammar auxiliary types *)
-
-IFDEF CAMLP5 THEN
-type gram_assoc = Gramext.g_assoc = NonA | RightA | LeftA
-type gram_position = Gramext.position =
-  | First
-  | Last
-  | Before of string
-  | After of string
-  | Like of string (** dont use it, not in camlp4 *)
-  | Level of string
-ELSE
-type gram_assoc = PcamlSig.Grammar.assoc = NonA | RightA | LeftA
-type gram_position = PcamlSig.Grammar.position =
-  | First
-  | Last
-  | Before of string
-  | After of string
-  | Level of string
-END
-
-
-(** Signature of Lexer *)
-
-IFDEF CAMLP5 THEN
-
-module type LexerSig = sig
-  include Grammar.GLexerType with type te = Tok.t
-  module Error : sig
-    type t
-    exception E of t
-    val to_string : t -> string
-  end
-end
-
-ELSE
-
-module type LexerSig =
-  Camlp4.Sig.Lexer with module Loc = Loc and type Token.t = Tok.t
-
-END
-
-(** Signature and implementation of grammars *)
-
-IFDEF CAMLP5 THEN
-
-module type GrammarSig = sig
-  include Grammar.S with type te = Tok.t
-  type 'a entry = 'a Entry.e
-  type internal_entry = Tok.t Gramext.g_entry
-  type symbol = Tok.t Gramext.g_symbol
-  type action = Gramext.g_action
-  type production_rule = symbol list * action
-  type single_extend_statment =
-      string option * gram_assoc option * production_rule list
-  type extend_statment =
-      gram_position option * single_extend_statment list
-  val action : 'a -> action
-  val entry_create : string -> 'a entry
-  val entry_parse : 'a entry -> parsable -> 'a
-  val entry_print : 'a entry -> unit
-  val srules' : production_rule list -> symbol
-  val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a
-end
-
-module GrammarMake (L:LexerSig) : GrammarSig = struct
-  include Grammar.GMake (L)
-  type 'a entry = 'a Entry.e
-  type internal_entry = Tok.t Gramext.g_entry
-  type symbol = Tok.t Gramext.g_symbol
-  type action = Gramext.g_action
-  type production_rule = symbol list * action
-  type single_extend_statment =
-      string option * gram_assoc option * production_rule list
-  type extend_statment =
-      gram_position option * single_extend_statment list
-  let action = Gramext.action
-  let entry_create = Entry.create
-  let entry_parse = Entry.parse
-IFDEF CAMLP5_6_02_1 THEN
-  let entry_print x = Entry.print !Pp_control.std_ft x
-ELSE
-  let entry_print = Entry.print
-END
-  let srules' = Gramext.srules
-  let parse_tokens_after_filter = Entry.parse_token
-end
-
-ELSE
-
-module type GrammarSig = sig
-  include Camlp4.Sig.Grammar.Static
-    with module Loc = Loc and type Token.t = Tok.t
-  type 'a entry = 'a Entry.t
-  type action = Action.t
-  type parsable
-  val parsable : char Stream.t -> parsable
-  val action : 'a -> action
-  val entry_create : string -> 'a entry
-  val entry_parse : 'a entry -> parsable -> 'a
-  val entry_print : 'a entry -> unit
-  val srules' : production_rule list -> symbol
-end
-
-module GrammarMake (L:LexerSig) : GrammarSig = struct
-  include Camlp4.Struct.Grammar.Static.Make (L)
-  type 'a entry = 'a Entry.t
-  type action = Action.t
-  type parsable = char Stream.t
-  let parsable s = s
-  let action = Action.mk
-  let entry_create = Entry.mk
-  let entry_parse e s = parse e (*FIXME*)Loc.ghost s
-  let entry_print x = Entry.print !Pp_control.std_ft x
-  let srules' = srules (entry_create "dummy")
-end
-
-END
-
-
-(** Misc functional adjustments *)
-
-(** - The lexer produces streams made of pairs in camlp4 *)
-
-let get_tok = IFDEF CAMLP5 THEN fun x -> x ELSE fst END
-
-(** - Gram.extend is more currified in camlp5 than in camlp4 *)
-
-IFDEF CAMLP5 THEN
-let maybe_curry f x y = f (x,y)
-let maybe_uncurry f (x,y) = f x y
-ELSE
-let maybe_curry f = f
-let maybe_uncurry f = f
-END
-
-(** Compatibility with camlp5 strict mode *)
-IFDEF CAMLP5 THEN
-  IFDEF STRICT THEN
-    let vala x = Ploc.VaVal x
-  ELSE
-    let vala x = x
-  END
-ELSE
-  let vala x = x
-END
-
-(** Fix a quotation difference in [str_item] *)
-
-let declare_str_items loc l =
-IFDEF CAMLP5 THEN
-  MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *)
-ELSE
-  Ast.stSem_of_list l
-END
-
-(** Quotation difference for match clauses *)
-
-let default_patt loc =
-  (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>)
-
-IFDEF CAMLP5 THEN
-
-let make_fun loc cl =
-  let l = cl @ [default_patt loc] in
-  MLast.ExFun (loc, vala l)  (* correspond to <:expr< fun [ $list:l$ ] >> *)
-
-ELSE
-
-let make_fun loc cl =
-  let mk_when = function
-    | Some w -> w
-    | None -> Ast.ExNil loc
-  in
-  let mk_clause (patt,optwhen,expr) =
-    (* correspond to <:match_case< ... when ... -> ... >> *)
-    Ast.McArr (loc, patt, mk_when optwhen, expr) in
-  let init = mk_clause (default_patt loc) in
-  let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in
-  let l = List.fold_right add_clause cl init in
-  Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *)
-
-END
-
-(** Explicit antiquotation $anti:... $ *)
-
-IFDEF CAMLP5 THEN
-let expl_anti loc e = <:expr< $anti:e$ >>
-ELSE
-let expl_anti _loc e = e (* FIXME: understand someday if we can do better *)
-END
diff --git a/lib/control.ml b/lib/control.ml
new file mode 100644
index 00000000..673a75a2
--- /dev/null
+++ b/lib/control.ml
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*s interruption *)
+
+let interrupt = ref false
+
+let steps = ref 0
+
+let are_we_threading = lazy (
+  match !Flags.async_proofs_mode with
+  | Flags.APon -> true
+  | _ -> false)
+
+let check_for_interrupt () =
+  if !interrupt then begin interrupt := false; raise Sys.Break end;
+  incr steps;
+  if !steps = 1000 && Lazy.force are_we_threading then begin
+    Thread.delay 0.001;
+    steps := 0;
+  end
+
+(** This function does not work on windows, sigh... *)
+let unix_timeout n f e =
+  let timeout_handler _ = raise e in
+  let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
+  let _ = Unix.alarm n in
+  let restore_timeout () =
+    let _ = Unix.alarm 0 in
+    Sys.set_signal Sys.sigalrm psh
+  in
+  try
+    let res = f () in
+    restore_timeout ();
+    res
+  with e ->
+    let e = Backtrace.add_backtrace e in
+    restore_timeout ();
+    Exninfo.iraise e
+
+let windows_timeout n f e =
+  let killed = ref false in
+  let exited = ref false in
+  let thread init =
+    while not !killed do
+      let cur = Unix.time () in
+      if float_of_int n <= cur -. init then begin
+        interrupt := true;
+        exited := true;
+        Thread.exit ()
+      end;
+      Thread.delay 0.5
+    done
+  in
+  let init = Unix.time () in
+  let _id = Thread.create thread init in
+  try
+    let res = f () in
+    let () = killed := true in
+    let cur = Unix.time () in
+    (** The thread did not interrupt, but the computation took longer than
+        expected. *)
+    let () = if float_of_int n <= cur -. init then begin
+      exited := true;
+      raise Sys.Break
+    end in
+    res
+  with
+  | Sys.Break ->
+    (** Just in case, it could be a regular Ctrl+C *)
+    if not !exited then begin killed := true; raise Sys.Break end
+    else raise e
+  | e ->
+    let () = killed := true in
+    let e = Backtrace.add_backtrace e in
+    Exninfo.iraise e
+
+type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a }
+
+let timeout_fun = match Sys.os_type with
+| "Unix" | "Cygwin" -> ref { timeout = unix_timeout }
+| _ -> ref { timeout = windows_timeout }
+
+let set_timeout f = timeout_fun := f
+
+let timeout n f e = !timeout_fun.timeout n f e
diff --git a/lib/control.mli b/lib/control.mli
new file mode 100644
index 00000000..2a496bca
--- /dev/null
+++ b/lib/control.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Global control of Coq. *)
+
+val interrupt : bool ref
+(** Coq interruption: set the following boolean reference to interrupt Coq
+    (it eventually raises [Break], simulating a Ctrl-C) *)
+
+val check_for_interrupt : unit -> unit
+(** Use this function as a potential yield function. If {!interrupt} has been
+    set, il will raise [Sys.Break]. *)
+
+val timeout : int -> (unit -> 'a) -> exn -> 'a
+(** [timeout n f e] tries to compute [f], and if it fails to do so before [n]
+    seconds, it raises [e] instead. *)
+
+type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a }
+
+val set_timeout : timeout -> unit
+(** Set a particular timeout function. *)
diff --git a/lib/deque.ml b/lib/deque.ml
new file mode 100644
index 00000000..c04d5993
--- /dev/null
+++ b/lib/deque.ml
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+exception Empty
+
+type 'a t = {
+  face : 'a list;
+  rear : 'a list;
+  lenf : int;
+  lenr : int;
+}
+
+let rec split i accu l = match l with
+| [] ->
+  if Int.equal i 0 then (accu, []) else invalid_arg "split"
+| t :: q ->
+  if Int.equal i 0 then (accu, l)
+  else split (pred i) (t :: accu) q
+
+let balance q =
+  let avg = (q.lenf + q.lenr) / 2 in
+  let dif = q.lenf + q.lenr - avg in
+  if q.lenf > succ (2 * q.lenr) then
+    let (ff, fr) = split avg [] q.face in
+    { face = List.rev ff ; rear = q.rear @ List.rev fr; lenf = avg; lenr = dif }
+  else if q.lenr > succ (2 * q.lenf) then
+    let (rf, rr) = split avg [] q.rear in
+    { face = q.face @ List.rev rr ; rear = List.rev rf; lenf = dif; lenr = avg }
+  else q
+
+let empty = {
+  face = [];
+  rear = [];
+  lenf = 0;
+  lenr = 0;
+}
+
+let lcons x q =
+  balance { q with lenf = succ q.lenf; face = x :: q.face }
+
+let lhd q = match q.face with
+| [] ->
+  begin match q.rear with
+  | [] -> raise Empty
+  | t :: _ -> t
+  end
+| t :: _ -> t
+
+let ltl q = match q.face with
+| [] ->
+  begin match q.rear with
+  | [] -> raise Empty
+  | t :: _ -> empty
+  end
+| t :: r -> balance { q with lenf = pred q.lenf; face = r }
+
+let rcons x q =
+  balance { q with lenr = succ q.lenr; rear = x :: q.rear }
+
+let rhd q = match q.rear with
+| [] ->
+  begin match q.face with
+  | [] -> raise Empty
+  | t :: r -> t
+  end
+| t :: _ -> t
+
+let rtl q = match q.rear with
+| [] ->
+  begin match q.face with
+  | [] -> raise Empty
+  | t :: r -> empty
+  end
+| t :: r ->
+  balance { q with lenr = pred q.lenr; rear = r }
+
+let rev q = {
+  face = q.rear;
+  rear = q.face;
+  lenf = q.lenr;
+  lenr = q.lenf;
+}
+
+let length q = q.lenf + q.lenr
+
+let is_empty q = Int.equal (length q) 0
+
+let filter f q =
+  let fold (accu, len) x = if f x then (x :: accu, succ len) else (accu, len) in
+  let (rf, lenf) = List.fold_left fold ([], 0) q.face in
+  let (rr, lenr) = List.fold_left fold ([], 0) q.rear in
+  balance { face = List.rev rf; rear = List.rev rr; lenf = lenf; lenr = lenr }
diff --git a/lib/deque.mli b/lib/deque.mli
new file mode 100644
index 00000000..fd644e3c
--- /dev/null
+++ b/lib/deque.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Purely functional, double-ended queues *)
+
+(** This module implements the banker's deque, from Okasaki. Most operations are
+    amortized O(1). *)
+
+type +'a t
+
+exception Empty
+
+(** {5 Constructor} *)
+
+val empty : 'a t
+
+(** The empty deque. *)
+
+(** {5 Left-side operations} *)
+
+val lcons : 'a -> 'a t -> 'a t
+(** Pushes an element on the left side of the deque. *)
+
+val lhd : 'a t -> 'a
+(** Returns the leftmost element in the deque. Raises [Empty] when empty. *)
+
+val ltl : 'a t -> 'a t
+(** Returns the left-tail of the deque. Raises [Empty] when empty. *)
+
+(** {5 Right-side operations} *)
+
+val rcons : 'a -> 'a t -> 'a t
+(** Same as [lcons] but on the right side. *)
+
+val rhd : 'a t -> 'a
+(** Same as [lhd] but on the right side. *)
+
+val rtl : 'a t -> 'a t
+(** Same as [ltl] but on the right side. *)
+
+(** {5 Operations} *)
+
+val rev : 'a t -> 'a t
+(** Reverse deque. *)
+
+val length : 'a t -> int
+(** Length of a deque. *)
+
+val is_empty : 'a t -> bool
+(** Emptyness of a deque. *)
+
+val filter : ('a -> bool) -> 'a t -> 'a t
+(** Filters the deque *)
diff --git a/lib/dnet.ml b/lib/dnet.ml
deleted file mode 100644
index 7f9bd949..00000000
--- a/lib/dnet.ml
+++ /dev/null
@@ -1,293 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Generic dnet implementation over non-recursive types *)
-
-module type Datatype =
-sig
-  type 'a t
-  val map : ('a -> 'b) -> 'a t -> 'b t
-  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
-  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
-  val fold2 : ('a -> 'b -> 'c -> 'a)  -> 'a -> 'b t -> 'c t -> 'a
-  val compare : unit t -> unit t -> int
-  val terminal : 'a t -> bool
-  val choose : ('a -> 'b) -> 'a t -> 'b
-end
-
-module type S =
-sig
-  type t
-  type ident
-  type meta
-  type 'a structure
-  module Idset : Set.S with type elt=ident
-  type 'a pattern =
-    | Term of 'a
-    | Meta of meta
-  type term_pattern = ('a structure) pattern as 'a
-  val empty : t
-  val add : t -> term_pattern -> ident -> t
-  val find_all : t -> Idset.t
-  val fold_pattern :
-    ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
-  val find_match : term_pattern -> t -> Idset.t
-  val inter : t -> t -> t
-  val union : t -> t -> t
-  val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
-end
-
-module Make =
-  functor (T:Datatype) ->
-  functor (Ident:Set.OrderedType) ->
-  functor (Meta:Set.OrderedType) ->
-struct
-
-  type ident = Ident.t
-  type meta = Meta.t
-
-  type 'a pattern =
-    | Term of 'a
-    | Meta of meta
-
-  type 'a structure = 'a T.t
-
-  module Idset = Set.Make(Ident)
-  module Mmap = Map.Make(Meta)
-  module Tmap = Map.Make(struct type t = unit structure
-				let compare = T.compare end)
-
-  type term_pattern = term_pattern structure pattern
-  type idset = Idset.t
-
-
-
-  (* we store identifiers at the leaf of the dnet *)
-  type node =
-    | Node of t structure
-    | Terminal of t structure * idset
-
-  (* at each node, we have a bunch of nodes (actually a map between
-     the bare node and a subnet) and a bunch of metavariables *)
-  and t = Nodes of node Tmap.t * idset Mmap.t
-
-  let empty : t = Nodes (Tmap.empty, Mmap.empty)
-
-  (* the head of a data is of type unit structure *)
-  let head w = T.map (fun c -> ()) w
-
-  (* given a node of the net and a word, returns the subnet with the
-     same head as the word (with the rest of the nodes) *)
-  let split l (w:'a structure) : node * node Tmap.t =
-    let elt : node = Tmap.find (head w) l in
-    (elt, Tmap.remove (head w) l)
-
-  let select l w = Tmap.find (head w) l
-
-  let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t =
-    match w with Term w ->
-      ( try
-	  let (n,tl) = split t w in
-	  let new_node = match n with
-	    | Terminal (e,is) -> Terminal (e,Idset.add id is)
-	    | Node e -> Node (T.map2 (fun t p -> add t p id)  e w) in
-	  Nodes ((Tmap.add (head w) new_node tl), m)
-	with Not_found ->
-	  let new_content = T.map (fun p -> add empty p id) w in
-	  let new_node =
-	    if T.terminal w then
-	      Terminal (new_content, Idset.singleton id)
-	    else Node new_content in
-	  Nodes ((Tmap.add (head w) new_node t), m) )
-      | Meta i ->
-	  let m =
-	    try Mmap.add i (Idset.add id (Mmap.find i m)) m
-	    with Not_found -> Mmap.add i (Idset.singleton id) m in
-	  Nodes (t, m)
-
-  let add t w id = add t w id
-
-  let rec find_all (Nodes (t,m)) : idset =
-    Idset.union
-      (Mmap.fold (fun _ -> Idset.union) m Idset.empty)
-      (Tmap.fold
-	 ( fun _ n acc ->
-	     let s2 = match n with
-	       | Terminal (_,is) -> is
-	       | Node e -> T.choose find_all e in
-	     Idset.union acc s2
-	 ) t Idset.empty)
-
-(*   (\* optimization hack: Not_found is catched in fold_pattern *\) *)
-(*   let fast_inter s1 s2 = *)
-(*     if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *)
-(*     else Idset.inter s1 s2 *)
-
-(*   let option_any2 f s1 s2 = match s1,s2 with *)
-(*     | Some s1, Some s2 -> f s1 s2 *)
-(*     | (Some s, _ | _, Some s) -> s *)
-(*     | _ -> raise Not_found *)
-
-(*   let fold_pattern ?(complete=true) f acc pat dn = *)
-(*     let deferred = ref [] in *)
-(*     let leafs,metas = ref None, ref None in *)
-(*     let leaf s = leafs := match !leafs with *)
-(*       | None -> Some s *)
-(*       | Some s' -> Some (fast_inter s s') in *)
-(*     let meta s = metas := match !metas with *)
-(*       | None -> Some s *)
-(*       | Some s' -> Some (Idset.union s s') in *)
-(*     let defer c = deferred := c::!deferred in *)
-(*     let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *)
-(*       Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *)
-(*       match p with *)
-(* 	| Meta m -> defer (m,dn) *)
-(* 	| Term w -> *)
-(* 	    try match select t w with *)
-(* 	      | Terminal (_,is) -> leaf is *)
-(* 	      | Node e -> *)
-(* 		  if complete then T.fold2 (fun _ -> fp_rec) () w e else *)
-(* 		    if T.fold2 *)
-(* 		      (fun b p dn -> match p with *)
-(* 			 | Term _ -> fp_rec p dn; false *)
-(* 			 | Meta _ -> b *)
-(* 		      ) true w e *)
-(* 		    then T.choose (T.choose fp_rec w) e *)
-(* 	    with Not_found -> *)
-(* 	      if Mmap.is_empty m then raise Not_found else () *)
-(*     in try *)
-(*       fp_rec pat dn; *)
-(*       (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *)
-(*       List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *)
-(*     with Not_found -> None,acc *)
-
-  (* Sets with a neutral element for inter *)
-  module OSet (S:Set.S) = struct
-    type t = S.t option
-    let union s1 s2 = match s1,s2 with
-      | (None, _ | _, None) -> None
-      | Some a, Some b -> Some (S.union a b)
-    let inter s1 s2 = match s1,s2 with
-      | (None, a | a, None) -> a
-      | Some a, Some b -> Some (S.inter a b)
-    let is_empty = function 
-      | None -> false
-      | Some s -> S.is_empty s
-    (* optimization hack: Not_found is catched in fold_pattern *)
-    let fast_inter s1 s2 =
-      if is_empty s1 || is_empty s2 then raise Not_found
-      else let r = inter s1 s2 in 
-      if is_empty r then raise Not_found else r
-    let full = None
-    let empty = Some S.empty
-  end
-
-  module OIdset = OSet(Idset)
-
-  let fold_pattern ?(complete=true) f acc pat dn =
-    let deferred = ref [] in
-    let defer c = deferred := c::!deferred in
-
-    let rec fp_rec metas p (Nodes(t,m) as dn:t) =
-      (* TODO gérer les dnets non-linéaires *)
-      let metas = Mmap.fold (fun _ -> Idset.union) m metas in
-      match p with 
-	| Meta m -> defer (metas,m,dn); OIdset.full
-	| Term w ->
-	    let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in
-	    try match select t w with
-	      | Terminal (_,is) -> Some (Idset.union curm is)
-	      | Node e -> 
-		  let ids = if complete then T.fold2
-		    (fun acc w e ->
-		       OIdset.fast_inter acc (fp_rec metas w e)
-		    ) OIdset.full w e 
-		  else
-		    let (all_metas, res) = T.fold2
-		      (fun (b,acc) w e -> match w with
-			 | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e)
-			 | Meta _ -> b, acc
-		      ) (true,OIdset.full) w e in
-		    if all_metas then T.choose (T.choose (fp_rec metas) w) e
-		    else res in
-		  OIdset.union ids (Some curm)
-	    with Not_found -> 
-	      if Idset.is_empty metas then raise Not_found else Some curm in
-    let cand = 
-      try fp_rec Idset.empty pat dn
-      with Not_found -> OIdset.empty in
-    let res = List.fold_left f acc !deferred in
-    cand, res
-
-  (* intersection of two dnets. keep only the common pairs *)
-  let rec inter (t1:t) (t2:t) : t =
-    let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
-      Nodes
-	(Tmap.fold
-	   ( fun k e acc ->
-	       try Tmap.add k (f e (Tmap.find k t2)) acc
-	       with Not_found -> acc
-	   ) t1 Tmap.empty,
-	 Mmap.fold
-	   ( fun m s acc ->
-	       try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc
-	       with Not_found -> acc
-	   ) m1 Mmap.empty
-	) in
-    inter_map
-      (fun n1 n2 -> match n1,n2 with
-	 | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2)
-	 | Node e1, Node e2 -> Node (T.map2 inter e1 e2)
-	 | _ -> assert false
-      ) t1 t2
-
-  let rec union (t1:t) (t2:t) : t =
-    let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
-      Nodes
-	(Tmap.fold
-	   ( fun k e acc ->
-	       try Tmap.add k (f e (Tmap.find k acc)) acc
-	       with Not_found -> Tmap.add k e acc
-	   ) t1 t2,
-	 Mmap.fold
-	   ( fun m s acc ->
-	       try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc
-	       with Not_found -> Mmap.add m s acc
-	   ) m1 m2
-	) in
-    union_map
-      (fun n1 n2 -> match n1,n2 with
-	 | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2)
-	 | Node e1, Node e2 -> Node (T.map2 union e1 e2)
-	 | _ -> assert false
-      ) t1 t2
-
-  let find_match (p:term_pattern) (t:t) : idset =
-    let metas = ref Mmap.empty in
-    let (mset,lset) = fold_pattern ~complete:false
-      (fun acc (mset,m,t) ->
-	 let all = OIdset.fast_inter acc
-	   (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in
-		 metas := Mmap.add m t !metas;
-		 find_all t)) in
-	 OIdset.union (Some mset) all
-      ) None p t in
-    Option.get (OIdset.inter mset lset)
-
-  let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn
-
-  let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty
-  let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty
-
-  let rec map sidset sterm (Nodes (t,m)) : t =
-    let snode = function
-      | Terminal (e,is) -> Terminal (e,idset_map sidset is)
-      | Node e -> Node (T.map (map sidset sterm) e) in
-    Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m)
-
-end
diff --git a/lib/dnet.mli b/lib/dnet.mli
deleted file mode 100644
index 826e120a..00000000
--- a/lib/dnet.mli
+++ /dev/null
@@ -1,126 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Generic discrimination net implementation over recursive
-   types. This module implements a association data structure similar
-   to tries but working on any types (not just lists). It is a term
-   indexing datastructure, a generalization of the discrimination nets
-   described for example in W.W.McCune, 1992, related also to
-   generalized tries [Hinze, 2000].
-
-   You can add pairs of (term,identifier) into a dnet, where the
-   identifier is *unique*, and search terms in a dnet filtering a
-   given pattern (retrievial of instances). It returns all identifiers
-   associated with terms matching the pattern. It also works the other
-   way around : You provide a set of patterns and a term, and it
-   returns all patterns which the term matches (retrievial of
-   generalizations). That's why you provide *patterns* everywhere.
-
-   Warning 1: Full unification doesn't work as for now. Make sure the
-   set of metavariables in the structure and in the queries are
-   distincts, or you'll get unexpected behaviours.
-
-   Warning 2: This structure is perfect, i.e. the set of candidates
-   returned is equal to the set of solutions. Beware of DeBruijn
-   shifts and sorts subtyping though (which makes the comparison not
-   symmetric, see term_dnet.ml).
-
-   The complexity of the search is (almost) the depth of the term.
-
-   To use it, you have to provide a module (Datatype) with the datatype
-   parametrized on the recursive argument. example:
-
-   type btree =                      type 'a btree0 =
-   | Leaf                    ===>    | Leaf
-   | Node of btree * btree           | Node of 'a * 'a
-
-*)
-
-(** datatype you want to build a dnet on *)
-module type Datatype =
-sig
-  (** parametric datatype. ['a] is morally the recursive argument *)
-  type 'a t
-
-  (** non-recursive mapping of subterms *)
-  val map : ('a -> 'b) -> 'a t -> 'b t
-  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
-
-  (** non-recursive folding of subterms *)
-  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
-  val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a
-
-  (** comparison of constructors *)
-  val compare : unit t -> unit t -> int
-
-  (** for each constructor, is it not-parametric on 'a? *)
-  val terminal : 'a t -> bool
-
-  (** [choose f w] applies f on ONE of the subterms of w *)
-  val choose : ('a -> 'b) -> 'a t -> 'b
-end
-
-module type S =
-sig
-  type t
-
-  (** provided identifier type *)
-  type ident
-
-  (** provided metavariable type *)
-  type meta
-
-  (** provided parametrized datastructure *)
-  type 'a structure
-
-  (** returned sets of solutions *)
-  module Idset : Set.S with type elt=ident
-
-  (** a pattern is a term where each node can be a unification
-     variable *)
-  type 'a pattern =
-    | Term of 'a
-    | Meta of meta
-
-  type term_pattern = 'a structure pattern as 'a
-
-  val empty : t
-
-  (** [add t w i] adds a new association (w,i) in t. *)
-  val add : t -> term_pattern -> ident -> t
-
-  (** [find_all t] returns all identifiers contained in t. *)
-  val find_all : t -> Idset.t
-
-  (** [fold_pattern f acc p dn] folds f on each meta of p, passing the
-     meta and the sub-dnet under it. The result includes:
-     - Some set if identifiers were gathered on the leafs of the term
-     - None if the pattern contains no leaf (only Metas at the leafs).
-  *)
-  val fold_pattern :
-    ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
-
-  (** [find_match p t] returns identifiers of all terms matching p in
-     t. *)
-  val find_match : term_pattern -> t -> Idset.t
-
-  (** set operations on dnets *)
-  val inter : t -> t -> t
-  val union : t -> t -> t
-
-  (** apply a function on each identifier and node of terms in a dnet *)
-  val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
-end
-
-module Make :
-  functor (T:Datatype) ->
-  functor (Ident:Set.OrderedType) ->
-  functor (Meta:Set.OrderedType) ->
-    S with type ident = Ident.t
-      and  type meta = Meta.t
-      and  type 'a structure = 'a T.t
diff --git a/lib/dyn.ml b/lib/dyn.ml
index e756297f..63def9a1 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -1,25 +1,49 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+open Errors
 
 (* Dynamics, programmed with DANGER !!! *)
 
-type t = string * Obj.t
+type t = int * Obj.t
 
-let dyntab = ref ([] : string list)
+let dyntab = ref (Int.Map.empty : string Int.Map.t)
+(** Instead of working with tags as strings, which are costly, we use their
+    hash. We ensure unicity of the hash in the [create] function. If ever a
+    collision occurs, which is unlikely, it is sufficient to tweak the offending
+    dynamic tag. *)
 
-let create s =
-  if List.mem s !dyntab then
-    anomaly ("Dyn.create: already declared dynamic " ^ s);
-  dyntab := s :: !dyntab;
-  ((fun v -> (s,Obj.repr v)),
-   (fun (s',rv) ->
-      if s = s' then Obj.magic rv else failwith "dyn_out"))
+let create (s : string) =
+  let hash = Hashtbl.hash s in
+  let () =
+    if Int.Map.mem hash !dyntab then
+      let old = Int.Map.find hash !dyntab in
+      let msg = Pp.str ("Dynamic tag collision: " ^ s ^ " vs. " ^ old) in
+      anomaly ~label:"Dyn.create" msg
+  in
+  let () = dyntab := Int.Map.add hash s !dyntab in
+  let infun v = (hash, Obj.repr v) in
+  let outfun (nh, rv) =
+    if Int.equal hash nh then Obj.magic rv
+    else
+      let msg = (Pp.str ("dyn_out: expected " ^ s)) in
+      anomaly msg
+  in
+  (infun, outfun)
 
-let tag (s,_) = s
+let has_tag (s, _) tag =
+  let hash = Hashtbl.hash (tag : string) in
+  Int.equal s hash
+
+let tag (s,_) =
+  try Int.Map.find s !dyntab
+  with Not_found ->
+    let msg = Pp.str ("Unknown dynamic tag " ^ (string_of_int s)) in
+    anomaly msg
+
+let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 3ddde2b6..4a713472 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,3 +12,5 @@ type t
 
 val create : string -> ('a -> t) * (t -> 'a)
 val tag : t -> string
+val has_tag : t -> string -> bool
+val pointer_equal : t -> t -> bool
diff --git a/lib/envars.ml b/lib/envars.ml
index 3040dd41..b0eed838 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -1,130 +1,219 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* This file gathers environment variables needed by Coq to run (such
-   as coqlib) *)
+open Util
 
-let (//) s1 s2 = s1 ^ "/" ^ s2
+(** {1 Helper functions} *)
 
-let coqbin =
-  System.canonical_path_name (Filename.dirname Sys.executable_name)
+let getenv_else s dft = try Sys.getenv s with Not_found -> dft ()
 
-(* The following only makes sense when executables are running from
-   source tree (e.g. during build or in local mode). *)
-let coqroot = Filename.dirname coqbin
+let safe_getenv warning n =
+  getenv_else n (fun () ->
+    warning ("Environment variable "^n^" not found: using '$"^n^"' .");
+    ("$"^n)
+  )
 
-(* On win32, we add coqbin to the PATH at launch-time (this used to be
-   done in a .bat script). *)
+let ( / ) a b =
+  if Filename.is_relative b then a ^ "/" ^ b else b
 
-let _ =
-  if Coq_config.arch = "win32" then
-    Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "")
+let coqify d = d / "coq"
 
-let exe s = s ^ Coq_config.exec_extension
+let opt2list = function None -> [] | Some x -> [x]
 
-let reldir instdir testfile oth =
-  let rpath = if Coq_config.local then [] else instdir in
-  let out = List.fold_left (//) coqroot rpath in
-  if Sys.file_exists (out//testfile) then out else oth ()
-
-let guess_coqlib () =
-  let file = "states/initial.coq" in
-    reldir (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) file
-      (fun () ->
-        let coqlib = match Coq_config.coqlib with
-          | Some coqlib -> coqlib
-          | None -> coqroot
-        in
-        if Sys.file_exists (coqlib//file)
-        then coqlib
-        else Util.error "cannot guess a path for Coq libraries; please use -coqlib option")
-
-let coqlib () =
-  if !Flags.coqlib_spec then !Flags.coqlib else
-    (if !Flags.boot then coqroot else guess_coqlib ())
-
-let docdir () =
-  reldir (if Coq_config.arch = "win32" then ["doc"] else ["share";"doc";"coq"]) "html" (fun () -> Coq_config.docdir)
+let home ~warn =
+  getenv_else "HOME" (fun () ->
+    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
+      getenv_else "USERPROFILE" (fun () ->
+	warn ("Cannot determine user home directory, using '.' .");
+	Filename.current_dir_name))
 
 let path_to_list p =
-  let sep = if Sys.os_type = "Win32" then ';' else ':' in
-    Util.split_string_at sep p
+  let sep = if String.equal Sys.os_type "Win32" then ';' else ':' in
+    String.split sep p
+
+let user_path () =
+  path_to_list (Sys.getenv "PATH") (* may raise Not_found *)
+
+let rec which l f =
+  match l with
+    | [] ->
+      raise Not_found
+    | p :: tl ->
+      if Sys.file_exists (p / f) then
+	p
+      else
+	which tl f
+
+let expand_path_macros ~warn s =
+  let rec expand_atom s i =
+    let l = String.length s in
+    if i<l && (Util.is_digit s.[i] || Util.is_letter s.[i] || s.[i] == '_')
+    then expand_atom s (i+1)
+    else i in
+  let rec expand_macros s i =
+    let l = String.length s in
+    if Int.equal i l then s else
+      match s.[i] with
+	| '$' ->
+	  let n = expand_atom s (i+1) in
+	  let v = safe_getenv warn (String.sub s (i+1) (n-i-1)) in
+	  let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
+	  expand_macros s (i + String.length v)
+	| '~' when Int.equal i 0 ->
+	  let n = expand_atom s (i+1) in
+	  let v =
+	    if Int.equal n (i + 1) then home ~warn
+	    else (Unix.getpwnam (String.sub s (i+1) (n-i-1))).Unix.pw_dir
+	  in
+	  let s = v^(String.sub s n (l-n)) in
+	  expand_macros s (String.length v)
+	| c -> expand_macros s (i+1)
+  in expand_macros s 0
+
+(** {1 Paths} *)
+
+(** {2 Coq paths} *)
+
+let relative_base =
+  Filename.dirname (Filename.dirname Sys.executable_name)
 
-let xdg_data_home =
-    (System.getenv_else "XDG_DATA_HOME" (System.home//".local/share"))//"coq"
+let coqbin =
+  CUnix.canonical_path_name (Filename.dirname Sys.executable_name)
 
-let xdg_config_home =
-  (System.getenv_else "XDG_CONFIG_HOME" (System.home//".config"))//"coq"
+(** The following only makes sense when executables are running from
+    source tree (e.g. during build or in local mode). *)
+let coqroot =
+  Filename.dirname coqbin
 
-let xdg_data_dirs =
-  (try
-    List.map (fun dir -> dir//"coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
-  with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"])
-    @ (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir])
+(** On win32, we add coqbin to the PATH at launch-time (this used to be
+    done in a .bat script). *)
+let _ =
+  if Coq_config.arch_is_win32 then
+    Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> ""))
+
+(** [check_file_else ~dir ~file oth] checks if [file] exists in
+    the installation directory [dir] given relatively to [coqroot].
+    If this Coq is only locally built, then [file] must be in [coqroot].
+    If the check fails, then [oth ()] is evaluated. *)
+let check_file_else ~dir ~file oth =
+  let path = if Coq_config.local then coqroot else coqroot / dir in
+  if Sys.file_exists (path / file) then path else oth ()
+
+let guess_coqlib fail =
+  let prelude = "theories/Init/Prelude.vo" in
+  let dir = if Coq_config.arch_is_win32 then "lib" else "lib/coq" in
+  check_file_else ~dir ~file:prelude
+    (fun () ->
+      let coqlib = match Coq_config.coqlib with
+        | Some coqlib -> coqlib
+        | None -> coqroot
+      in
+      if Sys.file_exists (coqlib / prelude) then coqlib
+      else
+        fail "cannot guess a path for Coq libraries; please use -coqlib option")
+
+(** coqlib is now computed once during coqtop initialization *)
+
+let set_coqlib ~fail =
+  if not !Flags.coqlib_spec then
+    let lib = if !Flags.boot then coqroot else guess_coqlib fail in
+    Flags.coqlib := lib
+
+let coqlib () = !Flags.coqlib
 
-let xdg_dirs =
-  let dirs = xdg_data_home :: xdg_data_dirs
-  in
-  List.rev (List.filter Sys.file_exists dirs)
+let docdir () =
+  let dir = if Coq_config.arch_is_win32 then "doc" else "share/doc/coq" in
+  check_file_else ~dir ~file:"html" (fun () -> Coq_config.docdir)
 
 let coqpath =
-  try
-    let path = Sys.getenv "COQPATH" in
-      List.rev (List.filter Sys.file_exists (path_to_list path))
-  with Not_found -> []
+  let coqpath = getenv_else "COQPATH" (fun () -> "") in
+  let make_search_path path =
+    let paths = path_to_list path in
+    let valid_paths = List.filter Sys.file_exists paths in
+    List.rev valid_paths
+  in
+  make_search_path coqpath
 
-let rec which l f =
-  match l with
-    | [] -> raise Not_found
-    | p :: tl ->
-	if Sys.file_exists (p//f)
-	then p
-	else which tl f
+(** {2 Caml paths} *)
 
-let guess_camlbin () =
-  let path = Sys.getenv "PATH" in (* may raise Not_found *)
-  let lpath = path_to_list path in
-    which lpath (exe "ocamlc")
+let exe s = s ^ Coq_config.exec_extension
 
-let guess_camlp4bin () =
-  let path = Sys.getenv "PATH" in (* may raise Not_found *)
-  let lpath = path_to_list path in
-    which lpath (exe Coq_config.camlp4)
+let guess_camlbin () = which (user_path ()) (exe "ocamlc")
 
 let camlbin () =
   if !Flags.camlbin_spec then !Flags.camlbin else
     if !Flags.boot then Coq_config.camlbin else
-      try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin
+      try guess_camlbin () with Not_found -> Coq_config.camlbin
+
+let ocamlc () = camlbin () / Coq_config.ocamlc
+
+let ocamlopt () = camlbin () / Coq_config.ocamlopt
 
 let camllib () =
-  if !Flags.boot
-  then Coq_config.camllib
+  if !Flags.boot then
+    Coq_config.camllib
   else
-    let camlbin = camlbin () in
-    let com = (camlbin//"ocamlc") ^ " -where" in
-    let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
-    Util.strip res
+    let _, res = CUnix.run_command (ocamlc () ^ " -where") in
+    String.strip res
+
+(** {2 Camlp4 paths} *)
+
+let guess_camlp4bin () = which (user_path ()) (exe Coq_config.camlp4)
 
 let camlp4bin () =
   if !Flags.camlp4bin_spec then !Flags.camlp4bin else
     if !Flags.boot then Coq_config.camlp4bin else
-      try guess_camlp4bin () with e when e <> Sys.Break ->
+      try guess_camlp4bin ()
+      with Not_found ->
         let cb = camlbin () in
-	if Sys.file_exists (cb//(exe Coq_config.camlp4)) then cb
-	else Coq_config.camlp4bin
+        if Sys.file_exists (cb / exe Coq_config.camlp4) then cb
+        else Coq_config.camlp4bin
+
+let camlp4 () = camlp4bin () / exe Coq_config.camlp4
 
 let camlp4lib () =
-  if !Flags.boot
-  then Coq_config.camlp4lib
+  if !Flags.boot then
+    Coq_config.camlp4lib
   else
-    let camlp4bin = camlp4bin () in
-    let com = (camlp4bin//Coq_config.camlp4) ^ " -where" in
-    let ex,res = System.run_command (fun x -> x) (fun _ -> ()) com in
+    let ex, res = CUnix.run_command (camlp4 () ^ " -where") in
     match ex with
-      |Unix.WEXITED 0 -> Util.strip res
-      |_ -> "/dev/null"
+      | Unix.WEXITED 0 -> String.strip res
+      | _ -> "/dev/null"
+
+(** {1 XDG utilities} *)
+
+let xdg_data_home warn =
+  coqify
+    (getenv_else "XDG_DATA_HOME" (fun () -> (home ~warn) / ".local/share"))
+
+let xdg_config_home warn =
+  coqify
+    (getenv_else "XDG_CONFIG_HOME" (fun () -> (home ~warn) / ".config"))
+
+let xdg_data_dirs warn =
+  let sys_dirs =
+    try
+      List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
+    with
+      | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "share"]
+      | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]
+  in
+  xdg_data_home warn :: sys_dirs @ opt2list Coq_config.datadir
+
+let xdg_config_dirs warn =
+  let sys_dirs =
+    try
+      List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
+    with
+      | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "config"]
+      | Not_found -> ["/etc/xdg/coq"]
+  in
+  xdg_config_home warn :: sys_dirs @ opt2list Coq_config.configdir
+
+let xdg_dirs ~warn =
+  List.filter Sys.file_exists (xdg_data_dirs warn)
diff --git a/lib/envars.mli b/lib/envars.mli
index 023b54c0..b62b9f28 100644
--- a/lib/envars.mli
+++ b/lib/envars.mli
@@ -1,25 +1,80 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** This file gathers environment variables needed by Coq to run (such
-   as coqlib) *)
+(** This file provides a high-level interface to the environment variables 
+    needed by Coq to run (such as coqlib). The values of these variables
+    may come from different sources (shell environment variables, 
+    command line options, options set at the time Coq was build). *)
 
+(** [expand_path_macros warn s] substitutes environment variables 
+    in a string by their values. This function also takes care of
+    substituting path of the form '~X' by an absolute path. 
+    Use [warn] as a message displayer. *)
+val expand_path_macros : warn:(string -> unit) -> string -> string
+
+(** [home warn] returns the root of the user directory, depending
+    on the OS. This information is usually stored in the $HOME 
+    environment variable on POSIX shells. If no such variable 
+    exists, then other common names are tried (HOMEDRIVE, HOMEPATH,
+    USERPROFILE). If all of them fail, [warn] is called. *)
+val home : warn:(string -> unit) -> string
+
+(** [coqlib] is the path to the Coq library. *)
 val coqlib : unit -> string
+
+(** [set_coqlib] must be runned once before any access to [coqlib] *)
+val set_coqlib : fail:(string -> string) -> unit
+
+(** [docdir] is the path to the Coq documentation. *)
 val docdir : unit -> string
+
+(** [coqbin] is the name of the current executable. *)
 val coqbin : string
+
+(** [coqroot] is the path to [coqbin]. 
+    The following value only makes sense when executables are running from
+    source tree (e.g. during build or in local mode). 
+*)
 val coqroot : string
-(* coqpath is stored in reverse order, since that is the order it
- * gets added to the searc path *)
-val xdg_config_home : string
-val xdg_dirs : string list
+
+(** [coqpath] is the standard path to coq. 
+    Notice that coqpath is stored in reverse order, since that is 
+    the order it gets added to the search path. *)
 val coqpath : string list
 
+(** [camlbin ()] is the path to the ocaml binaries. *)
 val camlbin : unit -> string
-val camlp4bin : unit -> string
+
+(** [camllib ()] is the path to the ocaml standard library. *)
 val camllib : unit -> string
+
+(** [ocamlc ()] is the ocaml bytecode compiler that compiled this Coq. *)
+val ocamlc   : unit -> string
+
+(** [ocamlc ()] is the ocaml native compiler that compiled this Coq. *)
+val ocamlopt : unit -> string
+
+(** [camlp4bin ()] is the path to the camlp4 binary. *)
+val camlp4bin : unit -> string
+
+(** [camlp4lib ()] is the path to the camlp4 library. *)
 val camlp4lib : unit -> string
+
+(** [camlp4 ()] is the camlp4 utility. *)
+val camlp4 : unit -> string
+
+(** Coq tries to honor the XDG Base Directory Specification to access
+    the user's configuration files.
+
+    see [http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html]
+*)
+val xdg_config_home : (string -> unit) -> string
+val xdg_data_home   : (string -> unit) -> string
+val xdg_config_dirs : (string -> unit) -> string list
+val xdg_data_dirs   : (string -> unit) -> string list
+val xdg_dirs : warn : (string -> unit) -> string list
diff --git a/lib/ephemeron.ml b/lib/ephemeron.ml
new file mode 100644
index 00000000..b36904ca
--- /dev/null
+++ b/lib/ephemeron.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type key_type = int
+
+type boxed_key = key_type ref ref
+
+let mk_key : unit -> boxed_key =
+  (* TODO: take a random value here. Is there a random function in OCaml? *) 
+  let bid = ref 0 in
+  (* According to OCaml Gc module documentation, Pervasives.ref is one of the
+     few ways of getting a boxed value the compiler will never alias. *)
+  fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid)
+
+(* A phantom type to preserve type safety *)
+type 'a key = boxed_key
+
+(* Comparing keys with == grants that if a key is unmarshalled (in the same
+   process where it was created or in another one) it is not mistaken for
+   an already existing one (unmarshal has no right to alias).  If the initial
+   value of bid is taken at random, then one also avoids potential collisions *)
+module HT = Hashtbl.Make(struct
+  type t = key_type ref
+  let equal k1 k2 = k1 == k2
+  let hash id = !id
+end)
+
+(* A key is the (unique) value inside a boxed key, hence it does not
+   keep its corresponding boxed key reachable (replacing key_type by boxed_key
+   would make the key always reachable) *)
+let values : Obj.t HT.t = HT.create 1001
+
+(* To avoid a race contidion between the finalization function and
+   get/create on the values hashtable, the finalization function just
+   enqueues in an imperative list the item to be collected.  Being the list
+   imperative, even if the Gc enqueue an item while run_collection is operating,
+   the tail of the list is eventually set to Empty on completion.
+   Kudos to the authors of Why3 that came up with this solution for their
+   implementation of weak hash tables! *)
+type imperative_list = cell ref
+and cell = Empty | Item of key_type ref * imperative_list
+
+let collection_queue : imperative_list ref = ref (ref Empty)
+
+let enqueue x = collection_queue := ref (Item (!x, !collection_queue))
+
+let run_collection () =
+  let rec aux l = match !l with
+    | Empty -> ()
+    | Item (k, tl) -> HT.remove values k; aux tl in
+  let l = !collection_queue in
+  aux l;
+  l := Empty
+
+(* The only reference to the boxed key is the one returned, when the user drops
+   it the value eventually disappears from the values table above *)
+let create (v : 'a) : 'a key =
+  run_collection ();
+  let k = mk_key () in
+  HT.add values !k (Obj.repr v);
+  Gc.finalise enqueue k;
+  k
+
+(* Avoid raising Not_found *)
+exception InvalidKey
+let get (k : 'a key) : 'a =
+  run_collection ();
+  try Obj.obj (HT.find values !k)
+  with Not_found -> raise InvalidKey
+
+(* Simple utils *)
+let default k v =
+  try get k
+  with InvalidKey -> v
+
+let iter_opt k f =
+  match
+    try Some (get k)
+    with InvalidKey -> None
+  with
+  | None -> ()
+  | Some v -> f v
+
+let clear () = run_collection ()
diff --git a/lib/ephemeron.mli b/lib/ephemeron.mli
new file mode 100644
index 00000000..195b23db
--- /dev/null
+++ b/lib/ephemeron.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Use case:
+     You have a data structure that needs to be marshalled but it contains
+     unmarshallable data (like a closure, or a file descriptor).  Actually
+     you don't need this data to be preserved by marshalling, it just happens
+     to be there.
+     You could produced a trimmed down data structure, but then, once
+     unmarshalled, you can't used the very same code to process it, unless you
+     re-inject the trimmed down data structure into the standard one, using
+     dummy values for the unmarshallable stuff.
+     Similarly you could change your data structure turning all types [bad]
+     into [bad option], then just before marshalling you set all values of type
+     [bad option] to [None].  Still this pruning may be expensive and you have
+     to code it.
+
+   Desiderata:
+     The marshalling operation automatically discards values that cannot be
+     marshalled or cannot be properly unmarshalled.
+
+   Proposed solution:
+     Turn all occurrences of [bad] into [bad key] in your data structure.
+     Use [crate bad_val] to obtain a unique key [k] for [bad_val], and store
+     [k] in the data structure.  Use [get k] to obtain [bad_val].
+
+     An ['a key] can always be marshalled.  When marshalled, a key loses its
+     value.  The function [get] raises Not_found on unmarshalled keys.
+     
+     If a key is garbage collected, the corresponding value is garbage
+     collected too (unless extra references to it exist).
+     In short no memory management hassle, keys can just replace their
+     corresponding value in the data structure.  *)
+
+type 'a key
+
+val create : 'a -> 'a key
+
+(* May raise InvalidKey *)
+exception InvalidKey
+val get : 'a key -> 'a
+
+(* These never fail. *)
+val iter_opt : 'a key -> ('a -> unit) -> unit
+val default : 'a key -> 'a -> 'a
+
+val clear : unit -> unit
diff --git a/lib/errors.ml b/lib/errors.ml
index 6affea23..ab331d6a 100644
--- a/lib/errors.ml
+++ b/lib/errors.ml
@@ -8,8 +8,40 @@
 
 open Pp
 
-(* spiwack: it might be reasonable to decide and move the declarations
-   of Anomaly and so on to this module so as not to depend on Util. *)
+(** Aliases *)
+
+let push = Backtrace.add_backtrace
+
+(* Errors *)
+
+exception Anomaly of string option * std_ppcmds (* System errors *)
+
+let make_anomaly ?label pp =
+  Anomaly (label, pp)
+
+let anomaly ?loc ?label pp = match loc with
+  | None -> raise (Anomaly (label, pp))
+  | Some loc -> Loc.raise loc (Anomaly (label, pp))
+
+let is_anomaly = function
+| Anomaly _ -> true
+| _ -> false
+
+exception UserError of string * std_ppcmds (* User errors *)
+let error string = raise (UserError("_", str string))
+let errorlabstrm l pps = raise (UserError(l,pps))
+
+exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
+let alreadydeclared pps = raise (AlreadyDeclared(pps))
+
+let todo s = prerr_string ("TODO: "^s^"\n")
+
+let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
+let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
+
+exception Timeout
+exception Drop
+exception Quit
 
 let handle_stack = ref []
 
@@ -34,14 +66,24 @@ let rec print_gen bottom stk e =
     In usual situation, the [handle_stack] is treated as it if was always
     non-empty with [print_anomaly] as its bottom handler. *)
 
-let where s =
+let where = function
+| None -> mt ()
+| Some s ->
   if !Flags.debug then str ("in "^s^":") ++ spc () else mt ()
 
 let raw_anomaly e = match e with
-  | Util.Anomaly (s,pps) -> where s ++ pps ++ str "."
+  | Anomaly (s, pps) -> where s ++ pps ++ str "."
   | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".")
   | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".")
 
+let print_backtrace e = match Backtrace.get_backtrace e with
+| None -> mt ()
+| Some bt ->
+  let bt = Backtrace.repr bt in
+  let pr_frame f = str (Backtrace.print_frame f) in
+  let bt = prlist_with_sep fnl pr_frame bt in
+  fnl () ++ hov 0 bt
+
 let print_anomaly askreport e =
   if askreport then
     hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.")
@@ -49,20 +91,20 @@ let print_anomaly askreport e =
     hov 0 (raw_anomaly e)
 
 (** The standard exception printer *)
-let print e = print_gen (print_anomaly true) !handle_stack e
+let print ?(info = Exninfo.null) e =
+  print_gen (print_anomaly true) !handle_stack e ++ print_backtrace info
+
+let iprint (e, info) = print ~info e
 
 (** Same as [print], except that the "Please report" part of an anomaly
     isn't printed (used in Ltac debugging). *)
 let print_no_report e = print_gen (print_anomaly false) !handle_stack e
 
-(** Same as [print], except that anomalies are not printed but re-raised
-    (used for the Fail command) *)
-let print_no_anomaly e = print_gen (fun e -> raise e) !handle_stack e
-
 (** Predefined handlers **)
 
 let _ = register_handler begin function
-  | Util.UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps)
+  | UserError(s, pps) ->
+    hov 0 (str "Error: " ++ where (Some s) ++ pps)
   | _ -> raise Unhandled
 end
 
@@ -70,10 +112,9 @@ end
     by inner functions during a [vernacinterp]. They should be handled
     only at the very end of interp, to be displayed to the user. *)
 
-(** NB: in the 8.4 branch, for maximal compatibility, anomalies
-    are considered non-critical *)
-
 let noncritical = function
-  | Sys.Break | Out_of_memory | Stack_overflow -> false
+  | Sys.Break | Out_of_memory | Stack_overflow
+  | Assert_failure _ | Match_failure _ | Anomaly _
+  | Timeout | Drop | Quit -> false
+  | Invalid_argument "equal: functional value" -> false
   | _ -> true
-
diff --git a/lib/errors.mli b/lib/errors.mli
index ae4d0b85..e4096a7e 100644
--- a/lib/errors.mli
+++ b/lib/errors.mli
@@ -6,9 +6,53 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
+open Pp
+
 (** This modules implements basic manipulations of errors for use
     throughout Coq's code. *)
 
+(** {6 Error handling} *)
+
+val push : exn -> Exninfo.iexn
+(** Alias for [Backtrace.add_backtrace]. *)
+
+(** {6 Generic errors.}
+
+ [Anomaly] is used for system errors and [UserError] for the
+   user's ones. *)
+
+val make_anomaly : ?label:string -> std_ppcmds -> exn
+(** Create an anomaly. *)
+
+val anomaly : ?loc:Loc.t -> ?label:string -> std_ppcmds -> 'a
+(** Raise an anomaly, with an optional location and an optional
+    label identifying the anomaly. *)
+
+val is_anomaly : exn -> bool
+(** Check whether a given exception is an anomaly.
+    This is mostly provided for compatibility. Please avoid doing specific
+    tricks with anomalies thanks to it. See rather [noncritical] below. *)
+
+exception UserError of string * std_ppcmds
+val error : string -> 'a
+val errorlabstrm : string -> std_ppcmds -> 'a
+val user_err_loc : Loc.t * string * std_ppcmds -> 'a
+
+exception AlreadyDeclared of std_ppcmds
+val alreadydeclared : std_ppcmds -> 'a
+
+val invalid_arg_loc : Loc.t * string -> 'a
+
+(** [todo] is for running of an incomplete code its implementation is
+   "do nothing" (or print a message), but this function should not be
+   used in a released code *)
+
+val todo : string -> unit
+
+exception Timeout
+exception Drop
+exception Quit
+
 (** [register_handler h] registers [h] as a handler.
     When an expression is printed with [print e], it
     goes through all registered handles (the most
@@ -30,20 +74,16 @@ exception Unhandled
 val register_handler : (exn -> Pp.std_ppcmds) -> unit
 
 (** The standard exception printer *)
-val print : exn -> Pp.std_ppcmds
+val print : ?info:Exninfo.info -> exn -> Pp.std_ppcmds
+val iprint : Exninfo.iexn -> Pp.std_ppcmds
 
 (** Same as [print], except that the "Please report" part of an anomaly
     isn't printed (used in Ltac debugging). *)
 val print_no_report : exn -> Pp.std_ppcmds
 
-(** Same as [print], except that anomalies are not printed but re-raised
-    (used for the Fail command) *)
-val print_no_anomaly : exn -> Pp.std_ppcmds
-
 (** Critical exceptions shouldn't be catched and ignored by mistake
     by inner functions during a [vernacinterp]. They should be handled
     only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user.
-    Typical example: [Sys.Break]. In the 8.4 branch, for maximal
-    compatibility, anomalies are not considered as critical...
+    Typical example: [Sys.Break], [Assert_failure], [Anomaly] ...
 *)
 val noncritical : exn -> bool
diff --git a/lib/exninfo.ml b/lib/exninfo.ml
new file mode 100644
index 00000000..d049dc6c
--- /dev/null
+++ b/lib/exninfo.ml
@@ -0,0 +1,104 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** Enriched exceptions have an additional field at the end of their usual data
+    containing a pair composed of the distinguishing [token] and the backtrace
+    information. We discriminate the token by pointer equality. *)
+
+module Store = Store.Make(struct end)
+
+type 'a t = 'a Store.field
+
+type info = Store.t
+
+type iexn = exn * info
+
+let make = Store.field
+let add = Store.set
+let get = Store.get
+let null = Store.empty
+
+exception Unique
+
+let dummy = (Unique, Store.empty)
+
+let current : (int * iexn) list ref = ref []
+(** List associating to each thread id the latest exception raised by an
+    instrumented raise (i.e. {!raise} from this module). It is shared between
+    threads, so we must take care of this when modifying it.
+
+    Invariants: all index keys are unique in the list.
+*)
+
+let lock = Mutex.create ()
+
+let rec remove_assoc (i : int) = function
+| [] -> []
+| (j, v) :: rem as l ->
+  if i = j then rem
+  else
+    let ans = remove_assoc i rem in
+    if rem == ans then l
+    else (j, v) :: ans
+
+let rec find_and_remove_assoc (i : int) = function
+| [] -> dummy, []
+| (j, v) :: rem as l ->
+  if i = j then (v, rem)
+  else
+    let (r, ans) = find_and_remove_assoc i rem in
+    if rem == ans then (r, l)
+    else (r, (j, v) :: ans)
+
+let iraise e =
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let () = current := (id, e) :: remove_assoc id !current in
+  let () = Mutex.unlock lock in
+  raise (fst e)
+
+let raise ?info e = match info with
+| None ->
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let () = current := remove_assoc id !current in
+  let () = Mutex.unlock lock in
+  raise e
+| Some i ->
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let () = current := (id, (e, i)) :: remove_assoc id !current in
+  let () = Mutex.unlock lock in
+  raise e
+
+let find_and_remove () =
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let (v, l) = find_and_remove_assoc id !current in
+  let () = current := l in
+  let () = Mutex.unlock lock in
+  v
+
+let info e =
+  let (src, data) = find_and_remove () in
+  if src == e then
+    (** Slightly unsound, some exceptions may not be unique up to pointer
+        equality. Though, it should be quite exceptional to be in a situation
+        where the following holds:
+
+        1. An argument-free exception is raised through the enriched {!raise};
+        2. It is not captured by any enriched with-clause (which would reset
+            the current data);
+        3. The same exception is raised through the standard raise, accessing
+            the wrong data.
+    . *)
+    data
+  else
+    (** Mismatch: the raised exception is not the one stored, either because the
+        previous raise was not instrumented, or because something went wrong. *)
+    Store.empty
diff --git a/lib/exninfo.mli b/lib/exninfo.mli
new file mode 100644
index 00000000..c960ac7c
--- /dev/null
+++ b/lib/exninfo.mli
@@ -0,0 +1,39 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** Additional information worn by exceptions. *)
+
+type 'a t
+(** Information containing a given type. *)
+
+type info
+(** All information *)
+
+type iexn = exn * info
+(** Information-wearing exceptions *)
+
+val make : unit -> 'a t
+(** Create a new piece of information. *)
+
+val null : info
+(** No information *)
+
+val add : info -> 'a t -> 'a -> info
+(** Add information to an exception. *)
+
+val get : info -> 'a t -> 'a option
+(** Get information worn by an exception. Returns [None] if undefined. *)
+
+val info : exn -> info
+(** Retrieve the information of the last exception raised. *)
+
+val iraise : iexn -> 'a
+(** Raise the given enriched exception. *)
+
+val raise : ?info:info -> exn -> 'a
+(** Raise the given exception with additional information. *)
diff --git a/lib/explore.ml b/lib/explore.ml
index 31a96774..3d57fc08 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -21,7 +21,7 @@ module Make = functor(S : SearchProblem) -> struct
 
   type position = int list
 
-  let msg_with_position p pp =
+  let msg_with_position (p : position) pp =
     let rec pp_rec = function
       | [] -> mt ()
       | [i] -> int i
@@ -50,7 +50,7 @@ module Make = functor(S : SearchProblem) -> struct
     in
     explore [1] s
 
-  (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
+  (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
 
   type 'a queue = 'a list * 'a list
 
@@ -58,7 +58,7 @@ module Make = functor(S : SearchProblem) -> struct
 
   let empty = [],[]
 
-  let push x (h,t) = (x::h,t)
+  let push x (h,t) : _ queue = (x::h,t)
 
   let pop = function
     | h, x::t -> x, (h,t)
diff --git a/lib/explore.mli b/lib/explore.mli
index aaf11229..f3679188 100644
--- a/lib/explore.mli
+++ b/lib/explore.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/lib/feedback.ml b/lib/feedback.ml
new file mode 100644
index 00000000..a5e16ea0
--- /dev/null
+++ b/lib/feedback.ml
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+open Serialize
+
+type message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+let of_message_level = function
+  | Debug s ->
+      Serialize.constructor "message_level" "debug" [Xml_datatype.PCData s]
+  | Info -> Serialize.constructor "message_level" "info" []
+  | Notice -> Serialize.constructor "message_level" "notice" []
+  | Warning -> Serialize.constructor "message_level" "warning" []
+  | Error -> Serialize.constructor "message_level" "error" []
+let to_message_level =
+  Serialize.do_match "message_level" (fun s args -> match s with
+  | "debug" -> Debug (Serialize.raw_string args)
+  | "info" -> Info
+  | "notice" -> Notice
+  | "warning" -> Warning
+  | "error" -> Error
+  | _ -> raise Serialize.Marshal_error)
+
+let of_message msg =
+  let lvl = of_message_level msg.message_level in
+  let content = Serialize.of_string msg.message_content in
+  Xml_datatype.Element ("message", [], [lvl; content])
+let to_message xml = match xml with
+  | Xml_datatype.Element ("message", [], [lvl; content]) -> {
+      message_level = to_message_level lvl;
+      message_content = Serialize.to_string content }
+  | _ -> raise Serialize.Marshal_error
+
+let is_message = function
+  | Xml_datatype.Element ("message", _, _) -> true
+  | _ -> false
+
+
+type edit_id = int
+type state_id = Stateid.t
+type edit_or_state_id = Edit of edit_id | State of state_id
+type route_id = int
+
+type feedback_content =
+  | Processed
+  | Incomplete
+  | Complete
+  | ErrorMsg of Loc.t * string
+  | ProcessingIn of string
+  | InProgress of int
+  | WorkerStatus of string * string
+  | Goals of Loc.t * string
+  | AddedAxiom
+  | GlobRef of Loc.t * string * string * string * string
+  | GlobDef of Loc.t * string * string * string
+  | FileDependency of string option * string
+  | FileLoaded of string * string
+  | Custom of Loc.t * string * xml
+  | Message of message
+
+type feedback = {
+  id : edit_or_state_id;
+  contents : feedback_content;
+  route : route_id;
+}
+
+let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with
+  | "addedaxiom", _ -> AddedAxiom
+  | "processed", _ -> Processed
+  | "processingin", [where] -> ProcessingIn (to_string where)
+  | "incomplete", _ -> Incomplete
+  | "complete", _ -> Complete
+  | "globref", [loc; filepath; modpath; ident; ty] ->
+       GlobRef(to_loc loc, to_string filepath,
+         to_string modpath, to_string ident, to_string ty)
+  | "globdef", [loc; ident; secpath; ty] ->
+       GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty)
+  | "errormsg", [loc;  s] -> ErrorMsg (to_loc loc, to_string s)
+  | "inprogress", [n] -> InProgress (to_int n)
+  | "workerstatus", [ns] ->
+       let n, s = to_pair to_string to_string ns in
+       WorkerStatus(n,s)
+  | "goals", [loc;s] -> Goals (to_loc loc, to_string s)
+  | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x)
+  | "filedependency", [from; dep] ->
+      FileDependency (to_option to_string from, to_string dep)
+  | "fileloaded", [dirpath; filename] ->
+      FileLoaded (to_string dirpath, to_string filename)
+  | "message", [m] -> Message (to_message m)
+  | _ -> raise Marshal_error)
+let of_feedback_content = function
+  | AddedAxiom -> constructor "feedback_content" "addedaxiom" []
+  | Processed -> constructor "feedback_content" "processed" []
+  | ProcessingIn where ->
+      constructor "feedback_content" "processingin" [of_string where]
+  | Incomplete -> constructor "feedback_content" "incomplete" []
+  | Complete -> constructor "feedback_content" "complete" []
+  | GlobRef(loc, filepath, modpath, ident, ty) ->
+      constructor "feedback_content" "globref" [
+        of_loc loc;
+        of_string filepath;
+        of_string modpath;
+        of_string ident;
+        of_string ty ]
+  | GlobDef(loc, ident, secpath, ty) ->
+      constructor "feedback_content" "globdef" [
+        of_loc loc;
+        of_string ident;
+        of_string secpath;
+        of_string ty ]
+  | ErrorMsg(loc, s) ->
+      constructor "feedback_content" "errormsg" [of_loc loc; of_string s]
+  | InProgress n -> constructor "feedback_content" "inprogress" [of_int n]
+  | WorkerStatus(n,s) ->
+      constructor "feedback_content" "workerstatus"
+        [of_pair of_string of_string (n,s)]
+  | Goals (loc,s) ->
+      constructor "feedback_content" "goals" [of_loc loc;of_string s]
+  | Custom (loc, name, x) ->
+      constructor "feedback_content" "custom" [of_loc loc; of_string name; x]
+  | FileDependency (from, depends_on) ->
+      constructor "feedback_content" "filedependency" [
+        of_option of_string from;
+        of_string depends_on]
+  | FileLoaded (dirpath, filename) ->
+      constructor "feedback_content" "fileloaded" [
+        of_string dirpath;
+        of_string filename ]
+  | Message m -> constructor "feedback_content" "message" [ of_message m ]
+
+let of_edit_or_state_id = function
+  | Edit id -> ["object","edit"], of_edit_id id
+  | State id -> ["object","state"], Stateid.to_xml id
+
+let of_feedback msg =
+  let content = of_feedback_content msg.contents in
+  let obj, id = of_edit_or_state_id msg.id in
+  let route = string_of_int msg.route in
+  Element ("feedback", obj @ ["route",route], [id;content])
+let to_feedback xml = match xml with
+  | Element ("feedback", ["object","edit";"route",route], [id;content]) -> {
+      id = Edit(to_edit_id id);
+      route = int_of_string route;
+      contents = to_feedback_content content }
+  | Element ("feedback", ["object","state";"route",route], [id;content]) -> { 
+      id = State(Stateid.of_xml id);
+      route = int_of_string route;
+      contents = to_feedback_content content }
+  | _ -> raise Marshal_error
+
+let is_feedback = function
+  | Element ("feedback", _, _) -> true
+  | _ -> false
+
+let default_route = 0
diff --git a/lib/feedback.mli b/lib/feedback.mli
new file mode 100644
index 00000000..52a0e9fe
--- /dev/null
+++ b/lib/feedback.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+(* Old plain messages (used to be in Pp) *)
+type message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+val of_message : message -> xml
+val to_message : xml -> message
+val is_message : xml -> bool
+
+
+(** Coq "semantic" infos obtained during parsing/execution *)
+type edit_id = int
+type state_id = Stateid.t
+type edit_or_state_id = Edit of edit_id | State of state_id
+type route_id = int
+
+val default_route : route_id
+
+type feedback_content =
+  (* STM mandatory data (must be displayed) *)
+  | Processed
+  | Incomplete
+  | Complete
+  | ErrorMsg of Loc.t * string
+  (* STM optional data *)
+  | ProcessingIn of string
+  | InProgress of int
+  | WorkerStatus of string * string
+  (* Generally useful metadata *)
+  | Goals of Loc.t * string
+  | AddedAxiom
+  | GlobRef of Loc.t * string * string * string * string
+  | GlobDef of Loc.t * string * string * string
+  | FileDependency of string option * string
+  | FileLoaded of string * string
+  (* Extra metadata *)
+  | Custom of Loc.t * string * xml
+  (* Old generic messages *)
+  | Message of message
+
+type feedback = {
+  id : edit_or_state_id;       (* The document part concerned *)
+  contents : feedback_content;  (* The payload *)
+  route : route_id;            (* Extra routing info *)
+}
+
+val of_feedback : feedback -> xml
+val to_feedback : xml -> feedback
+val is_feedback : xml -> bool
+
diff --git a/lib/flags.ml b/lib/flags.ml
index f6d98ba5..c8e7f7af 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,47 +8,116 @@
 
 let with_option o f x =
   let old = !o in o:=true;
-  try let r = f x in o := old; r
-  with reraise -> o := old; raise reraise
+   try let r = f x in if !o = true then o := old; r
+   with reraise ->
+     let reraise = Backtrace.add_backtrace reraise in
+     let () = o := old in
+     Exninfo.iraise reraise
+
+let with_options ol f x =
+  let vl = List.map (!) ol in
+  let () = List.iter (fun r -> r := true) ol in
+  try
+    let r = f x in
+    let () = List.iter2 (:=) ol vl in r
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = List.iter2 (:=) ol vl in
+    Exninfo.iraise reraise
 
 let without_option o f x =
   let old = !o in o:=false;
+  try let r = f x in if !o = false then o := old; r
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = o := old in
+    Exninfo.iraise reraise
+
+let with_extra_values o l f x =
+  let old = !o in o:=old@l;
   try let r = f x in o := old; r
-  with reraise -> o := old; raise reraise
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = o := old in
+    Exninfo.iraise reraise
 
 let boot = ref false
-
+let load_init = ref true
 let batch_mode = ref false
 
-let debug = ref false
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+let compilation_mode = ref BuildVo
+
+type async_proofs = APoff | APonLazy | APon
+let async_proofs_mode = ref APoff
+type cache = Force
+let async_proofs_cache = ref None
+let async_proofs_n_workers = ref 1
+let async_proofs_n_tacworkers = ref 2
+let async_proofs_private_flags = ref None
+let async_proofs_full = ref false
+let async_proofs_never_reopen_branch = ref false
+let async_proofs_flags_for_workers = ref []
+let async_proofs_worker_id = ref "master"
+type priority = Low | High
+let async_proofs_worker_priority = ref Low
+let string_of_priority = function Low -> "low" | High -> "high"
+let priority_of_string = function
+  | "low" -> Low
+  | "high" -> High
+  | _ -> raise (Invalid_argument "priority_of_string")
+
+let async_proofs_is_worker () =
+  !async_proofs_worker_id <> "master"
+let async_proofs_is_master () =
+  !async_proofs_mode = APon && !async_proofs_worker_id = "master"
 
-let print_emacs = ref false
+let debug = ref false
+let in_debugger = ref false
+let in_toplevel = ref false
 
-let term_quality = ref false
+let profile = false
 
-let xml_export = ref false
+let print_emacs = ref false
+let coqtop_ui = ref false
 
-type load_proofs = Force | Lazy | Dont
+let ide_slave = ref false
+let ideslave_coqtop_flags = ref None
 
-let load_proofs = ref Lazy
+let time = ref false
 
 let raw_print = ref false
 
 let record_print = ref true
 
+let univ_print = ref false
+
+let we_are_parsing = ref false
+
 (* Compatibility mode *)
 
 (* Current means no particular compatibility consideration.
    For correct comparisons, this constructor should remain the last one. *)
 
-type compat_version = V8_2 | V8_3 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | Current
+
 let compat_version = ref Current
-let version_strictly_greater v = !compat_version > v
+
+let version_strictly_greater v = match !compat_version, v with
+| V8_2, (V8_2 | V8_3 | V8_4 | Current) -> false
+| V8_3, (V8_3 | V8_4 | Current) -> false
+| V8_4, (V8_4 | Current) -> false
+| Current, Current -> false
+| V8_3, V8_2 -> true
+| V8_4, (V8_2 | V8_3) -> true
+| Current, (V8_2 | V8_3 | V8_4) -> true
+
 let version_less_or_equal v = not (version_strictly_greater v)
 
 let pr_version = function
   | V8_2 -> "8.2"
   | V8_3 -> "8.3"
+  | V8_4 -> "8.4"
   | Current -> "current"
 
 (* Translate *)
@@ -73,7 +142,23 @@ let auto_intros = ref true
 let make_auto_intros flag = auto_intros := flag
 let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros
 
-let hash_cons_proofs = ref true
+let universe_polymorphism = ref false
+let make_universe_polymorphism b = universe_polymorphism := b
+let is_universe_polymorphism () = !universe_polymorphism
+
+let local_polymorphic_flag = ref None
+let use_polymorphic_flag () = 
+  match !local_polymorphic_flag with 
+  | Some p -> local_polymorphic_flag := None; p
+  | None -> is_universe_polymorphism ()
+let make_polymorphic_flag b =
+  local_polymorphic_flag := Some b
+
+(** [program_mode] tells that Program mode has been activated, either
+    globally via [Set Program] or locally via the Program command prefix. *)
+
+let program_mode = ref false
+let is_program_mode () = !program_mode
 
 let warn = ref true
 let make_warn flag = warn := flag;  ()
@@ -85,28 +170,8 @@ let print_hyps_limit = ref (None : int option)
 let set_print_hyps_limit n = print_hyps_limit := n
 let print_hyps_limit () = !print_hyps_limit
 
-(* A list of the areas of the system where "unsafe" operation
- * has been requested *)
-
-module Stringset = Set.Make(struct type t = string let compare = compare end)
-
-let unsafe_set = ref Stringset.empty
-let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set
-let is_unsafe s = Stringset.mem s !unsafe_set
-
 (* Flags for external tools *)
 
-let subst_command_placeholder s t =
-  let buff = Buffer.create (String.length s + String.length t) in
-  let i = ref 0 in
-  while (!i < String.length s) do
-    if s.[!i] = '%' & !i+1 < String.length s & s.[!i+1] = 's'
-    then (Buffer.add_string buff t;incr i)
-    else Buffer.add_char buff s.[!i];
-    incr i
-  done;
-  Buffer.contents buff
-
 let browser_cmd_fmt =
  try
   let coq_netscape_remote_var = "COQREMOTEBROWSER" in
@@ -122,21 +187,9 @@ let is_standard_doc_url url =
   url = Coq_config.wwwrefman ||
   url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n)
 
-(* same as in System, but copied here because of dependencies *)
-let canonical_path_name p =
-  let current = Sys.getcwd () in
-  Sys.chdir p;
-  let result = Sys.getcwd () in
-  Sys.chdir current;
-  result
-
 (* Options for changing coqlib *)
 let coqlib_spec = ref false
-let coqlib = ref (
-  (* same as Envars.coqroot, but copied here because of dependencies *)
-  Filename.dirname
-    (canonical_path_name (Filename.dirname Sys.executable_name))
-)
+let coqlib = ref "(not initialized yet)"
 
 (* Options for changing camlbin (used by coqmktop) *)
 let camlbin_spec = ref false
@@ -152,3 +205,11 @@ let default_inline_level = 100
 let inline_level = ref default_inline_level
 let set_inline_level = (:=) inline_level
 let get_inline_level () = !inline_level
+
+(* Disabling native code compilation for conversion and normalization *)
+let no_native_compiler = ref Coq_config.no_native_compiler
+
+(* Print the mod uid associated to a vo file by the native compiler *)
+let print_mod_uid = ref false
+
+let tactic_context_compat = ref false
diff --git a/lib/flags.mli b/lib/flags.mli
index ede4629c..756d3b85 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,24 +9,51 @@
 (** Global options of the system. *)
 
 val boot : bool ref
+val load_init : bool ref
 
 val batch_mode : bool ref
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+val compilation_mode : compilation_mode ref
+
+type async_proofs = APoff | APonLazy | APon
+val async_proofs_mode : async_proofs ref
+type cache = Force
+val async_proofs_cache : cache option ref
+val async_proofs_n_workers : int ref
+val async_proofs_n_tacworkers : int ref
+val async_proofs_private_flags : string option ref
+val async_proofs_is_worker : unit -> bool
+val async_proofs_is_master : unit -> bool
+val async_proofs_full : bool ref
+val async_proofs_never_reopen_branch : bool ref
+val async_proofs_flags_for_workers : string list ref
+val async_proofs_worker_id : string ref
+type priority = Low | High
+val async_proofs_worker_priority : priority ref
+val string_of_priority : priority -> string
+val priority_of_string : string -> priority
 
 val debug : bool ref
+val in_debugger : bool ref
+val in_toplevel : bool ref
+
+val profile : bool
 
 val print_emacs : bool ref
+val coqtop_ui : bool ref
 
-val term_quality : bool ref
+val ide_slave : bool ref
+val ideslave_coqtop_flags : string option ref
 
-val xml_export : bool ref
+val time : bool ref
 
-type load_proofs = Force | Lazy | Dont
-val load_proofs : load_proofs ref
+val we_are_parsing : bool ref
 
 val raw_print : bool ref
 val record_print : bool ref
+val univ_print : bool ref
 
-type compat_version = V8_2 | V8_3 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | Current
 val compat_version : compat_version ref
 val version_strictly_greater : compat_version -> bool
 val version_less_or_equal : compat_version -> bool
@@ -48,25 +75,37 @@ val if_verbose : ('a -> unit) -> 'a -> unit
 val make_auto_intros : bool -> unit
 val is_auto_intros : unit -> bool
 
+val program_mode : bool ref
+val is_program_mode : unit -> bool
+
+(** Global universe polymorphism flag. *)
+val make_universe_polymorphism : bool -> unit
+val is_universe_polymorphism : unit -> bool
+
+(** Local universe polymorphism flag. *)
+val make_polymorphic_flag : bool -> unit
+val use_polymorphic_flag : unit -> bool
+
 val make_warn : bool -> unit
 val if_warn : ('a -> unit) -> 'a -> unit
 
-val hash_cons_proofs : bool ref
-
-(** Temporary activate an option (to activate option [o] on [f x y z],
+(** Temporarily activate an option (to activate option [o] on [f x y z],
    use [with_option o (f x y) z]) *)
 val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
-(** Temporary deactivate an option *)
+(** As [with_option], but on several flags. *)
+val with_options : bool ref list -> ('a -> 'b) -> 'a -> 'b
+
+(** Temporarily deactivate an option *)
 val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
+(** Temporarily extends the reference to a list *)
+val with_extra_values : 'c list ref -> 'c list -> ('a -> 'b) -> 'a -> 'b
+
 (** If [None], no limit *)
 val set_print_hyps_limit : int option -> unit
 val print_hyps_limit : unit -> int option
 
-val add_unsafe : string -> unit
-val is_unsafe : string -> bool
-
 (** Options for external tools *)
 
 (** Returns string format for default browser to use from Coq or CoqIDE *)
@@ -74,9 +113,6 @@ val browser_cmd_fmt : string
 
 val is_standard_doc_url : string -> bool
 
-(** Substitute %s in the first chain by the second chain *)
-val subst_command_placeholder : string -> string -> string
-
 (** Options for specifying where coq librairies reside *)
 val coqlib_spec : bool ref
 val coqlib : string ref
@@ -91,3 +127,13 @@ val camlp4bin : string ref
 val set_inline_level : int -> unit
 val get_inline_level : unit -> int
 val default_inline_level : int
+
+(* Disabling native code compilation for conversion and normalization *)
+val no_native_compiler : bool ref
+
+(* Print the mod uid associated to a vo file by the native compiler *)
+val print_mod_uid : bool ref
+
+val tactic_context_compat : bool ref
+(** Set to [true] to trigger the compatibility bugged context matching (old
+    context vs. appcontext) is set. *)
diff --git a/lib/fmap.ml b/lib/fmap.ml
deleted file mode 100644
index 8ca56fe7..00000000
--- a/lib/fmap.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-
-module Make = functor (X:Map.OrderedType) -> struct
-  type key = X.t
-  type 'a t =
-        Empty
-      | Node of 'a t * key * 'a * 'a t * int
-
-    let empty = Empty
-
-    let is_empty = function Empty -> true | _ -> false
-
-    let height = function
-        Empty -> 0
-      | Node(_,_,_,_,h) -> h
-
-    let create l x d r =
-      let hl = height l and hr = height r in
-      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let bal l x d r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      if hl > hr + 2 then begin
-        match l with
-          Empty -> invalid_arg "Map.bal"
-        | Node(ll, lv, ld, lr, _) ->
-            if height ll >= height lr then
-              create ll lv ld (create lr x d r)
-            else begin
-              match lr with
-                Empty -> invalid_arg "Map.bal"
-              | Node(lrl, lrv, lrd, lrr, _)->
-                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
-            end
-      end else if hr > hl + 2 then begin
-        match r with
-          Empty -> invalid_arg "Map.bal"
-        | Node(rl, rv, rd, rr, _) ->
-            if height rr >= height rl then
-              create (create l x d rl) rv rd rr
-            else begin
-              match rl with
-                Empty -> invalid_arg "Map.bal"
-              | Node(rll, rlv, rld, rlr, _) ->
-                  create (create l x d rll) rlv rld (create rlr rv rd rr)
-            end
-      end else
-        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let rec add x data = function
-        Empty ->
-          Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) ->
-          let c = X.compare x v in
-          if c = 0 then
-            Node(l, x, data, r, h)
-          else if c < 0 then
-            bal (add x data l) v d r
-          else
-            bal l v d (add x data r)
-
-    let rec find x = function
-        Empty ->
-          raise Not_found
-      | Node(l, v, d, r, _) ->
-          let c = X.compare x v in
-          if c = 0 then d
-          else find x (if c < 0 then l else r)
-
-    let rec mem x = function
-        Empty ->
-          false
-      | Node(l, v, d, r, _) ->
-          let c = X.compare x v in
-          c = 0 || mem x (if c < 0 then l else r)
-
-    let rec min_binding = function
-        Empty -> raise Not_found
-      | Node(Empty, x, d, r, _) -> (x, d)
-      | Node(l, x, d, r, _) -> min_binding l
-
-    let rec remove_min_binding = function
-        Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, x, d, r, _) -> r
-      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
-    let merge t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (_, _) ->
-          let (x, d) = min_binding t2 in
-          bal t1 x d (remove_min_binding t2)
-
-    let rec remove x = function
-        Empty ->
-          Empty
-      | Node(l, v, d, r, h) ->
-          let c = X.compare x v in
-          if c = 0 then
-            merge l r
-          else if c < 0 then
-            bal (remove x l) v d r
-          else
-            bal l v d (remove x r)
-
-    let rec iter f = function
-        Empty -> ()
-      | Node(l, v, d, r, _) ->
-          iter f l; f v d; iter f r
-
-    let rec map f = function
-        Empty               -> Empty
-      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
-
-    (* Maintien de fold_right par compatibilité (changé en fold_left dans
-       ocaml-3.09.0) *)
-
-    let rec fold f m accu =
-      match m with
-        Empty -> accu
-      | Node(l, v, d, r, _) ->
-          fold f l (f v d (fold f r accu))
-
-(* Added with respect to ocaml standard library. *)
-
-    let dom m = fold (fun x _ acc -> x::acc) m []
-
-    let rng m = fold (fun _ y acc -> y::acc) m []
-
-    let to_list m = fold (fun x y acc -> (x,y)::acc) m []
-
-end
diff --git a/lib/fmap.mli b/lib/fmap.mli
deleted file mode 100644
index 2c8dedd7..00000000
--- a/lib/fmap.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-
-module Make : functor (X : Map.OrderedType) ->
-sig
-  type key = X.t
-  type 'a t
-
-val empty : 'a t
-val is_empty : 'a t -> bool
-val add : key -> 'a -> 'a t -> 'a t
-val find : key -> 'a t -> 'a
-val remove : key -> 'a t -> 'a t
-val mem :  key -> 'a t -> bool
-val iter : (key -> 'a -> unit) -> 'a t -> unit
-val map : ('a -> 'b) -> 'a t -> 'b t
-val fold : (key -> 'a -> 'c -> 'c) -> 'a t -> 'c -> 'c
-
-(** Additions with respect to ocaml standard library. *)
-
-val dom : 'a t -> key list
-val rng : 'a t -> 'a list
-val to_list : 'a t -> (key * 'a) list
-end
- 
diff --git a/lib/fset.ml b/lib/fset.ml
deleted file mode 100644
index 567feaa7..00000000
--- a/lib/fset.ml
+++ /dev/null
@@ -1,235 +0,0 @@
-module Make = functor (X : Set.OrderedType) ->
-struct
-  
-  type elt = X.t
-    type t = Empty | Node of t * elt * t * int
-
-
-    (* Sets are represented by balanced binary trees (the heights of the
-       children differ by at most 2 *)
-
-    let height = function
-        Empty -> 0
-      | Node(_, _, _, h) -> h
-
-    (* Creates a new node with left son l, value x and right son r.
-       l and r must be balanced and | height l - height r | <= 2.
-       Inline expansion of height for better speed. *)
-
-    let create l x r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
-      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    (* Same as create, but performs one step of rebalancing if necessary.
-       Assumes l and r balanced.
-       Inline expansion of create for better speed in the most frequent case
-       where no rebalancing is required. *)
-
-    let bal l x r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
-      if hl > hr + 2 then begin
-        match l with
-          Empty -> invalid_arg "Set.bal"
-        | Node(ll, lv, lr, _) ->
-            if height ll >= height lr then
-              create ll lv (create lr x r)
-            else begin
-              match lr with
-                Empty -> invalid_arg "Set.bal"
-              | Node(lrl, lrv, lrr, _)->
-                  create (create ll lv lrl) lrv (create lrr x r)
-            end
-      end else if hr > hl + 2 then begin
-        match r with
-          Empty -> invalid_arg "Set.bal"
-        | Node(rl, rv, rr, _) ->
-            if height rr >= height rl then
-              create (create l x rl) rv rr
-            else begin
-              match rl with
-                Empty -> invalid_arg "Set.bal"
-              | Node(rll, rlv, rlr, _) ->
-                  create (create l x rll) rlv (create rlr rv rr)
-            end
-      end else
-        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    (* Same as bal, but repeat rebalancing until the final result
-       is balanced. *)
-
-    let rec join l x r =
-      match bal l x r with
-        Empty -> invalid_arg "Set.join"
-      | Node(l', x', r', _) as t' ->
-          let d = height l' - height r' in
-          if d < -2 or d > 2 then join l' x' r' else t'
-
-    (* Merge two trees l and r into one.
-       All elements of l must precede the elements of r.
-       Assumes | height l - height r | <= 2. *)
-
-    let rec merge t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
-          bal l1 v1 (bal (merge r1 l2) v2 r2)
-
-    (* Same as merge, but does not assume anything about l and r. *)
-
-    let rec concat t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
-          join l1 v1 (join (concat r1 l2) v2 r2)
-
-    (* Splitting *)
-
-    let rec split x = function
-        Empty ->
-          (Empty, None, Empty)
-      | Node(l, v, r, _) ->
-          let c = X.compare x v in
-          if c = 0 then (l, Some v, r)
-          else if c < 0 then
-            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
-          else
-            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
-
-    (* Implementation of the set operations *)
-
-    let empty = Empty
-
-    let is_empty = function Empty -> true | _ -> false
-
-    let rec mem x = function
-        Empty -> false
-      | Node(l, v, r, _) ->
-          let c = X.compare x v in
-          c = 0 || mem x (if c < 0 then l else r)
-
-    let rec add x = function
-        Empty -> Node(Empty, x, Empty, 1)
-      | Node(l, v, r, _) as t ->
-          let c = X.compare x v in
-          if c = 0 then t else
-          if c < 0 then bal (add x l) v r else bal l v (add x r)
-
-    let singleton x = Node(Empty, x, Empty, 1)
-
-    let rec remove x = function
-        Empty -> Empty
-      | Node(l, v, r, _) ->
-          let c = X.compare x v in
-          if c = 0 then merge l r else
-          if c < 0 then bal (remove x l) v r else bal l v (remove x r)
-
-    let rec union s1 s2 =
-      match (s1, s2) with
-        (Empty, t2) -> t2
-      | (t1, Empty) -> t1
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
-          if h1 >= h2 then
-            if h2 = 1 then add v2 s1 else begin
-              let (l2, _, r2) = split v1 s2 in
-              join (union l1 l2) v1 (union r1 r2)
-            end
-          else
-            if h1 = 1 then add v1 s2 else begin
-              let (l1, _, r1) = split v2 s1 in
-              join (union l1 l2) v2 (union r1 r2)
-            end
-
-    let rec inter s1 s2 =
-      match (s1, s2) with
-        (Empty, t2) -> Empty
-      | (t1, Empty) -> Empty
-      | (Node(l1, v1, r1, _), t2) ->
-          match split v1 t2 with
-            (l2, None, r2) ->
-              concat (inter l1 l2) (inter r1 r2)
-          | (l2, Some _, r2) ->
-              join (inter l1 l2) v1 (inter r1 r2)
-
-    let rec diff s1 s2 =
-      match (s1, s2) with
-        (Empty, t2) -> Empty
-      | (t1, Empty) -> t1
-      | (Node(l1, v1, r1, _), t2) ->
-          match split v1 t2 with
-            (l2, None, r2) ->
-              join (diff l1 l2) v1 (diff r1 r2)
-          | (l2, Some _, r2) ->
-              concat (diff l1 l2) (diff r1 r2)
-
-    let rec compare_aux l1 l2 =
-        match (l1, l2) with
-        ([], []) -> 0
-      | ([], _)  -> -1
-      | (_, []) -> 1
-      | (Empty :: t1, Empty :: t2) ->
-          compare_aux t1 t2
-      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
-          let c = compare v1 v2 in
-          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
-      | (Node(l1, v1, r1, _) :: t1, t2) ->
-          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
-      | (t1, Node(l2, v2, r2, _) :: t2) ->
-          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
-
-    let compare s1 s2 =
-      compare_aux [s1] [s2]
-
-    let equal s1 s2 =
-      compare s1 s2 = 0
-
-    let rec subset s1 s2 =
-      match (s1, s2) with
-        Empty, _ ->
-          true
-      | _, Empty ->
-          false
-      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
-          let c = X.compare v1 v2 in
-          if c = 0 then
-            subset l1 l2 && subset r1 r2
-          else if c < 0 then
-            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
-          else
-            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
-
-    let rec iter f = function
-        Empty -> ()
-      | Node(l, v, r, _) -> iter f l; f v; iter f r
-
-    let rec fold f s accu =
-      match s with
-        Empty -> accu
-      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
-
-    let rec cardinal = function
-        Empty -> 0
-      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
-
-    let rec elements_aux accu = function
-        Empty -> accu
-      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
-
-    let elements s =
-      elements_aux [] s
-
-    let rec min_elt = function
-        Empty -> raise Not_found
-      | Node(Empty, v, r, _) -> v
-      | Node(l, v, r, _) -> min_elt l
-
-    let rec max_elt = function
-        Empty -> raise Not_found
-      | Node(l, v, Empty, _) -> v
-      | Node(l, v, r, _) -> max_elt r
-
-    let choose = min_elt
-end
diff --git a/lib/fset.mli b/lib/fset.mli
deleted file mode 100644
index b1751d0b..00000000
--- a/lib/fset.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-module Make : functor (X : Set.OrderedType) ->
-sig
-  type elt = X.t
-  type  t
-
-val empty :  t
-val is_empty :  t -> bool
-val mem : elt ->  t -> bool
-val add : elt ->  t ->  t
-val singleton : elt ->  t
-val remove : elt -> t -> t
-val union : t -> t -> t
-val inter : t -> t -> t
-val diff : t -> t -> t
-val compare : t -> t -> int
-val equal : t -> t -> bool
-val subset : t -> t -> bool
-val iter : ( elt -> unit) -> t -> unit
-val fold : (elt -> 'b -> 'b) -> t -> 'b -> 'b
-val cardinal : t -> int
-val elements : t -> elt list
-val min_elt : t -> elt
-val max_elt : t -> elt
-val choose : t -> elt
-end
diff --git a/lib/future.ml b/lib/future.ml
new file mode 100644
index 00000000..2f1ce5e4
--- /dev/null
+++ b/lib/future.ml
@@ -0,0 +1,220 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* To deal with side effects we have to save/restore the system state *)
+let freeze = ref (fun () -> assert false : unit -> Dyn.t)
+let unfreeze = ref (fun _ -> () : Dyn.t -> unit)
+let set_freeze f g = freeze := f; unfreeze := g
+
+exception NotReady
+exception NotHere
+let _ = Errors.register_handler (function
+  | NotReady ->
+      Pp.strbrk("The value you are asking for is not ready yet. " ^
+                "Please wait or pass "^
+                "the \"-async-proofs off\" option to CoqIDE to disable "^
+                "asynchronous script processing.")
+  | NotHere ->
+      Pp.strbrk("The value you are asking for is not available "^
+                "in this process. If you really need this, pass "^
+                "the \"-async-proofs off\" option to CoqIDE to disable "^
+                "asynchronous script processing.")
+  | _ -> raise Errors.Unhandled)
+
+type fix_exn = Exninfo.iexn -> Exninfo.iexn
+let id x = prerr_endline "Future: no fix_exn.\nYou have probably created a Future.computation from a value without passing the ~fix_exn argument.  You probably want to chain with an already existing future instead."; x
+
+module UUID = struct
+  type t = int
+  let invalid = 0
+  let fresh =
+    let count = ref invalid in
+    fun () -> incr count; !count
+
+  let compare = compare
+  let equal = (==)
+end
+
+module UUIDMap = Map.Make(UUID)
+module UUIDSet = Set.Make(UUID)
+
+type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation]
+
+(* Val is not necessarily a final state, so the
+   computation restarts from the state stocked into Val *)
+and 'a comp =
+  | Delegated of (unit -> unit)
+  | Closure of (unit -> 'a)
+  | Val of 'a * Dyn.t option
+  | Exn of Exninfo.iexn  (* Invariant: this exception is always "fixed" as in fix_exn *)
+
+and 'a comput =
+  | Ongoing of (UUID.t * fix_exn * 'a comp ref) Ephemeron.key
+  | Finished of 'a
+
+and 'a computation = 'a comput ref
+
+let create ?(uuid=UUID.fresh ()) f x =
+  ref (Ongoing (Ephemeron.create (uuid, f, Pervasives.ref x)))
+let get x =
+  match !x with
+  | Finished v -> UUID.invalid, id, ref (Val (v,None))
+  | Ongoing x ->
+      try Ephemeron.get x
+      with Ephemeron.InvalidKey ->
+        UUID.invalid, id, ref (Exn (NotHere, Exninfo.null))
+
+type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn  ]
+
+let is_over kx = let _, _, x = get kx in match !x with
+  | Val _ | Exn _ -> true
+  | Closure _ | Delegated _ -> false
+
+let is_val kx = let _, _, x = get kx in match !x with
+  | Val _ -> true
+  | Exn _ | Closure _ | Delegated _ -> false
+
+let is_exn kx = let _, _, x = get kx in match !x with
+  | Exn _ -> true
+  | Val _ | Closure _ | Delegated _ -> false
+
+let peek_val kx = let _, _, x = get kx in match !x with
+  | Val (v, _) -> Some v
+  | Exn _ | Closure _ | Delegated _ -> None
+
+let uuid kx = let id, _, _ = get kx in id
+
+let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None))
+let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ())))
+
+let fix_exn_of ck = let _, fix_exn, _ = get ck in fix_exn
+
+let create_delegate ?(blocking=true) fix_exn =
+  let assignement signal ck = fun v ->
+    let _, fix_exn, c = get ck in
+    assert (match !c with Delegated _ -> true | _ -> false);
+    begin match v with
+    | `Val v -> c := Val (v, None)
+    | `Exn e -> c := Exn (fix_exn e)
+    | `Comp f -> let _, _, comp = get f in c := !comp end;
+    signal () in
+  let wait, signal =
+    if not blocking then (fun () -> raise NotReady), ignore else
+    let lock = Mutex.create () in
+    let cond = Condition.create () in
+    (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock),
+    (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in
+  let ck = create fix_exn (Delegated wait) in
+  ck, assignement signal ck
+
+(* TODO: get rid of try/catch to be stackless *)
+let rec compute ~pure ck : 'a value =
+  let _, fix_exn, c = get ck in
+  match !c with
+  | Val (x, _) -> `Val x
+  | Exn (e, info) -> `Exn (e, info)
+  | Delegated wait -> wait (); compute ~pure ck
+  | Closure f ->
+      try
+        let data = f () in
+        let state = if pure then None else Some (!freeze ()) in
+        c := Val (data, state); `Val data
+      with e ->
+        let e = Errors.push e in
+        let e = fix_exn e in
+        match e with
+        | (NotReady, _) -> `Exn e
+        | _ -> c := Exn e; `Exn e
+
+let force ~pure x = match compute ~pure x with
+  | `Val v -> v
+  | `Exn e -> Exninfo.iraise e
+
+let chain ~pure ck f =
+  let uuid, fix_exn, c = get ck in
+  create ~uuid fix_exn (match !c with
+  | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck))
+  | Exn _ as x -> x
+  | Val (v, None) when pure -> Closure (fun () -> f v)
+  | Val (v, Some _) when pure -> Closure (fun () -> f v)
+  | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v)
+  | Val (v, None) ->
+      match !ck with
+      | Finished _ -> Errors.anomaly(Pp.str
+          "Future.chain ~pure:false call on an already joined computation")
+      | Ongoing _ -> Errors.anomaly(Pp.strbrk(
+          "Future.chain ~pure:false call on a pure computation. "^
+          "This can happen if the computation was initial created with "^
+          "Future.from_val or if it was Future.chain ~pure:true with a "^
+          "function and later forced.")))
+
+let create fix_exn f = create fix_exn (Closure f)
+
+let replace kx y =
+  let _, _, x = get kx in
+  match !x with
+  | Exn _ -> x := Closure (fun () -> force ~pure:false y)
+  | _ -> Errors.anomaly
+           (Pp.str "A computation can be replaced only if is_exn holds")
+
+let purify f x =
+  let state = !freeze () in
+  try
+    let v = f x in
+    !unfreeze state;
+    v
+  with e ->
+    let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+
+let transactify f x =
+  let state = !freeze () in
+  try f x
+  with e ->
+    let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+
+let purify_future f x = if is_over x then f x else purify f x
+let compute x = purify_future (compute ~pure:false) x
+let force ~pure x = purify_future (force ~pure) x
+let chain ?(greedy=true) ~pure x f =
+  let y = chain ~pure x f in
+  if is_over x && greedy then ignore(force ~pure y);
+  y
+let force x = force ~pure:false x
+
+let join kx =
+  let v = force kx in
+  kx := Finished v;
+  v
+
+let sink kx = if is_val kx then ignore(join kx)
+
+let split2 ?greedy x =
+  chain ?greedy ~pure:true x (fun x -> fst x),
+  chain ?greedy ~pure:true x (fun x -> snd x)
+
+let map2 ?greedy f x l =
+  CList.map_i (fun i y ->
+    let xi = chain ?greedy ~pure:true x (fun x ->
+        try List.nth x i
+        with Failure _ | Invalid_argument _ ->
+          Errors.anomaly (Pp.str "Future.map2 length mismatch")) in
+    f xi y) 0 l
+
+let print f kx =
+  let open Pp in
+  let (uid, _, x) = get kx in
+  let uid =
+    if UUID.equal uid UUID.invalid then str "[#]"
+    else str "[" ++ int uid ++ str "]"
+  in
+  match !x with
+  | Delegated _ -> str "Delegated" ++ uid
+  | Closure _ -> str "Closure" ++ uid
+  | Val (x, None) -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x)
+  | Val (x, Some _) -> str "StateVal" ++ uid ++ spc () ++ hov 0 (f x)
+  | Exn (e, _) -> str "Exn"  ++ uid ++ spc () ++ hov 0 (str (Printexc.to_string e))
diff --git a/lib/future.mli b/lib/future.mli
new file mode 100644
index 00000000..8a4fa0bd
--- /dev/null
+++ b/lib/future.mli
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Futures: asynchronous computations with some purity enforcing
+ *
+ * A Future.computation is like a lazy_t but with some extra bells and whistles
+ * to deal with imperative code and eventual delegation to a slave process.
+ *
+ * Example of a simple scenario taken into account:
+ *
+ *   let f = Future.from_here (number_of_constants (Global.env())) in
+ *   let g = Future.chain ~pure:false f (fun n ->
+ *             n = number_of_constants (Global.env())) in
+ *   ...
+ *   Lemmas.save_named ...;
+ *   ...
+ *   let b = Future.force g in
+ *
+ * The Future.computation f holds a (immediate, no lazy here) value.
+ * We then chain to obtain g that (will) hold false if (when it will be
+ * run) the global environment has a different number of constants, true
+ * if nothing changed.
+ * Before forcing g, we add to the global environment one more constant.
+ * When finally we force g.  Its value is going to be *true*.
+ * This because Future.from_here stores in the computation not only the initial
+ * value but the entire system state.  When g is forced the state is restored,
+ * hence Global.env() returns the environment that was actual when f was
+ * created.
+ * Last, forcing g is run protecting the system state, hence when g finishes,
+ * the actual system state is restored.
+ *
+ * If you compare this with lazy_t, you see that the value returned is *false*,
+ * that is counter intuitive and error prone.
+ *
+ * Still not all computations are impure and access/alter the system state.
+ * This class can be optimized by using ~pure:true, but there is no way to
+ * statically check if this flag is misused, hence use it with care.
+ *
+ * Other differences with lazy_t is that a future computation that produces
+ * and exception can be substituted for another computation of the same type.
+ * Moreover a future computation can be delegated to another execution entity
+ * that will be allowed to set the result.  Finally future computations can
+ * always be marshalled: if they were joined before marshalling, they will
+ * hold the computed value (assuming it is itself marshallable), otherwise
+ * they will become invalid and accessing them raises a private exception.
+ *)
+
+(* Each computation has a unique id that is inherited by each offspring
+ * computation (chain, split, map...).  Joined computations lose it.  *)
+module UUID : sig
+  type t
+  val invalid : t
+
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+end
+
+module UUIDMap : Map.S with type key = UUID.t
+module UUIDSet : Set.S with type elt = UUID.t
+
+exception NotReady
+
+type 'a computation
+type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ]
+type fix_exn = Exninfo.iexn -> Exninfo.iexn
+
+(* Build a computation, no snapshot of the global state is taken.  If you need
+   to grab a copy of the state start with from_here () and then chain.
+   fix_exn is used to enrich any exception raised
+   by forcing the computations or any computation that is chained after
+   it. It is used by STM to attach errors to their corresponding states,
+   and to communicate to the code catching the exception a valid state id. *)
+val create : fix_exn -> (unit -> 'a) -> 'a computation
+
+(* Usually from_val is used to create "fake" futures, to use the same API
+   as if a real asynchronous computations was there.  In this case fixing
+   the exception is not needed, but *if* the future is chained, the fix_exn
+   argument should really be given *)
+val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation
+
+(* Like from_val, but also takes a snapshot of the global state.  Morally
+   the value is not just the 'a but also the global system state *)
+val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation
+
+(* To get the fix_exn of a computation and build a Tacexpr.declaration_hook.
+ * When a future enters the environment a corresponding hook is run to perform
+ * some work.  If this fails, then its failure has to be annotated with the
+ * same state id that corresponds to the future computation end.  I.e. Qed
+ * is split into two parts, the lazy one (the future) and the eagher one
+ * (the hook), both performing some computations for the same state id. *)
+val fix_exn_of : 'a computation -> fix_exn
+
+(* Run remotely, returns the function to assign.
+   If not blocking (the default) it raises NotReady if forced before the
+   delage assigns it. *)
+type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation]
+val create_delegate :
+  ?blocking:bool -> fix_exn -> 'a computation * ('a assignement -> unit)
+
+(* Given a computation that is_exn, replace it by another one *)
+val replace : 'a computation -> 'a computation -> unit
+
+(* Inspect a computation *)
+val is_over : 'a computation -> bool
+val is_val : 'a computation -> bool
+val is_exn : 'a computation -> bool
+val peek_val : 'a computation -> 'a option
+val uuid : 'a computation -> UUID.t
+
+(* [chain greedy pure c f] chains computation [c] with [f].
+ * The [greedy] and [pure] parameters are tricky:
+ * [pure]:
+ *   When pure is true, the returned computation will not keep a copy
+ *   of the global state.
+ *   [let c' = chain ~pure:true c f in let c'' = chain ~pure:false c' g in]
+ *   is invalid.  It works if one forces [c''] since the whole computation
+ *   will be executed in one go.  It will not work, and raise an anomaly, if
+ *   one forces c' and then c''.
+ *   [join c; chain ~pure:false c g] is invalid and fails at runtime.
+ *   [force c; chain ~pure:false c g] is correct.
+ * [greedy]:
+ *   The [greedy] parameter forces immediately the new computation if
+ *   the old one is_over (Exn or Val). Defaults to true. *)
+val chain : ?greedy:bool -> pure:bool ->
+  'a computation -> ('a -> 'b) -> 'b computation
+
+(* Forcing a computation *)
+val force : 'a computation -> 'a
+val compute : 'a computation -> 'a value
+
+(* Final call, no more *inpure* chain allowed since the state is lost.
+ * Also the fix_exn function is lost, hence error reporting can be incomplete
+ * in a computation obtained by chaining on a joined future. *)
+val join : 'a computation -> 'a
+
+(* Call this before stocking the future.  If it is_val then it is joined *)
+val sink : 'a computation -> unit
+
+(*** Utility functions ************************************************* ***)
+val split2 : ?greedy:bool ->
+  ('a * 'b) computation -> 'a computation * 'b computation
+val map2 : ?greedy:bool ->
+  ('a computation -> 'b -> 'c) ->
+     'a list computation -> 'b list -> 'c list
+
+(* Once set_freeze is called we can purify a computation *)
+val purify : ('a -> 'b) -> 'a -> 'b
+(* And also let a function alter the state but backtrack if it raises exn *)
+val transactify : ('a -> 'b) -> 'a -> 'b
+
+(** Debug: print a computation given an inner printing function. *)
+val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds
+
+(* These functions are needed to get rid of side effects.
+   Thy are set for the outermos layer of the system, since they have to
+   deal with the whole system state. *)
+val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit
diff --git a/lib/genarg.ml b/lib/genarg.ml
new file mode 100644
index 00000000..42458ecb
--- /dev/null
+++ b/lib/genarg.ml
@@ -0,0 +1,235 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Util
+
+type argument_type =
+  (* Basic types *)
+  | IntOrVarArgType
+  | IdentArgType
+  | VarArgType
+  (* Specific types *)
+  | GenArgType
+  | ConstrArgType
+  | ConstrMayEvalArgType
+  | QuantHypArgType
+  | OpenConstrArgType
+  | ConstrWithBindingsArgType
+  | BindingsArgType
+  | RedExprArgType
+  | ListArgType of argument_type
+  | OptArgType of argument_type
+  | PairArgType of argument_type * argument_type
+  | ExtraArgType of string
+
+let rec argument_type_eq arg1 arg2 = match arg1, arg2 with
+| IntOrVarArgType, IntOrVarArgType -> true
+| IdentArgType, IdentArgType -> true
+| VarArgType, VarArgType -> true
+| GenArgType, GenArgType -> true
+| ConstrArgType, ConstrArgType -> true
+| ConstrMayEvalArgType, ConstrMayEvalArgType -> true
+| QuantHypArgType, QuantHypArgType -> true
+| OpenConstrArgType, OpenConstrArgType -> true
+| ConstrWithBindingsArgType, ConstrWithBindingsArgType -> true
+| BindingsArgType, BindingsArgType -> true
+| RedExprArgType, RedExprArgType -> true
+| ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2
+| OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2
+| PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) ->
+  argument_type_eq arg1l arg2l && argument_type_eq arg1r arg2r
+| ExtraArgType s1, ExtraArgType s2 -> CString.equal s1 s2
+| _ -> false
+
+let rec pr_argument_type = function
+| IntOrVarArgType -> str "int_or_var"
+| IdentArgType -> str "ident"
+| VarArgType -> str "var"
+| GenArgType -> str "genarg"
+| ConstrArgType -> str "constr"
+| ConstrMayEvalArgType -> str "constr_may_eval"
+| QuantHypArgType -> str "qhyp"
+| OpenConstrArgType -> str "open_constr"
+| ConstrWithBindingsArgType -> str "constr_with_bindings"
+| BindingsArgType -> str "bindings"
+| RedExprArgType -> str "redexp"
+| ListArgType t -> pr_argument_type t ++ spc () ++ str "list"
+| OptArgType t -> pr_argument_type t ++ spc () ++ str "opt"
+| PairArgType (t1, t2) ->
+    str "("++ pr_argument_type t1 ++ spc () ++
+    str "*" ++ spc () ++ pr_argument_type t2 ++ str ")"
+| ExtraArgType s -> str s
+
+type ('raw, 'glob, 'top) genarg_type = argument_type
+
+type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type
+(** Alias for concision *)
+
+(* Dynamics but tagged by a type expression *)
+
+type rlevel
+type glevel
+type tlevel
+
+type 'a generic_argument = argument_type * Obj.t
+type raw_generic_argument = rlevel generic_argument
+type glob_generic_argument = glevel generic_argument
+type typed_generic_argument = tlevel generic_argument
+
+let rawwit t = t
+let glbwit t = t
+let topwit t = t
+
+let wit_list t = ListArgType t
+
+let wit_opt t = OptArgType t
+
+let wit_pair t1 t2 = PairArgType (t1,t2)
+
+let in_gen t o = (t,Obj.repr o)
+let out_gen t (t',o) = if argument_type_eq t t' then Obj.magic o else failwith "out_gen"
+let genarg_tag (s,_) = s
+
+let has_type (t, v) u = argument_type_eq t u
+
+let unquote x = x
+
+type ('a,'b) abstract_argument_type = argument_type
+type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type
+type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type
+type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type
+
+type ('a, 'b, 'c, 'l) cast = Obj.t
+
+let raw = Obj.obj
+let glb = Obj.obj
+let top = Obj.obj
+
+type ('r, 'l) unpacker =
+  { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r }
+
+let unpack pack (t, obj) = pack.unpacker t (Obj.obj obj)
+
+(** Type transformers *)
+
+type ('r, 'l) list_unpacker =
+  { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a list, 'b list, 'c list, 'l) cast -> 'r }
+
+let list_unpack pack (t, obj) = match t with
+| ListArgType t -> pack.list_unpacker t (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+type ('r, 'l) opt_unpacker =
+  { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a option, 'b option, 'c option, 'l) cast -> 'r }
+
+let opt_unpack pack (t, obj) = match t with
+| OptArgType t -> pack.opt_unpacker t (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+type ('r, 'l) pair_unpacker =
+  { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2.
+    ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+    (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r }
+
+let pair_unpack pack (t, obj) = match t with
+| PairArgType (t1, t2) -> pack.pair_unpacker t1 t2 (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+(** Creating args *)
+
+let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty
+
+let create_arg opt name =
+  if String.Map.mem name !arg0_map then
+    Errors.anomaly (str "generic argument already declared: " ++ str name)
+  else
+    let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in
+    ExtraArgType name
+
+let make0 = create_arg
+
+let default_empty_value t =
+  let rec aux = function
+  | ListArgType _ -> Some (Obj.repr [])
+  | OptArgType _ -> Some (Obj.repr None)
+  | PairArgType(t1, t2) ->
+      (match aux t1, aux t2 with
+      | Some v1, Some v2 -> Some (Obj.repr (v1, v2))
+      | _ -> None)
+  | ExtraArgType s ->
+    String.Map.find s !arg0_map
+  | _ -> None in
+  match aux t with
+  | Some v -> Some (Obj.obj v)
+  | None -> None
+
+(** Registering genarg-manipulating functions *)
+
+module type GenObj =
+sig
+  type ('raw, 'glb, 'top) obj
+  val name : string
+  val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
+end
+
+module Register (M : GenObj) =
+struct
+  let arg0_map =
+    ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t)
+
+  let register0 arg f = match arg with
+  | ExtraArgType s ->
+    if String.Map.mem s !arg0_map then
+      let msg = str M.name ++ str " function already registered: " ++ str s in
+      Errors.anomaly msg
+    else
+      arg0_map := String.Map.add s (Obj.magic f) !arg0_map
+  | _ -> assert false
+
+  let get_obj0 name =
+    try String.Map.find name !arg0_map
+    with Not_found ->
+      match M.default (ExtraArgType name) with
+      | None ->
+        Errors.anomaly (str M.name ++ str " function not found: " ++ str name)
+      | Some obj -> obj
+
+  (** For now, the following function is quite dummy and should only be applied
+      to an extra argument type, otherwise, it will badly fail. *)
+  let obj t = match t with
+  | ExtraArgType s -> Obj.magic (get_obj0 s)
+  | _ -> assert false
+
+end
+
+(** Hackish part *)
+
+let arg0_names = ref (String.Map.empty : string String.Map.t)
+(** We use this table to associate a name to a given witness, to use it with
+    the extension mechanism. This is REALLY ad-hoc, but I do not know how to
+    do so nicely either. *)
+
+let register_name0 t name = match t with
+| ExtraArgType s ->
+  let () = assert (not (String.Map.mem s !arg0_names)) in
+  arg0_names := String.Map.add s name !arg0_names
+| _ -> failwith "register_name0"
+
+let get_name0 name =
+  String.Map.find name !arg0_names
+
+module Unsafe =
+struct
+
+let inj tpe x = (tpe, x)
+let prj (_, x) = x
+
+end
diff --git a/lib/genarg.mli b/lib/genarg.mli
new file mode 100644
index 00000000..a269f927
--- /dev/null
+++ b/lib/genarg.mli
@@ -0,0 +1,278 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** The route of a generic argument, from parsing to evaluation.
+In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
+
+{% \begin{%}verbatim{% }%}
+             parsing          in_raw                            out_raw
+   char stream ---> raw_object ---> raw_object generic_argument -------+
+                          encapsulation                          decaps|
+                                                                       |
+                                                                       V
+                                                                   raw_object
+                                                                       |
+                                                         globalization |
+                                                                       V
+                                                                   glob_object
+                                                                       |
+                                                                encaps |
+                                                               in_glob |
+                                                                       V
+                                                           glob_object generic_argument
+                                                                       |
+          out                          in                     out_glob |
+  object <--- object generic_argument <--- object <--- glob_object <---+
+    |   decaps                       encaps      interp           decaps
+    |
+    V
+effective use
+{% \end{%}verbatim{% }%}
+
+To distinguish between the uninterpreted (raw), globalized and
+interpreted worlds, we annotate the type [generic_argument] by a
+phantom argument which is either [constr_expr], [glob_constr] or
+[constr].
+
+Transformation for each type :
+{% \begin{%}verbatim{% }%}
+tag                            raw open type            cooked closed type
+
+BoolArgType                    bool                      bool
+IntArgType                     int                       int
+IntOrVarArgType                int or_var                int
+StringArgType                  string (parsed w/ "")     string
+PreIdentArgType                string (parsed w/o "")    (vernac only)
+IdentArgType true              identifier                identifier
+IdentArgType false             identifier (pattern_ident) identifier
+IntroPatternArgType            intro_pattern_expr        intro_pattern_expr
+VarArgType                     identifier located        identifier
+RefArgType                     reference                 global_reference
+QuantHypArgType                quantified_hypothesis     quantified_hypothesis
+ConstrArgType                  constr_expr               constr
+ConstrMayEvalArgType           constr_expr may_eval      constr
+OpenConstrArgType              open_constr_expr          open_constr
+ConstrWithBindingsArgType      constr_expr with_bindings constr with_bindings
+BindingsArgType                constr_expr bindings      constr bindings
+List0ArgType of argument_type
+List1ArgType of argument_type
+OptArgType of argument_type
+ExtraArgType of string         '_a                      '_b
+{% \end{%}verbatim{% }%}
+*)
+
+(** {5 Generic types} *)
+
+type ('raw, 'glob, 'top) genarg_type
+(** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized
+    one, and ['top] the internalized one. *)
+
+type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type
+(** Alias for concision when the three types agree. *)
+
+val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type
+(** Create a new generic type of argument: force to associate
+    unique ML types at each of the three levels. *)
+
+val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type
+(** Alias for [make0]. *)
+
+(** {5 Specialized types} *)
+
+(** All of [rlevel], [glevel] and [tlevel] must be non convertible
+   to ensure the injectivity of the type inference from type
+   ['co generic_argument] to [('a,'co) abstract_argument_type];
+   this guarantees that, for 'co fixed, the type of
+   out_gen is monomorphic over 'a, hence type-safe
+*)
+
+type rlevel
+type glevel
+type tlevel
+
+type ('a, 'co) abstract_argument_type
+(** Type at level ['co] represented by an OCaml value of type ['a]. *)
+
+type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type
+(** Specialized type at raw level. *)
+
+type 'a glob_abstract_argument_type = ('a, glevel) abstract_argument_type
+(** Specialized type at globalized level. *)
+
+type 'a typed_abstract_argument_type = ('a, tlevel) abstract_argument_type
+(** Specialized type at internalized level. *)
+
+(** {6 Projections} *)
+
+val rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type
+(** Projection on the raw type constructor. *)
+
+val glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type
+(** Projection on the globalized type constructor. *)
+
+val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type
+(** Projection on the internalized type constructor. *)
+
+(** {5 Generic arguments} *)
+
+type 'a generic_argument
+(** A inhabitant of ['level generic_argument] is a inhabitant of some type at
+    level ['level], together with the representation of this type. *)
+
+type raw_generic_argument = rlevel generic_argument
+type glob_generic_argument = glevel generic_argument
+type typed_generic_argument = tlevel generic_argument
+
+(** {6 Constructors} *)
+
+val in_gen : ('a, 'co) abstract_argument_type -> 'a -> 'co generic_argument
+(** [in_gen t x] embeds an argument of type [t] into a generic argument. *)
+
+val out_gen : ('a, 'co) abstract_argument_type -> 'co generic_argument -> 'a
+(** [out_gen t x] recovers an argument of type [t] from a generic argument. It
+    fails if [x] has not the right dynamic type. *)
+
+val has_type : 'co generic_argument -> ('a, 'co) abstract_argument_type -> bool
+(** [has_type v t] tells whether [v] has type [t]. If true, it ensures that
+    [out_gen t v] will not raise a dynamic type exception. *)
+
+(** {6 Destructors} *)
+
+type ('a, 'b, 'c, 'l) cast
+
+val raw : ('a, 'b, 'c, rlevel) cast -> 'a
+val glb : ('a, 'b, 'c, glevel) cast -> 'b
+val top : ('a, 'b, 'c, tlevel) cast -> 'c
+
+type ('r, 'l) unpacker =
+  { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r }
+
+val unpack : ('r, 'l) unpacker -> 'l generic_argument -> 'r
+(** Existential-type destructors. *)
+
+(** {6 Manipulation of generic arguments}
+
+Those functions fail if they are applied to an argument which has not the right
+dynamic type. *)
+
+type ('r, 'l) list_unpacker =
+  { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a list, 'b list, 'c list, 'l) cast -> 'r }
+
+val list_unpack : ('r, 'l) list_unpacker -> 'l generic_argument -> 'r
+
+type ('r, 'l) opt_unpacker =
+  { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a option, 'b option, 'c option, 'l) cast -> 'r }
+
+val opt_unpack : ('r, 'l) opt_unpacker -> 'l generic_argument -> 'r
+
+type ('r, 'l) pair_unpacker =
+  { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2.
+    ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+    (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r }
+
+val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r
+
+(** {6 Type reification} *)
+
+type argument_type =
+  (** Basic types *)
+  | IntOrVarArgType
+  | IdentArgType
+  | VarArgType
+  (** Specific types *)
+  | GenArgType
+  | ConstrArgType
+  | ConstrMayEvalArgType
+  | QuantHypArgType
+  | OpenConstrArgType
+  | ConstrWithBindingsArgType
+  | BindingsArgType
+  | RedExprArgType
+  | ListArgType of argument_type
+  | OptArgType of argument_type
+  | PairArgType of argument_type * argument_type
+  | ExtraArgType of string
+
+val argument_type_eq : argument_type -> argument_type -> bool
+
+val pr_argument_type : argument_type -> Pp.std_ppcmds
+(** Print a human-readable representation for a given type. *)
+
+val genarg_tag : 'a generic_argument -> argument_type
+
+val unquote : ('a, 'co) abstract_argument_type -> argument_type
+
+(** {6 Registering genarg-manipulating functions}
+
+  This is boilerplate code used here and there in the code of Coq. *)
+
+module type GenObj =
+sig
+  type ('raw, 'glb, 'top) obj
+  (** An object manipulating generic arguments. *)
+
+  val name : string
+  (** A name for such kind of manipulation, e.g. [interp]. *)
+
+  val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
+  (** A generic object when there is no registered object for this type. *)
+end
+
+module Register (M : GenObj) :
+sig
+  val register0 : ('raw, 'glb, 'top) genarg_type ->
+    ('raw, 'glb, 'top) M.obj -> unit
+  (** Register a ground type manipulation function. *)
+
+  val obj : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) M.obj
+  (** Recover a manipulation function at a given type. *)
+
+end
+
+(** {5 Basic generic type constructors} *)
+
+(** {6 Parameterized types} *)
+
+val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type
+val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type
+val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+  ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type
+
+(** {5 Magic used by the parser} *)
+
+val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option
+
+val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit
+(** Used by the extension to give a name to types. The string should be the
+    absolute path of the argument witness, e.g.
+    [register_name0 wit_toto "MyArg.wit_toto"]. *)
+
+val get_name0 : string -> string
+(** Return the absolute path of a given witness. *)
+
+(** {5 Unsafe loophole} *)
+
+module Unsafe :
+sig
+
+(** Unsafe magic functions. Not for kids. This is provided here as a loophole to
+    escape this module. Do NOT use outside of the dedicated areas. NOT. EVER. *)
+
+val inj : argument_type -> Obj.t -> 'lev generic_argument
+(** Injects an object as generic argument. !!!BEWARE!!! only do this as
+    [inj tpe x] where:
+
+    1. [tpe] is the reification of a [('a, 'b, 'c) genarg_type];
+    2. [x] has type ['a], ['b] or ['c] according to the return level ['lev]. *)
+
+val prj : 'lev generic_argument -> Obj.t
+(** Recover the contents of a generic argument. *)
+
+end
diff --git a/lib/gmap.ml b/lib/gmap.ml
deleted file mode 100644
index e1c68da0..00000000
--- a/lib/gmap.ml
+++ /dev/null
@@ -1,140 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Maps using the generic comparison function of ocaml. Code borrowed from
-   the ocaml standard library (Copyright 1996, INRIA). *)
-
-    type ('a,'b) t =
-        Empty
-      | Node of ('a,'b) t * 'a * 'b * ('a,'b) t * int
-
-    let empty = Empty
-
-    let is_empty = function Empty -> true | _ -> false
-
-    let height = function
-        Empty -> 0
-      | Node(_,_,_,_,h) -> h
-
-    let create l x d r =
-      let hl = height l and hr = height r in
-      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let bal l x d r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      if hl > hr + 2 then begin
-        match l with
-          Empty -> invalid_arg "Map.bal"
-        | Node(ll, lv, ld, lr, _) ->
-            if height ll >= height lr then
-              create ll lv ld (create lr x d r)
-            else begin
-              match lr with
-                Empty -> invalid_arg "Map.bal"
-              | Node(lrl, lrv, lrd, lrr, _)->
-                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
-            end
-      end else if hr > hl + 2 then begin
-        match r with
-          Empty -> invalid_arg "Map.bal"
-        | Node(rl, rv, rd, rr, _) ->
-            if height rr >= height rl then
-              create (create l x d rl) rv rd rr
-            else begin
-              match rl with
-                Empty -> invalid_arg "Map.bal"
-              | Node(rll, rlv, rld, rlr, _) ->
-                  create (create l x d rll) rlv rld (create rlr rv rd rr)
-            end
-      end else
-        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let rec add x data = function
-        Empty ->
-          Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) ->
-          let c = Pervasives.compare x v in
-          if c = 0 then
-            Node(l, x, data, r, h)
-          else if c < 0 then
-            bal (add x data l) v d r
-          else
-            bal l v d (add x data r)
-
-    let rec find x = function
-        Empty ->
-          raise Not_found
-      | Node(l, v, d, r, _) ->
-          let c = Pervasives.compare x v in
-          if c = 0 then d
-          else find x (if c < 0 then l else r)
-
-    let rec mem x = function
-        Empty ->
-          false
-      | Node(l, v, d, r, _) ->
-          let c = Pervasives.compare x v in
-          c = 0 || mem x (if c < 0 then l else r)
-
-    let rec min_binding = function
-        Empty -> raise Not_found
-      | Node(Empty, x, d, r, _) -> (x, d)
-      | Node(l, x, d, r, _) -> min_binding l
-
-    let rec remove_min_binding = function
-        Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, x, d, r, _) -> r
-      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
-    let merge t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (_, _) ->
-          let (x, d) = min_binding t2 in
-          bal t1 x d (remove_min_binding t2)
-
-    let rec remove x = function
-        Empty ->
-          Empty
-      | Node(l, v, d, r, h) ->
-          let c = Pervasives.compare x v in
-          if c = 0 then
-            merge l r
-          else if c < 0 then
-            bal (remove x l) v d r
-          else
-            bal l v d (remove x r)
-
-    let rec iter f = function
-        Empty -> ()
-      | Node(l, v, d, r, _) ->
-          iter f l; f v d; iter f r
-
-    let rec map f = function
-        Empty               -> Empty
-      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
-
-    (* Maintien de fold_right par compatibilité (changé en fold_left dans
-       ocaml-3.09.0) *)
-
-    let rec fold f m accu =
-      match m with
-        Empty -> accu
-      | Node(l, v, d, r, _) ->
-          fold f l (f v d (fold f r accu))
-
-(* Added with respect to ocaml standard library. *)
-
-    let dom m = fold (fun x _ acc -> x::acc) m []
-
-    let rng m = fold (fun _ y acc -> y::acc) m []
-
-    let to_list m = fold (fun x y acc -> (x,y)::acc) m []
-
diff --git a/lib/gmap.mli b/lib/gmap.mli
deleted file mode 100644
index c2fb7d26..00000000
--- a/lib/gmap.mli
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Maps using the generic comparison function of ocaml. Same interface as
-   the module [Map] from the ocaml standard library. *)
-
-type ('a,'b) t
-
-val empty : ('a,'b) t
-val is_empty : ('a,'b) t -> bool
-val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
-val find : 'a -> ('a,'b) t -> 'b
-val remove : 'a -> ('a,'b) t -> ('a,'b) t
-val mem :  'a -> ('a,'b) t -> bool
-val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit
-val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
-val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
-
-(** Additions with respect to ocaml standard library. *)
-
-val dom : ('a,'b) t -> 'a list
-val rng : ('a,'b) t -> 'b list
-val to_list : ('a,'b) t -> ('a * 'b) list
diff --git a/lib/hMap.ml b/lib/hMap.ml
new file mode 100644
index 00000000..f902eded
--- /dev/null
+++ b/lib/hMap.ml
@@ -0,0 +1,332 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type HashedType =
+sig
+  type t
+  val compare : t -> t -> int
+  val hash : t -> int
+end
+
+module SetMake(M : HashedType) =
+struct
+  (** Hash Sets use hashes to prevent doing too many comparison tests. They
+      associate to each hash the set of keys having that hash.
+
+      Invariants:
+
+      1. There is no empty set in the intmap.
+      2. All values in the same set have the same hash, which is the int to
+         which it is associated in the intmap.
+  *)
+
+  module Set = Set.Make(M)
+
+  type elt = M.t
+
+  type t = Set.t Int.Map.t
+
+  let empty = Int.Map.empty
+
+  let is_empty = Int.Map.is_empty
+
+  let mem x s =
+    let h = M.hash x in
+    try
+      let m = Int.Map.find h s in
+      Set.mem x m
+    with Not_found -> false
+
+  let add x s =
+    let h = M.hash x in
+    try
+      let m = Int.Map.find h s in
+      let m = Set.add x m in
+      Int.Map.update h m s
+    with Not_found ->
+      let m = Set.singleton x in
+      Int.Map.add h m s
+
+  let singleton x =
+    let h = M.hash x in
+    let m = Set.singleton x in
+    Int.Map.singleton h m
+
+  let remove x s =
+    let h = M.hash x in
+    try
+      let m = Int.Map.find h s in
+      let m = Set.remove x m in
+      if Set.is_empty m then
+        Int.Map.remove h s
+      else
+        Int.Map.update h m s
+    with Not_found -> s
+
+  let union s1 s2 =
+    let fu _ m1 m2 = match m1, m2 with
+    | None, None -> None
+    | (Some _ as m), None | None, (Some _ as m) -> m
+    | Some m1, Some m2 -> Some (Set.union m1 m2)
+    in
+    Int.Map.merge fu s1 s2
+
+  let inter s1 s2 =
+    let fu _ m1 m2 = match m1, m2 with
+    | None, None -> None
+    | Some _, None | None, Some _ -> None
+    | Some m1, Some m2 ->
+      let m = Set.inter m1 m2 in
+      if Set.is_empty m then None else Some m
+    in
+    Int.Map.merge fu s1 s2
+
+  let diff s1 s2 =
+    let fu _ m1 m2 = match m1, m2 with
+    | None, None -> None
+    | (Some _ as m), None -> m
+    | None, Some _ -> None
+    | Some m1, Some m2 ->
+      let m = Set.diff m1 m2 in
+      if Set.is_empty m then None else Some m
+    in
+    Int.Map.merge fu s1 s2
+
+  let compare s1 s2 = Int.Map.compare Set.compare s1 s2
+
+  let equal s1 s2 = Int.Map.equal Set.equal s1 s2
+
+  let subset s1 s2 =
+    let check h m1 =
+      let m2 = try Int.Map.find h s2 with Not_found -> Set.empty in
+      Set.subset m1 m2
+    in
+    Int.Map.for_all check s1
+
+  let iter f s =
+    let fi _ m = Set.iter f m in
+    Int.Map.iter fi s
+
+  let fold f s accu =
+    let ff _ m accu = Set.fold f m accu in
+    Int.Map.fold ff s accu
+
+  let for_all f s =
+    let ff _ m = Set.for_all f m in
+    Int.Map.for_all ff s
+
+  let exists f s =
+    let fe _ m = Set.exists f m in
+    Int.Map.exists fe s
+
+  let filter f s =
+    let ff m = Set.filter f m in
+    let s = Int.Map.map ff s in
+    Int.Map.filter (fun _ m -> not (Set.is_empty m)) s
+
+  let partition f s =
+    let fold h m (sl, sr) =
+      let (ml, mr) = Set.partition f m in
+      let sl = if Set.is_empty ml then sl else Int.Map.add h ml sl in
+      let sr = if Set.is_empty mr then sr else Int.Map.add h mr sr in
+      (sl, sr)
+    in
+    Int.Map.fold fold s (Int.Map.empty, Int.Map.empty)
+
+  let cardinal s =
+    let fold _ m accu = accu + Set.cardinal m in
+    Int.Map.fold fold s 0
+
+  let elements s =
+    let fold _ m accu = Set.fold (fun x accu -> x :: accu) m accu in
+    Int.Map.fold fold s []
+
+  let min_elt _ = assert false (** Cannot be implemented efficiently *)
+
+  let max_elt _ = assert false (** Cannot be implemented efficiently *)
+
+  let choose s =
+    let (_, m) = Int.Map.choose s in
+    Set.choose m
+
+  let split s x = assert false (** Cannot be implemented efficiently *)
+
+end
+
+module Make(M : HashedType) =
+struct
+  (** This module is essentially the same as SetMake, except that we have maps
+      instead of sets in the intmap. Invariants are the same. *)
+  module Set = SetMake(M)
+  module Map = CMap.Make(M)
+
+  type key = M.t
+
+  type 'a t = 'a Map.t Int.Map.t
+
+  let empty = Int.Map.empty
+
+  let is_empty = Int.Map.is_empty
+
+  let mem k s =
+    let h = M.hash k in
+    try
+      let m = Int.Map.find h s in
+      Map.mem k m
+    with Not_found -> false
+
+  let add k x s =
+    let h = M.hash k in
+    try
+      let m = Int.Map.find h s in
+      let m = Map.add k x m in
+      Int.Map.update h m s
+    with Not_found ->
+      let m = Map.singleton k x in
+      Int.Map.add h m s
+
+  let singleton k x =
+    let h = M.hash k in
+    Int.Map.singleton h (Map.singleton k x)
+
+  let remove k s =
+    let h = M.hash k in
+    try
+      let m = Int.Map.find h s in
+      let m = Map.remove k m in
+      if Map.is_empty m then
+        Int.Map.remove h s
+      else
+        Int.Map.update h m s
+    with Not_found -> s
+
+  let merge f s1 s2 =
+    let fm h m1 m2 = match m1, m2 with
+    | None, None -> None
+    | Some m, None ->
+      let m = Map.merge f m Map.empty in
+      if Map.is_empty m then None
+      else Some m
+    | None, Some m ->
+      let m = Map.merge f Map.empty m in
+      if Map.is_empty m then None
+      else Some m
+    | Some m1, Some m2 ->
+      let m = Map.merge f m1 m2 in
+      if Map.is_empty m then None
+      else Some m
+    in
+    Int.Map.merge fm s1 s2
+
+  let compare f s1 s2 =
+    let fc m1 m2 = Map.compare f m1 m2 in
+    Int.Map.compare fc s1 s2
+
+  let equal f s1 s2 =
+    let fe m1 m2 = Map.equal f m1 m2 in
+    Int.Map.equal fe s1 s2
+
+  let iter f s =
+    let fi _ m = Map.iter f m in
+    Int.Map.iter fi s
+
+  let fold f s accu =
+    let ff _ m accu = Map.fold f m accu in
+    Int.Map.fold ff s accu
+
+  let for_all f s =
+    let ff _ m = Map.for_all f m in
+    Int.Map.for_all ff s
+
+  let exists f s =
+    let fe _ m = Map.exists f m in
+    Int.Map.exists fe s
+
+  let filter f s =
+    let ff m = Map.filter f m in
+    let s = Int.Map.map ff s in
+    Int.Map.filter (fun _ m -> not (Map.is_empty m)) s
+
+  let partition f s =
+    let fold h m (sl, sr) =
+      let (ml, mr) = Map.partition f m in
+      let sl = if Map.is_empty ml then sl else Int.Map.add h ml sl in
+      let sr = if Map.is_empty mr then sr else Int.Map.add h mr sr in
+      (sl, sr)
+    in
+    Int.Map.fold fold s (Int.Map.empty, Int.Map.empty)
+
+  let cardinal s =
+    let fold _ m accu = accu + Map.cardinal m in
+    Int.Map.fold fold s 0
+
+  let bindings s =
+    let fold _ m accu = Map.fold (fun k x accu -> (k, x) :: accu) m accu in
+    Int.Map.fold fold s []
+
+  let min_binding _ = assert false (** Cannot be implemented efficiently *)
+
+  let max_binding _ = assert false (** Cannot be implemented efficiently *)
+
+  let fold_left _ _ _ = assert false (** Cannot be implemented efficiently *)
+
+  let fold_right _ _ _ = assert false (** Cannot be implemented efficiently *)
+
+  let choose s =
+    let (_, m) = Int.Map.choose s in
+    Map.choose m
+
+  let find k s =
+    let h = M.hash k in
+    let m = Int.Map.find h s in
+    Map.find k m
+
+  let split k s = assert false (** Cannot be implemented efficiently *)
+
+  let map f s =
+    let fs m = Map.map f m in
+    Int.Map.map fs s
+
+  let mapi f s =
+    let fs m = Map.mapi f m in
+    Int.Map.map fs s
+
+  let modify k f s =
+    let h = M.hash k in
+    let m = Int.Map.find h s in
+    let m = Map.modify k f m in
+    Int.Map.update h m s
+
+  let bind f s =
+    let fb m = Map.bind f m in
+    Int.Map.map fb s
+
+  let domain s = Int.Map.map Map.domain s
+
+  let update k x s =
+    let h = M.hash k in
+    let m = Int.Map.find h s in
+    let m = Map.update k x m in
+    Int.Map.update h m s
+
+  let smartmap f s =
+    let fs m = Map.smartmap f m in
+    Int.Map.smartmap fs s
+
+  let smartmapi f s =
+    let fs m = Map.smartmapi f m in
+    Int.Map.smartmap fs s
+
+  module Unsafe =
+  struct
+    let map f s =
+      let fs m = Map.Unsafe.map f m in
+      Int.Map.map fs s
+  end
+
+end
diff --git a/lib/hMap.mli b/lib/hMap.mli
new file mode 100644
index 00000000..cdf933b2
--- /dev/null
+++ b/lib/hMap.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type HashedType =
+sig
+  type t
+  val compare : t -> t -> int
+  (** Total ordering *)
+  val hash : t -> int
+  (** Hashing function compatible with [compare], i.e. [compare x y = 0] implies
+      [hash x = hash y]. *)
+end
+
+(** Hash maps are maps that take advantage of having a hash on keys. This is
+    essentially a hash table, except that it uses purely functional maps instead
+    of arrays.
+
+    CAVEAT: order-related functions like [fold] or [iter] do not respect the
+    provided order anymore! It's your duty to do something sensible to prevent
+    this if you need it. In particular, [min_binding] and [max_binding] are now
+    made meaningless.
+*)
+module Make(M : HashedType) : CMap.ExtS with type key = M.t
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index d310713e..752e2634 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,42 +13,39 @@
 (* [t] is the type of object to hash-cons
  * [u] is the type of hash-cons functions for the sub-structures
  *   of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...).
- * [hash_sub u x] is a function that hash-cons the sub-structures of x using
+ * [hashcons u x] is a function that hash-cons the sub-structures of x using
  *   the hash-consing functions u provides.
  * [equal] is a comparison function. It is allowed to use physical equality
- *   on the sub-terms hash-consed by the hash_sub function.
+ *   on the sub-terms hash-consed by the hashcons function.
  * [hash] is the hash function given to the Hashtbl.Make function
  *
  * Note that this module type coerces to the argument of Hashtbl.Make.
  *)
 
-module type Comp =
+module type HashconsedType =
   sig
     type t
     type u
-    val hash_sub :  u -> t -> t
+    val hashcons :  u -> t -> t
     val equal : t -> t -> bool
     val hash : t -> int
   end
 
-(* The output is a function f such that
- * [f ()] has the side-effect of creating (internally) a hash-table of the
- *   hash-consed objects. The result is a function taking the sub-hashcons
- *   functions and an object, and hashcons it. It does not really make sense
- *   to call f() with different sub-hcons functions. That's why we use the
- *   wrappers simple_hcons, recursive_hcons, ... The latter just take as
- *   argument the sub-hcons functions (the tables are created at that moment),
- *   and returns the hcons function for t.
- *)
+(** The output is a function [generate] such that [generate args] creates a
+    hash-table of the hash-consed objects, together with [hcons], a function
+    taking a table and an object, and hashcons it. For simplicity of use, we use
+    the wrapper functions defined below. *)
 
 module type S =
   sig
     type t
     type u
-    val f : unit -> (u -> t -> t)
+    type table
+    val generate : u -> table
+    val hcons : table -> t -> t
   end
 
-module Make(X:Comp) =
+module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) =
   struct
     type t = X.t
     type u = X.u
@@ -58,34 +55,29 @@ module Make(X:Comp) =
      * w.r.t (=), although the equality on keys is X.equal. This is
      * granted since we hcons the subterms before looking up in the table.
      *)
-    module Htbl = Hashtbl.Make(
-      struct type t=X.t
-             type u=X.u
-             let hash=X.hash
-             let equal x1 x2 = (*incr comparaison;*) X.equal x1 x2
-      end)
-
-    (* The table is created when () is applied.
-     * Hashconsing is then very simple:
-     *  1- hashcons the subterms using hash_sub and u
-     *  2- look up in the table, if we do not get a hit, we add it
-     *)
-    let f () =
+    module Htbl = Hashset.Make(X)
+
+    type table = (Htbl.t * u)
+
+    let generate u =
       let tab = Htbl.create 97 in
-        (fun u x ->
-           let y = X.hash_sub u x in
-            (* incr acces;*)
-             try let r = Htbl.find tab y in(* incr succes;*) r
-             with Not_found -> Htbl.add tab y y; y)
+      (tab, u)
+
+    let hcons (tab, u) x =
+      let y = X.hashcons u x in
+      Htbl.repr (X.hash y) y tab
+
   end
 
 (* A few usefull wrappers:
- * takes as argument the function f above and build a function of type
+ * takes as argument the function [generate] above and build a function of type
  * u -> t -> t that creates a fresh table each time it is applied to the
  * sub-hcons functions. *)
 
 (* For non-recursive types it is quite easy. *)
-let simple_hcons h u = h () u
+let simple_hcons h f u =
+  let table = h u in
+  fun x -> f table x
 
 (* For a recursive type T, we write the module of sig Comp with u equals
  * to (T -> T) * u0
@@ -93,28 +85,14 @@ let simple_hcons h u = h () u
  * The second one to hashcons the other sub-structures.
  * We just have to take the fixpoint of h
  *)
-let recursive_hcons h u =
-  let hc = h () in
-  let rec hrec x = hc (hrec,u) x in
+let recursive_hcons h f u =
+  let loop = ref (fun _ -> assert false) in
+  let self x = !loop x in
+  let table = h (self, u) in
+  let hrec x = f table x in
+  let () = loop := hrec in
   hrec
 
-(* If the structure may contain loops, use this one. *)
-let recursive_loop_hcons h u =
-  let hc = h () in
-  let rec hrec visited x =
-    if List.memq x visited then x
-    else hc (hrec (x::visited),u) x
-  in
-  hrec []
-
-(* For 2 mutually recursive types *)
-let recursive2_hcons h1 h2 u1 u2 =
-  let hc1 = h1 () in
-  let hc2 = h2 () in
-  let rec hrec1 x = hc1 (hrec1,hrec2,u1) x
-  and hrec2 x = hc2 (hrec1,hrec2,u2) x
-  in (hrec1,hrec2)
-
 (* A set of global hashcons functions *)
 let hashcons_resets = ref []
 let init() = List.iter (fun f -> f()) !hashcons_resets
@@ -132,15 +110,48 @@ let register_hcons h u =
 (* Basic hashcons modules for string and obj. Integers do not need be
    hashconsed.  *)
 
+module type HashedType = sig type t val hash : t -> int end
+
+(* list *)
+module Hlist (D:HashedType) =
+  Make(
+    struct
+      type t = D.t list
+      type u = (t -> t) * (D.t -> D.t)
+      let hashcons (hrec,hdata) = function
+        | x :: l -> hdata x :: hrec l
+        | l -> l
+      let equal l1 l2 =
+        l1 == l2 ||
+          match l1, l2 with
+          | [], [] -> true
+          | x1::l1, x2::l2 -> x1==x2 && l1==l2
+          | _ -> false
+      let rec hash accu = function
+      | [] -> accu
+      | x :: l ->
+        let accu = Hashset.Combine.combine (D.hash x) accu in
+        hash accu l
+      let hash l = hash 0 l
+    end)
+
 (* string *)
 module Hstring = Make(
   struct
     type t = string
     type u = unit
-    let hash_sub () s =(* incr accesstr;*) s
-    let equal s1 s2 =(* incr comparaisonstr;
-      if*) s1=s2(* then (incr successtr; true) else false*)
-    let hash = Hashtbl.hash
+    let hashcons () s =(* incr accesstr;*) s
+    external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+    (** Copy from CString *)
+    let rec hash len s i accu =
+      if i = len then accu
+      else
+        let c = Char.code (String.unsafe_get s i) in
+        hash len s (succ i) (accu * 19 + c)
+
+    let hash s =
+      let len = String.length s in
+      hash len s 0 0
   end)
 
 (* Obj.t *)
@@ -148,10 +159,10 @@ exception NotEq
 
 (* From CAMLLIB/caml/mlvalues.h *)
 let no_scan_tag = 251
-let tuple_p obj = Obj.is_block obj & (Obj.tag obj < no_scan_tag)
+let tuple_p obj = Obj.is_block obj && (Obj.tag obj < no_scan_tag)
 
 let comp_obj o1 o2 =
-  if tuple_p o1 & tuple_p o2 then
+  if tuple_p o1 && tuple_p o2 then
     let n1 = Obj.size o1 and n2 = Obj.size o2 in
       if n1=n2 then
         try
@@ -176,7 +187,7 @@ module Hobj = Make(
   struct
     type t = Obj.t
     type u = (Obj.t -> Obj.t) * unit
-    let hash_sub (hrec,_) = hash_obj hrec
+    let hashcons (hrec,_) = hash_obj hrec
     let equal = comp_obj
     let hash = Hashtbl.hash
   end)
@@ -186,8 +197,8 @@ module Hobj = Make(
  *)
 (* string : string -> string *)
 (* obj : Obj.t -> Obj.t *)
-let string = register_hcons (simple_hcons Hstring.f) ()
-let obj = register_hcons (recursive_hcons Hobj.f) ()
+let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) ()
+let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) ()
 
 (* The unsafe polymorphic hashconsing function *)
 let magic_hash (c : 'a) =
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index d2aa6462..60a9ee01 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,43 +8,81 @@
 
 (** Generic hash-consing. *)
 
-module type Comp =
+(** {6 Hashconsing functorial interface} *)
+
+module type HashconsedType =
   sig
+    (** {6 Generic hashconsing signature}
+
+        Given an equivalence relation [equal], a hashconsing function is a
+        function that associates the same canonical element to two elements
+        related by [equal]. Usually, the element chosen is canonical w.r.t.
+        physical equality [(==)], so as to reduce memory consumption and
+        enhance efficiency of equality tests.
+
+        In order to ensure canonicality, we need a way to remember the element
+        associated to a class of equivalence; this is done using the table type
+        generated by the [Make] functor.
+    *)
+
     type t
+    (** Type of objects to hashcons. *)
     type u
-    val hash_sub :  u -> t -> t
+    (** Type of hashcons functions for the sub-structures contained in [t].
+        Usually a tuple of functions. *)
+    val hashcons :  u -> t -> t
+    (** The actual hashconsing function, using its fist argument to recursively
+        hashcons substructures. It should be compatible with [equal], that is
+        [equal x (hashcons f x) = true]. *)
     val equal : t -> t -> bool
+    (** A comparison function. It is allowed to use physical equality
+        on the sub-terms hashconsed by the [hashcons] function, but it should be
+        insensible to shallow copy of the compared object. *)
     val hash : t -> int
+    (** A hash function passed to the underlying hashtable structure. [hash]
+        should be compatible with [equal], i.e. if [equal x y = true] then
+        [hash x = hash y]. *)
   end
 
 module type S =
   sig
     type t
+    (** Type of objects to hashcons. *)
     type u
-    val f : unit -> (u -> t -> t)
+    (** Type of hashcons functions for the sub-structures contained in [t]. *)
+    type table
+    (** Type of hashconsing tables *)
+    val generate : u -> table
+    (** This create a hashtable of the hashconsed objects. *)
+    val hcons : table -> t -> t
+    (** Perform the hashconsing of the given object within the table. *)
   end
 
-module Make(X:Comp) : (S with type t = X.t and type u = X.u)
+module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u)
+(** Create a new hashconsing, given canonicalization functions. *)
 
-val simple_hcons : (unit -> 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive_hcons : (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive_loop_hcons :
-    (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive2_hcons :
-  (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u1 -> 't1 -> 't1) ->
-    (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u2 -> 't2 -> 't2) ->
-      'u1 -> 'u2 -> ('t1 -> 't1) * ('t2 -> 't2)
+(** {6 Wrappers} *)
 
-(** Declaring and reinitializing global hash-consing functions *)
+(** These are intended to be used together with instances of the [Make]
+    functor. *)
 
-val init : unit -> unit
-val register_hcons : ('u -> 't -> 't) -> ('u -> 't -> 't)
+val simple_hcons : ('u -> 'tab) -> ('tab -> 't -> 't) -> 'u -> 't -> 't
+(** [simple_hcons f sub obj] creates a new table each time it is applied to any
+    sub-hash function [sub]. *)
 
-module Hstring : (S with type t = string and type u = unit)
-module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+val recursive_hcons : (('t -> 't) * 'u -> 'tab) -> ('tab -> 't -> 't) -> ('u -> 't -> 't)
+(** As [simple_hcons] but intended to be used with well-founded data structures. *)
+
+(** {6 Hashconsing of usual structures} *)
 
-val string : string -> string
-val obj : Obj.t -> Obj.t
+module type HashedType = sig type t val hash : t -> int end
 
-val magic_hash : 'a -> 'a
+module Hstring : (S with type t = string and type u = unit)
+(** Hashconsing of strings.  *)
 
+module Hlist (D:HashedType) :
+  (S with type t = D.t list and type u = (D.t list -> D.t list)*(D.t->D.t))
+(** Hashconsing of lists.  *)
+
+module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+(** Hashconsing of OCaml values. *)
diff --git a/lib/hashset.ml b/lib/hashset.ml
new file mode 100644
index 00000000..6bec81c7
--- /dev/null
+++ b/lib/hashset.ml
@@ -0,0 +1,203 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt,
+    OCaml stdlib. *)
+
+(** The following functor is a specialized version of [Weak.Make].
+    Here, the responsibility of computing the hash function is now
+    given to the caller, which makes possible the interleaving of the
+    hash key computation and the hash-consing. *)
+
+module type EqType = sig
+  type t
+  val equal : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  type t
+  val create : int -> t
+  val clear : t -> unit
+  val repr : int -> elt -> t -> elt
+end
+
+module Make (E : EqType) =
+  struct
+
+  type elt = E.t
+
+  let emptybucket = Weak.create 0
+
+  type t = {
+    mutable table : elt Weak.t array;
+    mutable hashes : int array array;
+    mutable limit : int;               (* bucket size limit *)
+    mutable oversize : int;            (* number of oversize buckets *)
+    mutable rover : int;               (* for internal bookkeeping *)
+  }
+
+  let get_index t h = (h land max_int) mod (Array.length t.table)
+
+  let limit = 7
+  let over_limit = 2
+
+  let create sz =
+    let sz = if sz < 7 then 7 else sz in
+    let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
+    {
+      table = Array.make sz emptybucket;
+      hashes = Array.make sz [| |];
+      limit = limit;
+      oversize = 0;
+      rover = 0;
+    }
+
+  let clear t =
+    for i = 0 to Array.length t.table - 1 do
+      t.table.(i) <- emptybucket;
+      t.hashes.(i) <- [| |];
+    done;
+    t.limit <- limit;
+    t.oversize <- 0
+
+  let iter_weak f t =
+    let rec iter_bucket i j b =
+      if i >= Weak.length b then () else
+      match Weak.check b i with
+      | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
+      | false -> iter_bucket (i+1) j b
+    in
+    for i = 0 to pred (Array.length t.table) do
+      iter_bucket 0 i (Array.unsafe_get t.table i)
+    done
+
+  let rec count_bucket i b accu =
+    if i >= Weak.length b then accu else
+    count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0))
+
+  let min x y = if x - y < 0 then x else y
+
+  let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length
+  let prev_sz n = ((n - 3) * 2 + 2) / 3
+
+  let test_shrink_bucket t =
+    let bucket = t.table.(t.rover) in
+    let hbucket = t.hashes.(t.rover) in
+    let len = Weak.length bucket in
+    let prev_len = prev_sz len in
+    let live = count_bucket 0 bucket 0 in
+    if live <= prev_len then begin
+      let rec loop i j =
+        if j >= prev_len then begin
+          if Weak.check bucket i then loop (i + 1) j
+          else if Weak.check bucket j then begin
+            Weak.blit bucket j bucket i 1;
+            hbucket.(i) <- hbucket.(j);
+            loop (i + 1) (j - 1);
+          end else loop i (j - 1);
+        end;
+      in
+      loop 0 (Weak.length bucket - 1);
+      if prev_len = 0 then begin
+        t.table.(t.rover) <- emptybucket;
+        t.hashes.(t.rover) <- [| |];
+      end else begin
+        Obj.truncate (Obj.repr bucket) (prev_len + 1);
+        Obj.truncate (Obj.repr hbucket) prev_len;
+      end;
+      if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+    end;
+    t.rover <- (t.rover + 1) mod (Array.length t.table)
+
+  let rec resize t =
+    let oldlen = Array.length t.table in
+    let newlen = next_sz oldlen in
+    if newlen > oldlen then begin
+      let newt = create newlen in
+      let add_weak ob oh oi =
+        let setter nb ni _ = Weak.blit ob oi nb ni 1 in
+        let h = oh.(oi) in
+        add_aux newt setter None h (get_index newt h);
+      in
+      iter_weak add_weak t;
+      t.table <- newt.table;
+      t.hashes <- newt.hashes;
+      t.limit <- newt.limit;
+      t.oversize <- newt.oversize;
+      t.rover <- t.rover mod Array.length newt.table;
+    end else begin
+      t.limit <- max_int;             (* maximum size already reached *)
+      t.oversize <- 0;
+    end
+
+  and add_aux t setter d h index =
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = Weak.length bucket in
+    let rec loop i =
+      if i >= sz then begin
+        let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+        if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
+        let newbucket = Weak.create newsz in
+        let newhashes = Array.make newsz 0 in
+        Weak.blit bucket 0 newbucket 0 sz;
+        Array.blit hashes 0 newhashes 0 sz;
+        setter newbucket sz d;
+        newhashes.(sz) <- h;
+        t.table.(index) <- newbucket;
+        t.hashes.(index) <- newhashes;
+        if sz <= t.limit && newsz > t.limit then begin
+          t.oversize <- t.oversize + 1;
+          for i = 0 to over_limit do test_shrink_bucket t done;
+        end;
+        if t.oversize > Array.length t.table / over_limit then resize t
+      end else if Weak.check bucket i then begin
+        loop (i + 1)
+      end else begin
+        setter bucket i d;
+        hashes.(i) <- h
+      end
+    in
+    loop 0
+
+  let find_or h t d ifnotfound =
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = Weak.length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound index
+      else if h = hashes.(i) then begin
+        match Weak.get bucket i with
+        | Some v when E.equal v d -> v
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+  let repr h d t =
+    let ifnotfound index = add_aux t Weak.set (Some d) h index; d in
+    find_or h t d ifnotfound
+
+end
+
+module Combine = struct
+    (* These are helper functions to combine the hash keys in a similar
+       way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
+       be prime numbers. There were chosen empirically. Notice that the
+       problem of hashing trees is hard and there are plenty of study on
+       this topic. Therefore, there must be room for improvement here. *)
+    let alpha = 65599
+    let beta  = 7
+    let combine x y     = x * alpha + y
+    let combine3 x y z   = combine x (combine y z)
+    let combine4 x y z t = combine x (combine3 y z t)
+    let combine5 x y z t u = combine x (combine4 y z t u)
+    let combinesmall x y = beta * x + y
+end
diff --git a/lib/hashset.mli b/lib/hashset.mli
new file mode 100644
index 00000000..537f3418
--- /dev/null
+++ b/lib/hashset.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt,
+    OCaml stdlib. *)
+
+(** The following functor is a specialized version of [Weak.Make].
+    Here, the responsibility of computing the hash function is now
+    given to the caller, which makes possible the interleaving of the
+    hash key computation and the hash-consing. *)
+
+module type EqType = sig
+  type t
+  val equal : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  (** Type of hashsets elements. *)
+  type t
+  (** Type of hashsets. *)
+  val create : int -> t
+  (** [create n] creates a fresh hashset with initial size [n]. *)
+  val clear : t -> unit
+  (** Clear the contents of a hashset. *)
+  val repr : int -> elt -> t -> elt
+  (** [repr key constr set] uses [key] to look for [constr]
+      in the hashet [set]. If [constr] is in [set], returns the
+      specific representation that is stored in [set]. Otherwise,
+      [constr] is stored in [set] and will be used as the canonical
+      representation of this value in the future. *)
+end
+
+module Make (E : EqType) : S with type elt = E.t
+
+module Combine : sig
+  val combine : int -> int -> int
+  val combinesmall : int -> int -> int
+  val combine3 : int -> int -> int -> int
+  val combine4 : int -> int -> int -> int -> int
+  val combine5 : int -> int -> int -> int -> int -> int
+end
diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml
deleted file mode 100644
index 14b439ec..00000000
--- a/lib/hashtbl_alt.ml
+++ /dev/null
@@ -1,109 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* The following module is a specialized version of [Hashtbl] that is
-   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
-   with [constr] used both as a key and as an image.  Thus, in each
-   cell of the internal bucketlist, there are two representations of
-   the same value. In this implementation, there is only one.
-
-   Besides, the responsibility of computing the hash function is now
-   given to the caller, which makes possible the interleaving of the
-   hash key computation and the hash-consing. *)
-
-module type Hashtype = sig
-  type t
-  val equals : t -> t -> bool
-end
-
-module type S = sig
-  type elt
-  (* [may_add_and_get key constr] uses [key] to look for [constr]
-     in the hash table [H]. If [constr] is in [H], returns the
-     specific representation that is stored in [H]. Otherwise,
-     [constr] is stored in [H] and will be used as the canonical
-     representation of this value in the future. *)
-  val may_add_and_get : int -> elt -> elt
-end
-
-module Make (E : Hashtype) =
-  struct
-
-    type elt = E.t
-
-    type bucketlist = Empty | Cons of elt * int * bucketlist
-
-    let initial_size = 19991
-    let table_data = ref (Array.make initial_size Empty)
-    let table_size = ref 0
-
-    let resize () =
-      let odata = !table_data in
-      let osize = Array.length odata in
-    let nsize = min (2 * osize + 1) Sys.max_array_length in
-    if nsize <> osize then begin
-      let ndata = Array.create nsize Empty in
-      let rec insert_bucket = function
-	| Empty -> ()
-	| Cons (key, hash, rest) ->
-          let nidx = hash mod nsize in
-          ndata.(nidx) <- Cons (key, hash, ndata.(nidx));
-          insert_bucket rest
-      in
-      for i = 0 to osize - 1 do insert_bucket odata.(i) done;
-      table_data := ndata
-    end
-
-  let add hash key =
-    let odata = !table_data in
-    let osize = Array.length odata in
-    let i = hash mod osize in
-    odata.(i) <- Cons (key, hash, odata.(i));
-    incr table_size;
-    if !table_size > osize lsl 1 then resize ()
-
-  let find_rec hash key bucket =
-    let rec aux = function
-      | Empty ->
-	add hash key; key
-      | Cons (k, h, rest) ->
-	if hash == h && E.equals key k then k else aux rest
-    in
-    aux bucket
-
-  let may_add_and_get hash key =
-    let odata = !table_data in
-    match odata.(hash mod (Array.length odata)) with
-      |	Empty -> add hash key; key
-      | Cons (k1, h1, rest1) ->
-	if hash == h1 && E.equals key k1 then k1 else
-	  match rest1 with
-            | Empty -> add hash key; key
-	    | Cons (k2, h2, rest2) ->
-              if hash == h2 && E.equals key k2 then k2 else
-		match rest2 with
-		  | Empty -> add hash key; key
-		  | Cons (k3, h3, rest3) ->
-		    if hash == h3 && E.equals key k3 then k3
-		    else find_rec hash key rest3
-
-end
-
-module Combine = struct
-    (* These are helper functions to combine the hash keys in a similar
-       way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
-       be prime numbers. There were chosen empirically. Notice that the
-       problem of hashing trees is hard and there are plenty of study on
-       this topic. Therefore, there must be room for improvement here. *)
-    let alpha = 65599
-    let beta  = 7
-    let combine x y     = x * alpha + y
-    let combine3 x y z   = combine x (combine y z)
-    let combine4 x y z t = combine x (combine3 y z t)
-    let combinesmall x y = beta * x + y
-end
diff --git a/lib/hashtbl_alt.mli b/lib/hashtbl_alt.mli
deleted file mode 100644
index f14fd90f..00000000
--- a/lib/hashtbl_alt.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* The following module is a specialized version of [Hashtbl] that is
-   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
-   with [constr] used both as a key and as an image.  Thus, in each
-   cell of the internal bucketlist, there are two representations of
-   the same value. In this implementation, there is only one.
-
-   Besides, the responsibility of computing the hash function is now
-   given to the caller, which makes possible the interleaving of the
-   hash key computation and the hash-consing. *)
-
-module type Hashtype = sig
-  type t
-  val equals : t -> t -> bool
-end
-
-module type S = sig
-  type elt
-  (* [may_add_and_get key constr] uses [key] to look for [constr]
-     in the hash table [H]. If [constr] is in [H], returns the
-     specific representation that is stored in [H]. Otherwise,
-     [constr] is stored in [H] and will be used as the canonical
-     representation of this value in the future. *)
-  val may_add_and_get : int -> elt -> elt
-end
-
-module Make (E : Hashtype) : S with type elt = E.t
-
-module Combine : sig
-  val combine : int -> int -> int
-  val combinesmall : int -> int -> int
-  val combine3 : int -> int -> int -> int
-  val combine4 : int -> int -> int -> int -> int
-end
diff --git a/lib/heap.ml b/lib/heap.ml
index 372cecfc..a19bc0d1 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -51,101 +51,86 @@ exception EmptyHeap
 
 module Functional(X : Ordered) = struct
 
-  (* Heaps are encoded as complete binary trees, i.e., binary trees
-     which are full expect, may be, on the bottom level where it is filled
-     from the left.
-     These trees also enjoy the heap property, namely the value of any node
-     is greater or equal than those of its left and right subtrees.
-
-     There are 4 kinds of complete binary trees, denoted by 4 constructors:
-     [FFF] for a full binary tree (and thus 2 full subtrees);
-     [PPF] for a partial tree with a partial left subtree and a full
-     right subtree;
-     [PFF] for a partial tree with a full left subtree and a full right subtree
-     (but of different heights);
-     and [PFP] for a partial tree with a full left subtree and a partial
-     right subtree. *)
+  (* Heaps are encoded as Braun trees, that are binary trees
+     where size r <= size l <= size r + 1 for each node Node (l, x, r) *)
 
   type t =
-    | Empty
-    | FFF of t * X.t * t (* full    (full,    full) *)
-    | PPF of t * X.t * t (* partial (partial, full) *)
-    | PFF of t * X.t * t (* partial (full,    full) *)
-    | PFP of t * X.t * t (* partial (full,    partial) *)
+    | Leaf
+    | Node of t * X.t * t
 
   type elt = X.t
 
-  let empty = Empty
+  let empty = Leaf
 
-  (* smart constructors for insertion *)
-  let p_f l x r = match l with
-    | Empty | FFF _ -> PFF (l, x, r)
-    | _ -> PPF (l, x, r)
-
-  let pf_ l x = function
-    | Empty | FFF _ as r -> FFF (l, x, r)
-    | r -> PFP (l, x, r)
+  let is_empty t = t = Leaf
 
   let rec add x = function
-    | Empty ->
-	FFF (Empty, x, Empty)
-    (* insertion to the left *)
-    | FFF (l, y, r) | PPF (l, y, r) ->
-	if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r
-    (* insertion to the right *)
-    | PFF (l, y, r) | PFP (l, y, r) ->
-	if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r)
+    | Leaf ->
+        Node (Leaf, x, Leaf)
+    | Node (l, y, r) ->
+        if X.compare x y >= 0 then
+          Node (add y r, x, l)
+        else
+          Node (add x r, y, l)
+
+  let rec extract = function
+    | Leaf ->
+        assert false
+    | Node (Leaf, y, r) ->
+        assert (r = Leaf);
+        y, Leaf
+    | Node (l, y, r) ->
+        let x, l = extract l in
+        x, Node (r, y, l)
+
+  let is_above x = function
+    | Leaf -> true
+    | Node (_, y, _) -> X.compare x y >= 0
+
+  let rec replace_min x = function
+    | Node (l, _, r) when is_above x l && is_above x r ->
+        Node (l, x, r)
+    | Node ((Node (_, lx, _) as l), _, r) when is_above lx r ->
+        (* lx <= x, rx necessarily *)
+        Node (replace_min x l, lx, r)
+    | Node (l, _, (Node (_, rx, _) as r)) ->
+        (* rx <= x, lx necessarily *)
+        Node (l, rx, replace_min x r)
+    | Leaf | Node (Leaf, _, _) | Node (_, _, Leaf) ->
+        assert false
+
+  (* merges two Braun trees [l] and [r],
+     with the assumption that [size r <= size l <= size r + 1] *)
+  let rec merge l r = match l, r with
+    | _, Leaf ->
+        l
+    | Node (ll, lx, lr), Node (_, ly, _) ->
+        if X.compare lx ly >= 0 then
+          Node (r, lx, merge ll lr)
+        else
+          let x, l = extract l in
+          Node (replace_min x r, ly, l)
+    | Leaf, _ ->
+        assert false (* contradicts the assumption *)
 
   let maximum = function
-    | Empty -> raise EmptyHeap
-    | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x
-
-  (* smart constructors for removal; note that they are different
-     from the ones for insertion! *)
-  let p_f l x r = match l with
-    | Empty | FFF _ -> FFF (l, x, r)
-    | _ -> PPF (l, x, r)
-
-  let pf_ l x = function
-    | Empty | FFF _ as r -> PFF (l, x, r)
-    | r -> PFP (l, x, r)
-
-  let rec remove = function
-    | Empty ->
-	raise EmptyHeap
-    | FFF (Empty, _, Empty) ->
-	Empty
-    | PFF (l, _, Empty) ->
-	l
-    (* remove on the left *)
-    | PPF (l, x, r) | PFF (l, x, r) ->
-        let xl = maximum l in
-	let xr = maximum r in
-	let l' = remove l in
-	if X.compare xl xr >= 0 then
-	  p_f l' xl r
-	else
-	  p_f l' xr (add xl (remove r))
-    (* remove on the right *)
-    | FFF (l, x, r) | PFP (l, x, r) ->
-        let xl = maximum l in
-	let xr = maximum r in
-	let r' = remove r in
-	if X.compare xl xr > 0 then
-	  pf_ (add xr (remove l)) xl r'
-	else
-	  pf_ l xr r'
+    | Leaf -> raise EmptyHeap
+    | Node (_, x, _) -> x
+
+  let remove = function
+    | Leaf ->
+        raise EmptyHeap
+    | Node (l, _, r) ->
+        merge l r
 
   let rec iter f = function
-    | Empty ->
-	()
-    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
-	iter f l; f x; iter f r
+    | Leaf -> ()
+    | Node (l, x, r) -> iter f l; f x; iter f r
 
   let rec fold f h x0 = match h with
-    | Empty ->
+    | Leaf ->
 	x0
-    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
+    | Node (l, x, r) ->
 	fold f l (fold f r (f x x0))
 
 end
diff --git a/lib/heap.mli b/lib/heap.mli
index ee86e814..a69de34c 100644
--- a/lib/heap.mli
+++ b/lib/heap.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/lib/hook.ml b/lib/hook.ml
new file mode 100644
index 00000000..0aa373c2
--- /dev/null
+++ b/lib/hook.ml
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type 'a content =
+| Unset
+| Default of 'a
+| Set of 'a
+
+type 'a t = 'a content ref
+
+type 'a value = 'a t
+
+let get (hook : 'a value) = match !hook with
+| Unset -> assert false
+| Default data | Set data -> data
+
+let set (hook : 'a t) data = match !hook with
+| Unset | Default _ -> hook := Set data
+| Set _ -> assert false
+
+let make ?default () =
+  let data = match default with
+  | None -> Unset
+  | Some data -> Default data
+  in
+  let ans = ref data in
+  (ans, ans)
diff --git a/lib/hook.mli b/lib/hook.mli
new file mode 100644
index 00000000..d10f2c86
--- /dev/null
+++ b/lib/hook.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module centralizes the notions of hooks. Hooks are pointers that are to
+    be set at runtime exactly once. *)
+
+type 'a t
+(** The type of hooks containing ['a]. Hooks can only be set. *)
+
+type 'a value
+(** The content part of a hook. *)
+
+val make : ?default:'a -> unit -> ('a value * 'a t)
+(** Create a new hook together with a way to retrieve its runtime value. *)
+
+val get : 'a value -> 'a
+(** Access the content of a hook. If it was not set yet, try to recover the
+    default value if there is one.
+    @raise Assert_failure if undefined. *)
+
+val set : 'a t -> 'a -> unit
+(** Register a hook. Assertion failure if already registered. *)
diff --git a/lib/iStream.ml b/lib/iStream.ml
new file mode 100644
index 00000000..f9351d4b
--- /dev/null
+++ b/lib/iStream.ml
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type ('a,'r) u =
+| Nil
+| Cons of 'a * 'r
+
+type 'a node = ('a,'a t) u
+
+and 'a t = 'a node Lazy.t
+
+let empty = Lazy.lazy_from_val Nil
+
+let cons x s = Lazy.lazy_from_val (Cons (x, s))
+
+let thunk = Lazy.lazy_from_fun
+
+let rec make_node f s = match f s with
+| Nil -> Nil
+| Cons (x, s) -> Cons (x, make f s)
+
+and make f s = lazy (make_node f s)
+
+let rec force s = match Lazy.force s with
+| Nil -> ()
+| Cons (_, s) -> force s
+
+let force s = force s; s
+
+let is_empty s = match Lazy.force s with
+| Nil -> true
+| Cons (_, _) -> false
+
+let peek = Lazy.force
+
+let rec of_list = function
+| [] -> empty
+| x :: l -> cons x (of_list l)
+
+let rec to_list s = match Lazy.force s with
+| Nil -> []
+| Cons (x, s) -> x :: (to_list s)
+
+let rec iter f s = match Lazy.force s with
+| Nil -> ()
+| Cons (x, s) -> f x; iter f s
+
+let rec map_node f = function
+| Nil -> Nil
+| Cons (x, s) -> Cons (f x, map f s)
+
+and map f s = lazy (map_node f (Lazy.force s))
+
+let rec app_node n1 s2 = match n1 with
+| Nil -> Lazy.force s2
+| Cons (x, s1) -> Cons (x, app s1 s2)
+
+and app s1 s2 = lazy (app_node (Lazy.force s1) s2)
+
+let rec fold f accu s = match Lazy.force s with
+| Nil -> accu
+| Cons (x, s) -> fold f (f accu x) s
+
+let rec map_filter_node f = function
+| Nil -> Nil
+| Cons (x, s) ->
+  begin match f x with
+  | None -> map_filter_node f (Lazy.force s)
+  | Some y -> Cons (y, map_filter f s)
+  end
+
+and map_filter f s = lazy (map_filter_node f (Lazy.force s))
+
+let rec concat_node = function
+| Nil -> Nil
+| Cons (s, sl) -> app_node (Lazy.force s) (concat sl)
+
+and concat (s : 'a t t) =
+  lazy (concat_node (Lazy.force s))
+
+let rec concat_map_node f = function
+| Nil -> Nil
+| Cons (x,s) -> app_node (Lazy.force (f x)) (concat_map f s)
+
+and concat_map f l = lazy (concat_map_node f (Lazy.force l))
diff --git a/lib/iStream.mli b/lib/iStream.mli
new file mode 100644
index 00000000..8cb12af4
--- /dev/null
+++ b/lib/iStream.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** {5 Purely functional streams}
+
+  Contrarily to OCaml module [Stream], these are meant to be used purely
+  functionally. This implies in particular that accessing an element does not
+  discard it. *)
+
+type +'a t
+(** Type of pure streams. *)
+
+type ('a,'r) u =
+| Nil
+| Cons of 'a * 'r
+(** View type to decompose and build streams. *)
+
+(** {6 Constructors} *)
+
+val empty : 'a t
+(** The empty stream. *)
+
+val cons : 'a -> 'a t -> 'a t
+(** Append an element in front of a stream. *)
+
+val thunk : (unit -> ('a,'a t) u) -> 'a t
+(** Internalize the lazyness of a stream. *)
+
+val make : ('a -> ('b, 'a) u) -> 'a -> 'b t
+(** Coiteration constructor. *)
+
+(** {6 Destructors} *)
+
+val is_empty : 'a t -> bool
+(** Whethere a stream is empty. *)
+
+val peek : 'a t -> ('a , 'a t) u
+(** Return the head and the tail of a stream, if any. *)
+
+(** {6 Standard operations}
+
+    All stream-returning functions are lazy. The other ones are eager. *)
+
+val app : 'a t -> 'a t -> 'a t
+(** Append two streams. Not tail-rec. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** Mapping of streams. Not tail-rec. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iteration over streams. *)
+
+val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** Fold over streams. *)
+
+val concat : 'a t t -> 'a t
+(** Appends recursively a stream of streams. *)
+
+val map_filter : ('a -> 'b option) -> 'a t -> 'b t
+(** Mixing [map] and [filter]. Not tail-rec. *)
+
+val concat_map : ('a -> 'b t) -> 'a t -> 'b t
+(** [concat_map f l] is the same as [concat (map f l)]. *)
+
+(** {6 Conversions} *)
+
+val of_list : 'a list -> 'a t
+(** Convert a list into a stream. *)
+
+val to_list : 'a t -> 'a list
+(** Convert a stream into a list. *)
+
+(** {6 Other}*)
+
+val force : 'a t -> 'a t
+(** Forces the whole stream. *)
diff --git a/lib/int.ml b/lib/int.ml
new file mode 100644
index 00000000..d9917657
--- /dev/null
+++ b/lib/int.ml
@@ -0,0 +1,237 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type t = int
+
+external equal : int -> int -> bool = "%eq"
+
+external compare : int -> int -> int = "caml_int_compare"
+
+let hash i = i land 0x3FFFFFFF
+
+module Self =
+struct
+  type t = int
+  let compare = compare
+end
+
+module Set = Set.Make(Self)
+module Map =
+struct
+  include CMap.Make(Self)
+
+  type 'a map = 'a CMap.Make(Self).t
+
+  type 'a _map =
+  | MEmpty
+  | MNode of 'a map * int * 'a * 'a map * int
+
+  let map_prj : 'a map -> 'a _map = Obj.magic
+
+  let rec find i s = match map_prj s with
+  | MEmpty -> raise Not_found
+  | MNode (l, k, v, r, h) ->
+    if i < k then find i l
+    else if i = k then v
+    else find i r
+end
+
+module List = struct
+  let mem = List.memq
+  let assoc = List.assq
+  let mem_assoc = List.mem_assq
+  let remove_assoc = List.remove_assq
+end
+
+let min (i : int) j = if i < j then i else j
+
+(** Utility function *)
+let rec next from upto =
+  if from < upto then next (2 * from + 1) upto
+  else from
+
+
+module PArray =
+struct
+
+  type 'a t = 'a data ref
+  and 'a data =
+  | Root of 'a option array
+  | DSet of int * 'a option * 'a t
+
+  let empty n = ref (Root (Array.make n None))
+
+  let rec rerootk t k = match !t with
+  | Root _ -> k ()
+  | DSet (i, v, t') ->
+    let next () = match !t' with
+    | Root a as n ->
+      let v' = Array.unsafe_get a i in
+      let () = Array.unsafe_set a i v in
+      let () = t := n in
+      let () = t' := DSet (i, v', t) in
+      k ()
+    | DSet _ -> assert false
+    in
+    rerootk t' next
+
+  let reroot t = rerootk t (fun () -> ())
+
+  let get t i =
+  let () = assert (0 <= i) in
+  match !t with
+  | Root a ->
+    if Array.length a <= i then None
+    else Array.unsafe_get a i
+  | DSet _ ->
+    let () = reroot t in
+    match !t with
+    | Root a ->
+      if Array.length a <= i then None
+      else Array.unsafe_get a i
+    | DSet _ -> assert false
+
+  let set t i v =
+    let () = assert (0 <= i) in
+    let () = reroot t in
+    match !t with
+    | DSet _ -> assert false
+    | Root a as n ->
+      let len = Array.length a in
+      if i < len then
+        let old = Array.unsafe_get a i in
+        if old == v then t
+        else
+          let () = Array.unsafe_set a i v in
+          let res = ref n in
+          let () = t := DSet (i, old, res) in
+          res
+      else match v with
+      | None -> t (** Nothing to do! *)
+      | Some _ -> (** we must resize *)
+        let nlen = next len (succ i) in
+        let nlen = min nlen Sys.max_array_length in
+        let () = assert (i < nlen) in
+        let a' = Array.make nlen None in
+        let () = Array.blit a 0 a' 0 len in
+        let () = Array.unsafe_set a' i v in
+        let res = ref (Root a') in
+        let () = t := DSet (i, None, res) in
+        res
+
+end
+
+module PMap =
+struct
+
+  type key = int
+
+  (** Invariants:
+
+    1. an empty map is always [Empty].
+    2. the set of the [Map] constructor remembers the present keys.
+  *)
+  type 'a t = Empty | Map of Set.t * 'a PArray.t
+
+  let empty = Empty
+
+  let is_empty = function
+  | Empty -> true
+  | Map _ -> false
+
+  let singleton k x =
+    let len = next 19 (k + 1) in
+    let len = min Sys.max_array_length len in
+    let v = PArray.empty len in
+    let v = PArray.set v k (Some x) in
+    let s = Set.singleton k in
+    Map (s, v)
+
+  let add k x = function
+  | Empty -> singleton k x
+  | Map (s, v) ->
+    let s = match PArray.get v k with
+    | None -> Set.add k s
+    | Some _ -> s
+    in
+    let v = PArray.set v k (Some x) in
+    Map (s, v)
+
+  let remove k = function
+  | Empty -> Empty
+  | Map (s, v) ->
+    let s = Set.remove k s in
+    if Set.is_empty s then Empty
+    else
+      let v = PArray.set v k None in
+      Map (s, v)
+
+  let mem k = function
+  | Empty -> false
+  | Map (_, v) ->
+    match PArray.get v k with
+    | None -> false
+    | Some _ -> true
+
+  let find k = function
+  | Empty -> raise Not_found
+  | Map (_, v) ->
+    match PArray.get v k with
+    | None -> raise Not_found
+    | Some x -> x
+
+  let iter f = function
+  | Empty -> ()
+  | Map (s, v) ->
+    let iter k = match PArray.get v k with
+    | None -> ()
+    | Some x -> f k x
+    in
+    Set.iter iter s
+
+  let fold f m accu = match m with
+  | Empty -> accu
+  | Map (s, v) ->
+    let fold k accu = match PArray.get v k with
+    | None -> accu
+    | Some x -> f k x accu
+    in
+    Set.fold fold s accu
+
+  let exists f m = match m with
+  | Empty -> false
+  | Map (s, v) ->
+    let exists k = match PArray.get v k with
+    | None -> false
+    | Some x -> f k x
+    in
+    Set.exists exists s
+
+  let for_all f m = match m with
+  | Empty -> true
+  | Map (s, v) ->
+    let for_all k = match PArray.get v k with
+    | None -> true
+    | Some x -> f k x
+    in
+    Set.for_all for_all s
+
+  let cast = function
+  | Empty -> Map.empty
+  | Map (s, v) ->
+    let bind k = match PArray.get v k with
+    | None -> assert false
+    | Some x -> x
+    in
+    Map.bind bind s
+
+  let domain = function
+  | Empty -> Set.empty
+  | Map (s, _) -> s
+
+end
diff --git a/lib/int.mli b/lib/int.mli
new file mode 100644
index 00000000..c910bda6
--- /dev/null
+++ b/lib/int.mli
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** A native integer module with usual utility functions. *)
+
+type t = int
+
+external equal : t -> t -> bool = "%eq"
+
+external compare : t -> t -> int = "caml_int_compare"
+
+val hash : t -> int
+
+module Set : Set.S with type elt = t
+module Map : CMap.ExtS with type key = t and module Set := Set
+
+module List : sig
+  val mem : int -> int list -> bool
+  val assoc : int -> (int * 'a) list -> 'a
+  val mem_assoc : int -> (int * 'a) list -> bool
+  val remove_assoc : int -> (int * 'a) list -> (int * 'a) list
+end
+
+module PArray :
+sig
+  type 'a t
+  (** Persistent, auto-resizable arrays. The [get] and [set] functions never
+      fail whenever the index is between [0] and [Sys.max_array_length - 1]. *)
+  val empty : int -> 'a t
+  (** The empty array, with a given starting size. *)
+  val get : 'a t -> int -> 'a option
+  (** Get a value at the given index. Returns [None] if undefined. *)
+  val set : 'a t -> int -> 'a option -> 'a t
+  (** Set/unset a value at the given index. *)
+end
+
+module PMap :
+sig
+  type key = int
+  type 'a t
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val mem : key -> 'a t -> bool
+  val add : key -> 'a -> 'a t -> 'a t
+  val singleton : key -> 'a -> 'a t
+  val remove : key -> 'a t -> 'a t
+(*   val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t *)
+(*   val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int *)
+(*   val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool *)
+  val iter : (key -> 'a -> unit) -> 'a t -> unit
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val for_all : (key -> 'a -> bool) -> 'a t -> bool
+  val exists : (key -> 'a -> bool) -> 'a t -> bool
+(*   val filter : (key -> 'a -> bool) -> 'a t -> 'a t *)
+(*   val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t *)
+(*   val cardinal : 'a t -> int *)
+(*   val bindings : 'a t -> (key * 'a) list *)
+(*   val min_binding : 'a t -> key * 'a *)
+(*   val max_binding : 'a t -> key * 'a *)
+(*   val choose : 'a t -> key * 'a *)
+(*   val split : key -> 'a t -> 'a t * 'a option * 'a t *)
+  val find : key -> 'a t -> 'a
+(*   val map : ('a -> 'b) -> 'a t -> 'b t *)
+(*   val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t *)
+  val domain : 'a t -> Set.t
+  val cast : 'a t -> 'a Map.t
+end
+(** This is a (partial) implementation of a [Map] interface on integers, except
+    that it internally uses persistent arrays. This ensures O(1) accesses in
+    non-backtracking cases. It is thus better suited for zero-starting,
+    contiguous keys, or otherwise a lot of space will be empty. To keep track of
+    the present keys, a binary tree is also used, so that adding a key is
+    still logarithmic. It is therefore essential that most of the operations
+    are accesses and not add/removes. *)
diff --git a/lib/lib.mllib b/lib/lib.mllib
index db79b5c2..f3f6ad8f 100644
--- a/lib/lib.mllib
+++ b/lib/lib.mllib
@@ -1,31 +1,20 @@
-Xml_lexer
-Xml_parser
-Xml_utils
-Pp_control
-Pp
-Compat
-Flags
-Segmenttree
-Unicodetable
-Util
 Errors
 Bigint
-Hashcons
 Dyn
+Segmenttree
+Unicodetable
+Unicode
 System
-Envars
-Gmap
-Fset
-Fmap
-Tries
-Gmapl
+CThread
+Spawn
+Trie
 Profile
 Explore
 Predicate
 Rtree
 Heap
-Option
-Dnet
-Store
 Unionfind
-Hashtbl_alt
+Genarg
+Ephemeron
+Future
+RemoteCounter
diff --git a/lib/loc.ml b/lib/loc.ml
new file mode 100644
index 00000000..b62677d4
--- /dev/null
+++ b/lib/loc.ml
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Locations management *)
+
+
+type t = {
+  fname : string; (** filename *)
+  line_nb : int; (** start line number *)
+  bol_pos : int; (** position of the beginning of start line *)
+  line_nb_last : int; (** end line number *)
+  bol_pos_last : int; (** position of the beginning of end line *)
+  bp : int; (** start position *)
+  ep : int; (** end position *)
+}
+
+let create fname line_nb bol_pos (bp, ep) = {
+  fname = fname; line_nb = line_nb; bol_pos = bol_pos;
+  line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; }
+
+let make_loc (bp, ep) = {
+  fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
+  bp = bp; ep = ep; }
+
+let ghost = {
+  fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
+  bp = 0; ep = 0; }
+
+let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *)
+
+let merge loc1 loc2 =
+  if loc1.bp < loc2.bp then
+    if loc1.ep < loc2.ep then {
+      fname = loc1.fname;
+      line_nb = loc1.line_nb;
+      bol_pos = loc1.bol_pos;
+      line_nb_last = loc2.line_nb_last;
+      bol_pos_last = loc2.bol_pos_last;
+      bp = loc1.bp; ep = loc2.ep; }
+    else loc1
+  else if loc2.ep < loc1.ep then {
+    fname = loc2.fname;
+    line_nb = loc2.line_nb;
+    bol_pos = loc2.bol_pos;
+    line_nb_last = loc1.line_nb_last;
+    bol_pos_last = loc1.bol_pos_last;
+    bp = loc2.bp; ep = loc1.ep; }
+  else loc2
+
+let unloc loc = (loc.bp, loc.ep)
+
+let represent loc = (loc.fname, loc.line_nb, loc.bol_pos, loc.bp, loc.ep)
+
+let dummy_loc = ghost
+let join_loc = merge
+
+(** Located type *)
+
+type 'a located = t * 'a
+let located_fold_left f x (_,a) = f x a
+let located_iter2 f (_,a) (_,b) = f a b
+let down_located f (_,a) = f a
+
+(** Exceptions *)
+
+let location : t Exninfo.t = Exninfo.make ()
+
+let add_loc e loc = Exninfo.add e location loc
+
+let get_loc e = Exninfo.get e location
+
+let raise loc e =
+  let info = Exninfo.add Exninfo.null location loc in
+  Exninfo.iraise (e, info)
diff --git a/lib/loc.mli b/lib/loc.mli
new file mode 100644
index 00000000..7a9a9ffd
--- /dev/null
+++ b/lib/loc.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** {5 Basic types} *)
+
+type t
+
+type 'a located = t * 'a
+(** Embed a location in a type *)
+
+(** {5 Location manipulation} *)
+
+(** This is inherited from CAMPL4/5. *)
+
+val create : string -> int -> int -> (int * int) -> t
+(** Create a location from a filename, a line number, a position of the
+    beginning of the line and a pair of start and end position *)
+
+val unloc : t -> int * int
+(** Return the start and end position of a location *)
+
+val make_loc : int * int -> t
+(** Make a location out of its start and end position *)
+
+val ghost : t
+(** Dummy location *)
+
+val is_ghost : t -> bool
+(** Test whether the location is meaningful *)
+
+val merge : t -> t -> t
+
+val represent : t -> (string * int * int * int * int)
+(** Return the arguments given in [create] *)
+
+(** {5 Located exceptions} *)
+
+val add_loc : Exninfo.info -> t -> Exninfo.info
+(** Adding location to an exception *)
+
+val get_loc : Exninfo.info -> t option
+(** Retrieving the optional location of an exception *)
+
+val raise : t -> exn -> 'a
+(** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *)
+
+(** {5 Location utilities} *)
+
+val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
+val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
+
+val down_located : ('a -> 'b) -> 'a located -> 'b
+(** Projects out a located object *)
+
+(** {5 Backward compatibility} *)
+
+val dummy_loc : t
+(** Same as [ghost] *)
+
+val join_loc : t -> t -> t
+(** Same as [merge] *)
diff --git a/lib/monad.ml b/lib/monad.ml
new file mode 100644
index 00000000..4a52684d
--- /dev/null
+++ b/lib/monad.ml
@@ -0,0 +1,157 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+
+(** Combinators on monadic computations. *)
+
+
+(** A definition of monads, each of the combinators is used in the
+    [Make] functor. *)
+module type Def = sig
+
+  type +'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (>>) : unit t -> 'a t -> 'a t
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
+  (** The monadic laws must hold:
+      - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)]
+      - [return a >>= f] = [f a]
+      - [x>>=return] = [x]
+
+      As well as the following identities:
+      - [x >> y] = [x >>= fun () -> y]
+      - [map f x] = [x >>= fun x' -> f x'] *)
+
+end
+
+module type ListS = sig
+
+  type 'a t
+
+  (** [List.map f l] maps [f] on the elements of [l] in left to right
+      order. *)
+  val map : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** [List.map f l] maps [f] on the elements of [l] in right to left
+      order. *)
+  val map_right : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** Like the regular [List.fold_right]. The monadic effects are
+      threaded right to left.
+
+      Note: many monads behave poorly with right-to-left order. For
+      instance a failure monad would still have to traverse the
+      whole list in order to fail and failure needs to be propagated
+      through the rest of the list in binds which are now
+      spurious. It is also the worst case for substitution monads
+      (aka free monads), exposing the quadratic behaviour.*)
+  val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t
+
+  (** Like the regular [List.fold_left]. The monadic effects are
+      threaded left to right. It is tail-recursive if the [(>>=)]
+      operator calls its second argument in a tail position. *)
+  val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t
+
+  (** Like the regular [List.iter]. The monadic effects are threaded
+      left to right. It is tail-recurisve if the [>>] operator calls
+      its second argument in a tail position. *)
+  val iter : ('a -> unit t) -> 'a list -> unit t
+
+
+  (** {6 Two-list iterators} *)
+
+  (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts
+      simultaneously on two lists. Runs [r] (presumably an
+      exception-raising computation) if both lists do not have the
+      same length. *)
+  val fold_left2 : 'a t ->
+    ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t
+
+end
+
+module type S = sig
+
+  include Def
+
+  (** List combinators *)
+  module List : ListS with type 'a t := 'a t
+
+end
+
+
+module Make (M:Def) : S with type +'a t = 'a M.t = struct
+
+  include M
+
+  module List = struct
+
+    (* The combinators are loop-unrolled to spare a some monadic binds
+       (it is a common optimisation to treat the last of a list of
+       bind specially) and hopefully gain some efficiency using fewer
+       jump. *)
+
+    let rec map f = function
+      | [] -> return []
+      | [a] ->
+          M.map (fun a' -> [a']) (f a)
+      | a::b::l ->
+          f a >>= fun a' ->
+          f b >>= fun b' ->
+          M.map (fun l' -> a'::b'::l') (map f l)
+
+    let rec map_right f = function
+      | [] -> return []
+      | [a] ->
+          M.map (fun a' -> [a']) (f a)
+      | a::b::l ->
+          map f l >>= fun l' ->
+          f b >>= fun b' ->
+          M.map (fun a' -> a'::b'::l') (f a)
+
+    let rec fold_right f l x =
+      match l with
+      | [] -> return x
+      | [a] -> f a x
+      | a::b::l ->
+          fold_right f l x >>= fun acc ->
+          f b acc >>= fun acc ->
+          f a acc
+
+    let rec fold_left f x = function
+      | [] -> return x
+      | [a] -> f x a
+      | a::b::l ->
+          f x a >>= fun x' ->
+          f x' b >>= fun x'' ->
+          fold_left f x'' l
+
+    let rec iter f = function
+      | [] -> return ()
+      | [a] -> f a
+      | a::b::l -> f a >> f b >> iter f l
+
+
+
+    let rec fold_left2 r f x l1 l2 =
+      match l1,l2 with
+      | [] , [] -> return x
+      | [a] , [b] -> f x a b
+      | a1::a2::l1 , b1::b2::l2 ->
+          f x a1 b1 >>= fun x' ->
+          f x' a2 b2 >>= fun x'' ->
+          fold_left2 r f x'' l1 l2
+      | _ , _ -> r
+
+  end
+
+end
+
+
+
diff --git a/lib/monad.mli b/lib/monad.mli
new file mode 100644
index 00000000..c8655efa
--- /dev/null
+++ b/lib/monad.mli
@@ -0,0 +1,90 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+
+(** Combinators on monadic computations. *)
+
+
+(** A definition of monads, each of the combinators is used in the
+    [Make] functor. *)
+module type Def = sig
+
+  type +'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (>>) : unit t -> 'a t -> 'a t
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
+(** The monadic laws must hold:
+    - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)]
+    - [return a >>= f] = [f a]
+    - [x>>=return] = [x]
+
+    As well as the following identities:
+    - [x >> y] = [x >>= fun () -> y]
+    - [map f x] = [x >>= fun x' -> f x'] *)
+
+end
+
+
+(** List combinators *)
+module type ListS = sig
+
+  type 'a t
+
+  (** [List.map f l] maps [f] on the elements of [l] in left to right
+      order. *)
+  val map : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** [List.map f l] maps [f] on the elements of [l] in right to left
+      order. *)
+  val map_right : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** Like the regular [List.fold_right]. The monadic effects are
+      threaded right to left.
+
+      Note: many monads behave poorly with right-to-left order. For
+      instance a failure monad would still have to traverse the
+      whole list in order to fail and failure needs to be propagated
+      through the rest of the list in binds which are now
+      spurious. It is also the worst case for substitution monads
+      (aka free monads), exposing the quadratic behaviour.*)
+  val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t
+
+  (** Like the regular [List.fold_left]. The monadic effects are
+      threaded left to right. It is tail-recursive if the [(>>=)]
+      operator calls its second argument in a tail position. *)
+  val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t
+
+  (** Like the regular [List.iter]. The monadic effects are threaded
+      left to right. It is tail-recurisve if the [>>] operator calls
+      its second argument in a tail position. *)
+  val iter : ('a -> unit t) -> 'a list -> unit t
+
+
+  (** {6 Two-list iterators} *)
+
+  (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts
+      simultaneously on two lists. Runs [r] (presumably an
+      exception-raising computation) if both lists do not have the
+      same length. *)
+  val fold_left2 : 'a t ->
+    ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t
+
+end
+
+module type S = sig
+
+  include Def
+
+  module List : ListS with type 'a t := 'a t
+
+end
+
+(** Expands the monadic definition to extra combinators. *)
+module Make (M:Def) : S with type +'a t = 'a M.t
diff --git a/lib/option.ml b/lib/option.ml
index d6df7063..9ea1a769 100644
--- a/lib/option.ml
+++ b/lib/option.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -19,6 +19,26 @@ let has_some = function
   | None -> false
   | _ -> true
 
+let is_empty = function
+| None -> true
+| Some _ -> false
+
+(** Lifting equality onto option types. *)
+let equal f x y = match x, y with
+| None, None -> true
+| Some x, Some y -> f x y
+| _, _ -> false
+
+let compare f x y = match x, y with
+| None, None -> 0
+| Some x, Some y -> f x y
+| None, Some _ -> -1
+| Some _, None -> 1
+
+let hash f = function
+| None -> 0
+| Some x -> f x
+
 exception IsNone
 
 (** [get x] returns [y] where [x] is [Some y]. It raises IsNone
@@ -44,6 +64,14 @@ let flatten = function
   | _ -> None
 
 
+(** [append x y] is the first element of the concatenation of [x] and
+    [y] seen as lists. *)
+let append o1 o2 =
+  match o1 with
+  | Some _ -> o1
+  | None  -> o2
+
+
 (** {6 "Iterators"} ***)
 
 (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing
@@ -153,21 +181,11 @@ module List =
   let rec flatten = function
     | x::l -> cons x (flatten l)
     | [] -> []
-end
-
 
+  let rec find f = function
+    |[] -> None
+    |h :: t -> match f h with
+	 |None -> find f t
+	 |x -> x
 
-(** {6 Miscelaneous Primitives} *)
-
-module Misc =
- struct
-  (** [Misc.compare f x y] lifts the equality predicate [f] to
-      option types. That is, if both [x] and [y] are [None] then
-      it returns [true], if they are bothe [Some _] then
-      [f] is called. Otherwise it returns [false]. *)
-   let compare f x y =
-     match x,y with
-     | None, None -> true
-     | Some z, Some w -> f z w
-     | _,_ -> false
 end
diff --git a/lib/option.mli b/lib/option.mli
index 121d6500..d9ad0e11 100644
--- a/lib/option.mli
+++ b/lib/option.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,11 +13,26 @@
    they actually are similar considering ['a option] as a type
    of lists with at most one element. *)
 
+exception IsNone
+
 (** [has_some x] is [true] if [x] is of the form [Some y] and [false]
     otherwise.  *)
 val has_some : 'a option -> bool
 
-exception IsNone
+(** Negation of [has_some] *)
+val is_empty : 'a option -> bool
+
+(** [equal f x y] lifts the equality predicate [f] to
+    option types. That is, if both [x] and [y] are [None] then
+    it returns [true], if they are both [Some _] then
+    [f] is called. Otherwise it returns [false]. *)
+val equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
+
+(** Same as [equal], but with comparison. *)
+val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int
+
+(** Lift a hash to option types. *)
+val hash : ('a -> int) -> 'a option -> int
 
 (** [get x] returns [y] where [x] is [Some y]. It raises IsNone
     if [x] equals [None]. *)
@@ -32,6 +47,12 @@ val init : bool -> 'a -> 'a option
 (** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *)
 val flatten : 'a option option -> 'a option
 
+(** [append x y] is the first element of the concatenation of [x] and
+    [y] seen as lists.  In other words, [append (Some a) y] is [Some
+    a], [append None (Some b)] is [Some b], and [append None None] is
+    [None]. *)
+val append : 'a option -> 'a option -> 'a option
+
 
 (** {6 "Iterators"} ***)
 
@@ -67,7 +88,7 @@ val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
 (** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *)
 val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option
 
-(** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
+(** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
 val cata : ('a -> 'b) -> 'b -> 'a option -> 'b
 
 (** {6 More Specific Operations} ***)
@@ -100,16 +121,6 @@ module List : sig
   (** [List.flatten l] is the list of all the [y]s such that [l] contains
       [Some y] (in the same order). *)
   val flatten : 'a option list -> 'a list
-end
-
 
-(** {6 Miscelaneous Primitives} *)
-
-module Misc : sig
-  (** [Misc.compare f x y] lifts the equality predicate [f] to
-      option types. That is, if both [x] and [y] are [None] then
-      it returns [true], if they are bothe [Some _] then
-      [f] is called. Otherwise it returns [false]. *)
-   val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
+  val find : ('a -> 'b option) -> 'a list -> 'b option
 end
-
diff --git a/lib/pp.ml b/lib/pp.ml
new file mode 100644
index 00000000..234d2344
--- /dev/null
+++ b/lib/pp.ml
@@ -0,0 +1,591 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module Glue : sig
+
+  (* A left associative glue implements efficient glue operator
+     when used as left associative.  If glue is denoted ++ then
+
+        a ++ b ++ c ++ d = ((a ++ b) ++ c) ++ d = [d] @ ([c] @ ([b] @  [a]))
+
+     I.e. if the short list is the second argument
+  *)
+  type 'a t
+
+  val atom : 'a -> 'a t
+  val glue : 'a t -> 'a t -> 'a t
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val iter : ('a -> unit) -> 'a t -> unit
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
+end = struct
+
+  type 'a t = 'a list
+
+  let atom x = [x]
+  let glue x y = y @ x
+  let empty = []
+  let is_empty x = x = []
+
+  let iter f g = List.iter f (List.rev g)
+  let map = List.map
+end
+
+module Tag :
+sig
+  type t 
+  type 'a key
+  val create : string -> 'a key
+  val inj : 'a -> 'a key -> t
+  val prj : t -> 'a key -> 'a option
+end =
+struct
+  (** See module {Dyn} for more details. *)
+
+  type t = int * Obj.t
+
+  type 'a key = int
+
+  let dyntab = ref (Int.Map.empty : string Int.Map.t)
+
+  let create (s : string) =
+    let hash = Hashtbl.hash s in
+    let () = assert (not (Int.Map.mem hash !dyntab)) in
+    let () = dyntab := Int.Map.add hash s !dyntab in
+    hash
+
+  let inj x h = (h, Obj.repr x)
+
+  let prj (nh, rv) h =
+    if Int.equal h nh then Some (Obj.magic rv)
+    else None
+
+end
+
+open Pp_control
+
+(* This should not be used outside of this file. Use
+   Flags.print_emacs instead. This one is updated when reading
+   command line options. This was the only way to make [Pp] depend on
+   an option without creating a circularity: [Flags] -> [Util] ->
+   [Pp] -> [Flags] *)
+let print_emacs = ref false
+
+(* The different kinds of blocks are:
+   \begin{description}
+   \item[hbox:] Horizontal block no line breaking;
+   \item[vbox:] Vertical block each break leads to a new line;
+   \item[hvbox:] Horizontal-vertical block: same as vbox, except if
+      this block is small enough to fit on a single line
+   \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
+      only when necessary to print the content of the block
+   \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
+      (except if no mark yet on the reste of the line)
+   \end{description}
+ *)
+
+let comments = ref []
+
+let rec split_com comacc acc pos = function
+    [] -> comments := List.rev acc; comacc
+  | ((b,e),c as com)::coms ->
+      (* Take all comments that terminates before pos, or begin exactly
+         at pos (used to print comments attached after an expression) *)
+      if e<=pos || pos=b then split_com (c::comacc) acc pos coms
+      else  split_com comacc (com::acc) pos coms
+
+
+type block_type =
+  | Pp_hbox of int
+  | Pp_vbox of int
+  | Pp_hvbox of int
+  | Pp_hovbox of int
+  | Pp_tbox
+
+type str_token =
+| Str_def of string
+| Str_len of string * int (** provided length *)
+
+type 'a ppcmd_token =
+  | Ppcmd_print of 'a
+  | Ppcmd_box of block_type * ('a ppcmd_token Glue.t)
+  | Ppcmd_print_break of int * int
+  | Ppcmd_set_tab
+  | Ppcmd_print_tbreak of int * int
+  | Ppcmd_white_space of int
+  | Ppcmd_force_newline
+  | Ppcmd_print_if_broken
+  | Ppcmd_open_box of block_type
+  | Ppcmd_close_box
+  | Ppcmd_close_tbox
+  | Ppcmd_comment of int
+  | Ppcmd_open_tag of Tag.t
+  | Ppcmd_close_tag
+
+type 'a ppdir_token =
+  | Ppdir_ppcmds of 'a ppcmd_token Glue.t
+  | Ppdir_print_newline
+  | Ppdir_print_flush
+
+type ppcmd = str_token ppcmd_token
+
+type std_ppcmds = ppcmd Glue.t
+
+type 'a ppdirs = 'a ppdir_token Glue.t
+
+let (++) = Glue.glue
+
+let app = Glue.glue
+
+let is_empty g = Glue.is_empty g
+
+let rewrite f p =
+  let strtoken = function
+    | Str_len (s, n) ->
+      let s' = f s in
+      Str_len (s', String.length s')
+    | Str_def s ->
+      Str_def (f s)
+  in
+  let rec ppcmd_token = function
+    | Ppcmd_print x -> Ppcmd_print (strtoken x)
+    | Ppcmd_box (bt, g) -> Ppcmd_box (bt, Glue.map ppcmd_token g)
+    | p -> p
+  in
+  Glue.map ppcmd_token p
+
+(* Compute length of an UTF-8 encoded string
+   Rem 1 : utf8_length <= String.length (equal if pure ascii)
+   Rem 2 : if used for an iso8859_1 encoded string, the result is
+   wrong in very rare cases. Such a wrong case corresponds to any
+   sequence of a character in range 192..253 immediately followed by a
+   character in range 128..191 (typical case in french is "déçu" which
+   is counted 3 instead of 4); then no real harm to use always
+   utf8_length even if using an iso8859_1 encoding *)
+
+let utf8_length s =
+  let len = String.length s
+  and cnt = ref 0
+  and nc = ref 0
+  and p = ref 0 in
+  while !p < len do
+    begin
+      match s.[!p] with
+      | '\000'..'\127' -> nc := 0 (* ascii char *)
+      | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
+      | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
+      | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
+      | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
+      | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
+      | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
+      | '\254'..'\255' -> nc := 0 (* invalid byte *)
+    end ;
+    incr p ;
+    while !p < len && !nc > 0 do
+      match s.[!p] with
+      | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
+      | _ (* not a continuation byte *) -> nc := 0
+    done ;
+    incr cnt
+  done ;
+  !cnt
+
+(* formatting commands *)
+let str s = Glue.atom(Ppcmd_print (Str_def s))
+let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i)))
+let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b))
+let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b))
+let tab () = Glue.atom(Ppcmd_set_tab)
+let fnl () = Glue.atom(Ppcmd_force_newline)
+let pifb () = Glue.atom(Ppcmd_print_if_broken)
+let ws n = Glue.atom(Ppcmd_white_space n)
+let comment n = Glue.atom(Ppcmd_comment n)
+
+(* derived commands *)
+let mt () = Glue.empty
+let spc () = Glue.atom(Ppcmd_print_break (1,0))
+let cut () = Glue.atom(Ppcmd_print_break (0,0))
+let align () = Glue.atom(Ppcmd_print_break (0,0))
+let int n = str (string_of_int n)
+let real r = str (string_of_float r)
+let bool b = str (string_of_bool b)
+let strbrk s =
+  let rec aux p n =
+    if n < String.length s then
+      if s.[n] = ' ' then
+        if p = n then spc() :: aux (n+1) (n+1)
+        else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1)
+      else aux p (n + 1)
+    else if p = n then [] else [str (String.sub s p (n-p))]
+  in List.fold_left (++) Glue.empty (aux 0 0)
+
+let ismt = is_empty
+
+(* boxing commands *)
+let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s))
+let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s))
+let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s))
+let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s))
+let t s = Glue.atom(Ppcmd_box(Pp_tbox,s))
+
+(* Opening and closing of boxes *)
+let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n))
+let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n))
+let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n))
+let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n))
+let tb () = Glue.atom(Ppcmd_open_box Pp_tbox)
+let close () = Glue.atom(Ppcmd_close_box)
+let tclose () = Glue.atom(Ppcmd_close_tbox)
+
+(* Opening and closed of tags *)
+let open_tag t = Glue.atom(Ppcmd_open_tag t)
+let close_tag () = Glue.atom(Ppcmd_close_tag)
+let tag t s = open_tag t ++ s ++ close_tag ()
+let eval_ppcmds l = l
+
+(* In new syntax only double quote char is escaped by repeating it *)
+let escape_string s =
+  let rec escape_at s i =
+    if i<0 then s
+    else if s.[i] == '"' then
+      let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
+      escape_at s' (i-1)
+    else escape_at s (i-1) in
+  escape_at s (String.length s - 1)
+
+let qstring s = str ("\""^escape_string s^"\"")
+let qs = qstring
+let quote s = h 0 (str "\"" ++ s ++ str "\"")
+
+(* This flag tells if the last printed comment ends with a newline, to
+  avoid empty lines *)
+let com_eol = ref false
+
+let com_brk ft = com_eol := false
+let com_if ft f =
+  if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
+  else Lazy.force f
+
+let rec pr_com ft s =
+  let (s1,os) =
+    try
+      let n = String.index s '\n' in
+      String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
+    with Not_found -> s,None in
+  com_if ft (Lazy.lazy_from_val());
+(*  let s1 =
+    if String.length s1 <> 0 && s1.[0] = ' ' then
+      (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
+    else s1 in*)
+  Format.pp_print_as ft (utf8_length s1) s1;
+  match os with
+      Some s2 ->
+        if Int.equal (String.length s2) 0 then (com_eol := true)
+        else
+          (Format.pp_force_newline ft (); pr_com ft s2)
+    | None -> ()
+
+type tag_handler = Tag.t -> Format.tag
+
+(* pretty printing functions *)
+let pp_dirs ?pp_tag ft =
+  let pp_open_box = function
+    | Pp_hbox n   -> Format.pp_open_hbox ft ()
+    | Pp_vbox n   -> Format.pp_open_vbox ft n
+    | Pp_hvbox n  -> Format.pp_open_hvbox ft n
+    | Pp_hovbox n -> Format.pp_open_hovbox ft n
+    | Pp_tbox     -> Format.pp_open_tbox ft ()
+  in
+  let rec pp_cmd = function
+    | Ppcmd_print tok         ->
+        begin match tok with
+        | Str_def s ->
+          let n = utf8_length s in
+          com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+        | Str_len (s, n) ->
+          com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+        end
+    | Ppcmd_box(bty,ss)       -> (* Prevent evaluation of the stream! *)
+        com_if ft (Lazy.lazy_from_val());
+        pp_open_box bty ;
+        if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss;
+        Format.pp_close_box ft ()
+    | Ppcmd_open_box bty      -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
+    | Ppcmd_close_box         -> Format.pp_close_box ft ()
+    | Ppcmd_close_tbox        -> Format.pp_close_tbox ft ()
+    | Ppcmd_white_space n     ->
+        com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
+    | Ppcmd_print_break(m,n)  ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
+    | Ppcmd_set_tab           -> Format.pp_set_tab ft ()
+    | Ppcmd_print_tbreak(m,n) ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
+    | Ppcmd_force_newline     ->
+        com_brk ft; Format.pp_force_newline ft ()
+    | Ppcmd_print_if_broken   ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
+    | Ppcmd_comment i         ->
+        let coms = split_com [] [] i !comments in
+(*        Format.pp_open_hvbox ft 0;*)
+        List.iter (pr_com ft) coms(*;
+        Format.pp_close_box ft ()*)
+    | Ppcmd_open_tag tag ->
+      begin match pp_tag with
+      | None -> ()
+      | Some f -> Format.pp_open_tag ft (f tag)
+      end
+    | Ppcmd_close_tag ->
+      begin match pp_tag with
+      | None -> ()
+      | Some _ -> Format.pp_close_tag ft ()
+      end
+  in
+  let pp_dir = function
+    | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream
+    | Ppdir_print_newline    ->
+        com_brk ft; Format.pp_print_newline ft ()
+    | Ppdir_print_flush      -> Format.pp_print_flush ft ()
+  in
+  fun (dirstream : _ ppdirs) ->
+    try
+      Glue.iter pp_dir dirstream; com_brk ft
+    with reraise ->
+      let reraise = Backtrace.add_backtrace reraise in
+      let () = Format.pp_print_flush ft () in
+      Exninfo.iraise reraise
+
+
+
+(* pretty print on stdout and stderr *)
+
+(* Special chars for emacs, to detect warnings inside goal output *)
+let emacs_quote_start = String.make 1 (Char.chr 254)
+let emacs_quote_end = String.make 1 (Char.chr 255)
+
+let emacs_quote_info_start = "<infomsg>"
+let emacs_quote_info_end = "</infomsg>"
+
+let emacs_quote g =
+  if !print_emacs then str emacs_quote_start ++ hov 0 g ++ str emacs_quote_end
+  else hov 0 g
+
+let emacs_quote_info g =
+  if !print_emacs then str emacs_quote_info_start++fnl() ++ hov 0 g ++ str emacs_quote_info_end
+  else hov 0 g
+
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp_with ?pp_tag ft strm =
+  pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm))
+
+let ppnl_with ft strm =
+  pp_dirs ft (Glue.atom (Ppdir_ppcmds (strm ++ fnl ())))
+
+let pp_flush_with ft = Format.pp_print_flush ft
+
+(* pretty printing functions WITH FLUSH *)
+let msg_with ft strm =
+  pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush))
+
+let msgnl_with ft strm =
+  pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_newline))
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp        x = pp_with   !std_ft x
+let ppnl      x = ppnl_with !std_ft x
+let pperr     x = pp_with   !err_ft x
+let pperrnl   x = ppnl_with !err_ft x
+let message   s = ppnl      (str s)
+let pp_flush  x = Format.pp_print_flush !std_ft x
+let pperr_flush x = Format.pp_print_flush !err_ft x
+let flush_all () =
+  flush stderr; flush stdout; pp_flush (); pperr_flush ()
+
+(* pretty printing functions WITH FLUSH *)
+let msg x = msg_with !std_ft x
+let msgnl x = msgnl_with !std_ft x
+let msgerr x = msg_with !err_ft x
+let msgerrnl x = msgnl_with !err_ft x
+
+(* Logging management *)
+
+type message_level =  Feedback.message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = Feedback.message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+let of_message = Feedback.of_message
+let to_message = Feedback.to_message
+let is_message = Feedback.is_message
+
+type logger = message_level -> std_ppcmds -> unit
+
+let make_body info s =
+  emacs_quote (hov 0 (info ++ spc () ++ s))
+
+let debugbody strm = hov 0 (str "Debug:" ++ spc () ++ strm)
+let warnbody strm = make_body (str "Warning:") strm
+let errorbody strm = make_body (str "Error:") strm
+let infobody strm = emacs_quote_info strm
+
+let std_logger ~id:_ level msg = match level with
+| Debug _ -> msgnl (debugbody msg)
+| Info -> msgnl (hov 0 msg)
+| Notice -> msgnl msg
+| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody msg)) ()
+| Error -> msgnl_with !err_ft (errorbody msg)
+
+let emacs_logger ~id:_ level mesg = match level with
+| Debug _ -> msgnl (debugbody mesg)
+| Info -> msgnl (infobody mesg)
+| Notice -> msgnl mesg
+| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody mesg)) ()
+| Error -> msgnl_with !err_ft (errorbody mesg)
+
+let logger = ref std_logger
+
+let make_pp_emacs() = print_emacs:=true; logger:=emacs_logger
+let make_pp_nonemacs() = print_emacs:=false; logger := std_logger
+
+
+let feedback_id = ref (Feedback.Edit 0)
+let feedback_route = ref Feedback.default_route
+
+(* If mixing some output and a goal display, please use msg_warning,
+   so that interfaces (proofgeneral for example) can easily dispatch
+   them to different windows. *)
+
+let msg_info x = !logger ~id:!feedback_id Info x
+let msg_notice x = !logger ~id:!feedback_id Notice x
+let msg_warning x = !logger ~id:!feedback_id Warning x
+let msg_error x = !logger ~id:!feedback_id Error x
+let msg_debug x = !logger ~id:!feedback_id (Debug "_") x
+
+let set_logger l = logger := (fun ~id:_ lvl msg -> l lvl msg)
+
+let std_logger lvl msg = std_logger ~id:!feedback_id lvl msg
+
+(** Feedback *)
+
+let feeder = ref ignore
+let set_id_for_feedback ?(route=Feedback.default_route) i =
+  feedback_id := i; feedback_route := route
+let feedback ?state_id ?edit_id ?route what =
+  !feeder {
+     Feedback.contents = what;
+     Feedback.route = Option.default !feedback_route route;
+     Feedback.id =
+       match state_id, edit_id with
+       | Some id, _ -> Feedback.State id
+       | None, Some eid -> Feedback.Edit eid
+       | None, None -> !feedback_id;
+  }
+let set_feeder f = feeder := f
+let get_id_for_feedback () = !feedback_id, !feedback_route
+
+(** Utility *)
+
+let string_of_ppcmds c =
+  msg_with Format.str_formatter c;
+  Format.flush_str_formatter ()
+
+let log_via_feedback () = logger := (fun ~id lvl msg ->
+  !feeder {
+     Feedback.contents = Feedback.Message {
+       message_level = lvl;
+       message_content = string_of_ppcmds msg };
+     Feedback.route = !feedback_route;
+     Feedback.id = id })
+
+(* Copy paste from Util *)
+
+let pr_comma () = str "," ++ spc ()
+let pr_semicolon () = str ";" ++ spc ()
+let pr_bar () = str "|" ++ spc ()
+let pr_arg pr x = spc () ++ pr x
+let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
+let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x
+
+let pr_nth n =
+  int n ++ str (match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th")
+
+(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
+
+let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l
+
+(* unlike all other functions below, [prlist] works lazily.
+   if a strict behavior is needed, use [prlist_strict] instead.
+   evaluation is done from left to right. *)
+
+let prlist_sep_lastsep no_empty sep lastsep elem =
+  let rec start = function
+    |[] -> mt ()
+    |[e] -> elem e
+    |h::t -> let e = elem h in
+        if no_empty && ismt e then start t else
+          let rec aux = function
+            |[] -> mt ()
+            |h::t ->
+               let e = elem h and r = aux t in
+                 if no_empty && ismt e then r else
+                   if ismt r
+                   then let s = lastsep () in s ++ e
+                   else let s = sep () in s ++ e ++ r
+          in let r = aux t in e ++ r
+  in start
+
+let prlist_strict pr l = prlist_sep_lastsep true mt mt pr l
+(* [prlist_with_sep sep pr [a ; ... ; c]] outputs
+   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
+let prlist_with_sep sep pr l = prlist_sep_lastsep false sep sep pr l
+(* Print sequence of objects separated by space (unless an element is empty) *)
+let pr_sequence pr l = prlist_sep_lastsep true spc spc pr l
+(* [pr_enum pr [a ; b ; ... ; c]] outputs
+   [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
+let pr_enum pr l = prlist_sep_lastsep true pr_comma (fun () -> str " and" ++ spc ()) pr l
+
+let pr_vertical_list pr = function
+  | [] -> str "none" ++ fnl ()
+  | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep fnl pr l) ++ fnl ()
+
+(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs
+   [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *)
+
+let prvecti_with_sep sep elem v =
+  let rec pr i =
+    if Int.equal i 0 then
+      elem 0 v.(0)
+    else
+      let r = pr (i-1) and s = sep () and e = elem i v.(i) in
+      r ++ s ++ e
+  in
+  let n = Array.length v in
+  if Int.equal n 0 then mt () else pr (n - 1)
+
+(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *)
+
+let prvecti elem v = prvecti_with_sep mt elem v
+
+(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs
+   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
+
+let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
+
+(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *)
+
+let prvect elem v = prvect_with_sep mt elem v
+
+let surround p = hov 1 (str"(" ++ p ++ str")")
diff --git a/lib/pp.ml4 b/lib/pp.ml4
deleted file mode 100644
index f13a3d16..00000000
--- a/lib/pp.ml4
+++ /dev/null
@@ -1,351 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp_control
-
-(* This should not be used outside of this file. Use
-   Flags.print_emacs instead. This one is updated when reading
-   command line options. This was the only way to make [Pp] depend on
-   an option without creating a circularity: [Flags. -> [Util] ->
-   [Pp] -> [Flags. *)
-let print_emacs = ref false
-let make_pp_emacs() = print_emacs:=true
-let make_pp_nonemacs() = print_emacs:=false
-
-(* The different kinds of blocks are:
-   \begin{description}
-   \item[hbox:] Horizontal block no line breaking;
-   \item[vbox:] Vertical block each break leads to a new line;
-   \item[hvbox:] Horizontal-vertical block: same as vbox, except if
-      this block is small enough to fit on a single line
-   \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
-      only when necessary to print the content of the block
-   \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
-      (except if no mark yet on the reste of the line)
-   \end{description}
- *)
-
-let comments = ref []
-
-let rec split_com comacc acc pos = function
-    [] -> comments := List.rev acc; comacc
-  | ((b,e),c as com)::coms ->
-      (* Take all comments that terminates before pos, or begin exactly
-         at pos (used to print comments attached after an expression) *)
-      if e<=pos || pos=b then split_com (c::comacc) acc pos coms
-      else  split_com comacc (com::acc) pos coms
-
-
-type block_type =
-  | Pp_hbox of int
-  | Pp_vbox of int
-  | Pp_hvbox of int
-  | Pp_hovbox of int
-  | Pp_tbox
-
-type 'a ppcmd_token =
-  | Ppcmd_print of 'a
-  | Ppcmd_box of block_type * ('a ppcmd_token Stream.t)
-  | Ppcmd_print_break of int * int
-  | Ppcmd_set_tab
-  | Ppcmd_print_tbreak of int * int
-  | Ppcmd_white_space of int
-  | Ppcmd_force_newline
-  | Ppcmd_print_if_broken
-  | Ppcmd_open_box of block_type
-  | Ppcmd_close_box
-  | Ppcmd_close_tbox
-  | Ppcmd_comment of int
-
-type 'a ppdir_token =
-  | Ppdir_ppcmds of 'a ppcmd_token Stream.t
-  | Ppdir_print_newline
-  | Ppdir_print_flush
-
-type ppcmd = (int*string) ppcmd_token
-
-type std_ppcmds = ppcmd Stream.t
-
-type 'a ppdirs = 'a ppdir_token Stream.t
-
-(* Compute length of an UTF-8 encoded string
-   Rem 1 : utf8_length <= String.length (equal if pure ascii)
-   Rem 2 : if used for an iso8859_1 encoded string, the result is
-   wrong in very rare cases. Such a wrong case corresponds to any
-   sequence of a character in range 192..253 immediately followed by a
-   character in range 128..191 (typical case in french is "déçu" which
-   is counted 3 instead of 4); then no real harm to use always
-   utf8_length even if using an iso8859_1 encoding *)
-
-let utf8_length s =
-  let len = String.length s
-  and cnt = ref 0
-  and nc = ref 0
-  and p = ref 0 in
-  while !p < len do
-    begin
-      match s.[!p] with
-      | '\000'..'\127' -> nc := 0 (* ascii char *)
-      | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
-      |	'\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
-      |	'\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
-      |	'\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
-      |	'\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
-      |	'\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
-      |	'\254'..'\255' -> nc := 0 (* invalid byte *)
-    end ;
-    incr p ;
-    while !p < len && !nc > 0 do
-      match s.[!p] with
-      |	'\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
-      |	_ (* not a continuation byte *) -> nc := 0
-    done ;
-    incr cnt
-  done ;
-  !cnt
-
-(* formatting commands *)
-let str s = [< 'Ppcmd_print (utf8_length s,s) >]
-let stras (i,s) = [< 'Ppcmd_print (i,s) >]
-let brk (a,b) = [< 'Ppcmd_print_break (a,b) >]
-let tbrk (a,b) = [< 'Ppcmd_print_tbreak (a,b) >]
-let tab () = [< 'Ppcmd_set_tab >]
-let fnl () = [< 'Ppcmd_force_newline >]
-let pifb () = [< 'Ppcmd_print_if_broken >]
-let ws n = [< 'Ppcmd_white_space n >]
-let comment n = [< ' Ppcmd_comment n >]
-
-(* derived commands *)
-let mt () = [< >]
-let spc () = [< 'Ppcmd_print_break (1,0) >]
-let cut () = [< 'Ppcmd_print_break (0,0) >]
-let align () = [< 'Ppcmd_print_break (0,0) >]
-let int n = str (string_of_int n)
-let real r = str (string_of_float r)
-let bool b = str (string_of_bool b)
-let strbrk s =
-  let rec aux p n =
-    if n < String.length s then
-      if s.[n] = ' ' then
-	if p=n then [< spc (); aux (n+1) (n+1) >]
-	else [< str (String.sub s p (n-p)); spc (); aux (n+1) (n+1) >]
-      else aux p (n+1)
-    else if p=n then [< >] else [< str (String.sub s p (n-p)) >]
-  in aux 0 0
-
-let ismt s = try let _ = Stream.empty s in true with Stream.Failure -> false
-
-(* boxing commands *)
-let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >]
-let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >]
-let hv n s = [< 'Ppcmd_box(Pp_hvbox n,s) >]
-let hov n s = [< 'Ppcmd_box(Pp_hovbox n,s) >]
-let t s = [< 'Ppcmd_box(Pp_tbox,s) >]
-
-(* Opening and closing of boxes *)
-let hb n = [< 'Ppcmd_open_box(Pp_hbox n) >]
-let vb n = [< 'Ppcmd_open_box(Pp_vbox n) >]
-let hvb n = [< 'Ppcmd_open_box(Pp_hvbox n) >]
-let hovb n = [< 'Ppcmd_open_box(Pp_hovbox n) >]
-let tb () = [< 'Ppcmd_open_box Pp_tbox >]
-let close () = [< 'Ppcmd_close_box >]
-let tclose () = [< 'Ppcmd_close_tbox >]
-
-let (++) = Stream.iapp
-
-let rec eval_ppcmds l =
-  let rec aux l =
-    try
-      let a = match Stream.next l with
-      | Ppcmd_box (b,s) -> Ppcmd_box (b,eval_ppcmds s)
-      | a -> a in
-      let rest = aux l in
-      a :: rest
-    with Stream.Failure -> [] in
-  Stream.of_list (aux l)
-
-(* In new syntax only double quote char is escaped by repeating it *)
-let rec escape_string s =
-  let rec escape_at s i =
-    if i<0 then s
-    else if s.[i] == '"' then
-      let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
-      escape_at s' (i-1)
-    else escape_at s (i-1) in
-  escape_at s (String.length s - 1)
-
-let qstring s = str ("\""^escape_string s^"\"")
-let qs = qstring
-let quote s = h 0 (str "\"" ++ s ++ str "\"")
-
-let rec xmlescape ppcmd =
-  let rec escape what withwhat (len, str) =
-    try
-      let pos = String.index str what in
-      let (tlen, tail) =
-        escape what withwhat ((len - pos - 1),
-          (String.sub str (pos + 1) (len - pos - 1)))
-      in
-      (pos + tlen + String.length withwhat, String.sub str 0 pos ^ withwhat ^ tail)
-    with Not_found -> (len, str)
-  in
-  match ppcmd with
-    | Ppcmd_print (len, str) ->
-        Ppcmd_print (escape '"' "&quot;"
-          (escape '<' "&lt;" (escape '&' "&amp;" (len, str))))
-      (* In XML we always print whole content so we can npeek the whole stream *)
-    | Ppcmd_box (x, str) -> Ppcmd_box (x, Stream.of_list
-        (List.map xmlescape (Stream.npeek max_int str)))
-    | x -> x
-
-
-(* This flag tells if the last printed comment ends with a newline, to
-  avoid empty lines *)
-let com_eol = ref false
-
-let com_brk ft = com_eol := false
-let com_if ft f =
-  if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
-  else Lazy.force f
-
-let rec pr_com ft s =
-  let (s1,os) =
-    try
-      let n = String.index s '\n' in
-      String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
-    with Not_found -> s,None in
-  com_if ft (Lazy.lazy_from_val());
-(*  let s1 =
-    if String.length s1 <> 0 && s1.[0] = ' ' then
-      (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
-    else s1 in*)
-  Format.pp_print_as ft (utf8_length s1) s1;
-  match os with
-      Some s2 ->
-        if String.length s2 = 0 then (com_eol := true)
-        else
-          (Format.pp_force_newline ft (); pr_com ft s2)
-    | None -> ()
-
-(* pretty printing functions *)
-let pp_dirs ft =
-  let pp_open_box = function
-    | Pp_hbox n   -> Format.pp_open_hbox ft ()
-    | Pp_vbox n   -> Format.pp_open_vbox ft n
-    | Pp_hvbox n  -> Format.pp_open_hvbox ft n
-    | Pp_hovbox n -> Format.pp_open_hovbox ft n
-    | Pp_tbox     -> Format.pp_open_tbox ft ()
-  in
-  let rec pp_cmd = function
-    | Ppcmd_print(n,s)        ->
-        com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
-    | Ppcmd_box(bty,ss)       -> (* Prevent evaluation of the stream! *)
-        com_if ft (Lazy.lazy_from_val());
-        pp_open_box bty ;
-        if not (Format.over_max_boxes ()) then Stream.iter pp_cmd ss;
-        Format.pp_close_box ft ()
-    | Ppcmd_open_box bty      -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
-    | Ppcmd_close_box         -> Format.pp_close_box ft ()
-    | Ppcmd_close_tbox        -> Format.pp_close_tbox ft ()
-    | Ppcmd_white_space n     ->
-        com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
-    | Ppcmd_print_break(m,n)  ->
-        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
-    | Ppcmd_set_tab           -> Format.pp_set_tab ft ()
-    | Ppcmd_print_tbreak(m,n) ->
-        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
-    | Ppcmd_force_newline     ->
-        com_brk ft; Format.pp_force_newline ft ()
-    | Ppcmd_print_if_broken   ->
-        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
-    | Ppcmd_comment i         ->
-        let coms = split_com [] [] i !comments in
-(*        Format.pp_open_hvbox ft 0;*)
-        List.iter (pr_com ft) coms(*;
-        Format.pp_close_box ft ()*)
-  in
-  let pp_dir = function
-    | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream
-    | Ppdir_print_newline    ->
-        com_brk ft; Format.pp_print_newline ft ()
-    | Ppdir_print_flush      -> Format.pp_print_flush ft ()
-  in
-  fun dirstream ->
-    try
-      Stream.iter pp_dir dirstream; com_brk ft
-    with
-      | reraise -> Format.pp_print_flush ft () ; raise reraise
-
-
-(* pretty print on stdout and stderr *)
-
-(* Special chars for emacs, to detect warnings inside goal output *)
-let emacs_quote_start = String.make 1 (Char.chr 254)
-let emacs_quote_end = String.make 1 (Char.chr 255)
-
-let emacs_quote strm =
-  if !print_emacs then
-    [< str emacs_quote_start; hov 0 strm; str emacs_quote_end >]
-  else hov 0 strm
-
-let warnbody strm = emacs_quote (str "Warning: " ++ strm)
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds strm >]
-
-let ppnl_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds [< strm ; 'Ppcmd_force_newline >] >]
-
-let default_warn_with ft strm = ppnl_with ft (warnbody strm)
-
-let pp_warn_with = ref default_warn_with
-
-let set_warning_function pp_warn = pp_warn_with := pp_warn
-
-let warn_with ft strm = !pp_warn_with ft strm
-
-let warning_with ft string = warn_with ft (str string)
-
-let pp_flush_with ft = Format.pp_print_flush ft
-
-(* pretty printing functions WITH FLUSH *)
-let msg_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_flush >]
-
-let msgnl_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_newline >]
-
-let msg_warning_with ft strm =
-  msgnl_with ft (warnbody strm)
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp        x = pp_with   !std_ft x
-let ppnl      x = ppnl_with !std_ft x
-let pperr     x = pp_with   !err_ft x
-let pperrnl   x = ppnl_with !err_ft x
-let message   s = ppnl      (str s)
-let warning   x = warning_with !err_ft x
-let warn      x = warn_with    !err_ft x
-let pp_flush  x = Format.pp_print_flush !std_ft x
-let flush_all() = flush stderr; flush stdout; pp_flush()
-
-(* pretty printing functions WITH FLUSH *)
-let msg x = msg_with !std_ft x
-let msgnl x = msgnl_with !std_ft x
-let msgerr x = msg_with !err_ft x
-let msgerrnl x = msgnl_with !err_ft x
-let msg_warning x = msg_warning_with !err_ft x
-let msg_warn x = msg_warning (str x)
-
-(* Same specific display in emacs as warning, but without the "Warning:" *)
-let msg_debug x = msgnl (emacs_quote x)
-
-let string_of_ppcmds c =
-  msg_with Format.str_formatter c;
-  Format.flush_str_formatter ()
diff --git a/lib/pp.mli b/lib/pp.mli
index 695bcbc0..5dd2686d 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp_control
-
 (** Modify pretty printing functions behavior for emacs ouput (special
    chars inserted at some places). This function should called once in
    module [Options], that's all. *)
@@ -16,11 +14,9 @@ val make_pp_nonemacs:unit -> unit
 
 (** Pretty-printers. *)
 
-type ppcmd
-
-type std_ppcmds = ppcmd Stream.t
+type std_ppcmds
 
-(** {6 Formatting commands. } *)
+(** {6 Formatting commands} *)
 
 val str  : string -> std_ppcmds
 val stras : int * string -> std_ppcmds
@@ -36,15 +32,24 @@ val ismt : std_ppcmds -> bool
 val comment : int -> std_ppcmds
 val comments : ((int * int) * string) list ref
 
-(** {6 Concatenation. } *)
+(** {6 Manipulation commands} *)
 
-val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+val app : std_ppcmds -> std_ppcmds -> std_ppcmds
+(** Concatenation. *)
 
-(** {6 Evaluation. } *)
+val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+(** Infix alias for [app]. *)
 
 val eval_ppcmds : std_ppcmds -> std_ppcmds
+(** Force computation. *)
+
+val is_empty : std_ppcmds -> bool
+(** Test emptyness. *)
 
-(** {6 Derived commands. } *)
+val rewrite : (string -> string) -> std_ppcmds -> std_ppcmds
+(** [rewrite f pps] applies [f] to all strings that appear in [pps]. *)
+
+(** {6 Derived commands} *)
 
 val spc : unit -> std_ppcmds
 val cut : unit -> std_ppcmds
@@ -57,9 +62,7 @@ val qs : string -> std_ppcmds
 val quote : std_ppcmds -> std_ppcmds
 val strbrk : string -> std_ppcmds
 
-val xmlescape : ppcmd -> ppcmd
-
-(** {6 Boxing commands. } *)
+(** {6 Boxing commands} *)
 
 val h : int -> std_ppcmds -> std_ppcmds
 val v : int -> std_ppcmds -> std_ppcmds
@@ -67,7 +70,7 @@ val hv : int -> std_ppcmds -> std_ppcmds
 val hov : int -> std_ppcmds -> std_ppcmds
 val t : std_ppcmds -> std_ppcmds
 
-(** {6 Opening and closing of boxes. } *)
+(** {6 Opening and closing of boxes} *)
 
 val hb : int -> std_ppcmds
 val vb : int -> std_ppcmds
@@ -77,48 +80,200 @@ val tb : unit -> std_ppcmds
 val close : unit -> std_ppcmds
 val tclose : unit -> std_ppcmds
 
-(** {6 Pretty-printing functions {% \emph{%}without flush{% }%}. } *)
+(** {6 Opening and closing of tags} *)
 
-val pp_with : Format.formatter -> std_ppcmds -> unit
-val ppnl_with : Format.formatter -> std_ppcmds -> unit
-val warning_with : Format.formatter -> string -> unit
-val warn_with : Format.formatter -> std_ppcmds -> unit
-val pp_flush_with : Format.formatter -> unit -> unit
+module Tag :
+sig
+  type t
+  (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *)
 
-val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit
+  type 'a key
+  (** Keys used to inject tags *)
 
-(** {6 Pretty-printing functions {% \emph{%}with flush{% }%}. } *)
+  val create : string -> 'a key
+  (** Create a key with the given name. Two keys cannot share the same name, if
+      ever this is the case this function raises an assertion failure. *)
 
-val msg_with : Format.formatter -> std_ppcmds -> unit
-val msgnl_with : Format.formatter -> std_ppcmds -> unit
+  val inj : 'a -> 'a key -> t
+  (** Inject an object into a tag. *)
+
+  val prj : t -> 'a key -> 'a option
+  (** Project an object from a tag. *)
+end
+
+type tag_handler = Tag.t -> Format.tag
+
+val tag : Tag.t -> std_ppcmds -> std_ppcmds
+val open_tag : Tag.t -> std_ppcmds
+val close_tag : unit -> std_ppcmds
+
+(** {6 Sending messages to the user} *)
+type message_level = Feedback.message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = Feedback.message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+type logger = message_level -> std_ppcmds -> unit
+
+(** {6 output functions}
+
+[msg_notice] do not put any decoration on output by default. If
+possible don't mix it with goal output (prefer msg_info or
+msg_warning) so that interfaces can dispatch outputs easily. Once all
+interfaces use the xml-like protocol this constraint can be
+relaxed. *)
+(* Should we advertise these functions more? Should they be the ONLY
+   allowed way to output something? *)
+
+val msg_info : std_ppcmds -> unit
+(** Message that displays information, usually in verbose mode, such as [Foobar
+    is defined] *)
+
+val msg_notice : std_ppcmds -> unit
+(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *)
+
+val msg_warning : std_ppcmds -> unit
+(** Message indicating that something went wrong, but without serious
+    consequences. *)
+
+val msg_error : std_ppcmds -> unit
+(** Message indicating that something went really wrong, though still
+    recoverable; otherwise an exception would have been raised. *)
+
+val msg_debug : std_ppcmds -> unit
+(** For debugging purposes *)
+
+val std_logger : logger
+(** Standard logging function *)
+
+val set_logger : logger -> unit
+
+val log_via_feedback : unit -> unit
+
+val of_message : message -> Xml_datatype.xml
+val to_message : Xml_datatype.xml -> message
+val is_message : Xml_datatype.xml -> bool
+
+
+(** {6 Feedback sent, even asynchronously, to the user interface} *)
+
+(* This stuff should be available to most of the system, line msg_* above.
+ * But I'm unsure this is the right place, especially for the global edit_id.
+ *
+ * Morally the parser gets a string and an edit_id, and gives back an AST.
+ * Feedbacks during the parsing phase are attached to this edit_id.
+ * The interpreter assignes an exec_id to the ast, and feedbacks happening
+ * during interpretation are attached to the exec_id.
+ * Only one among state_id and edit_id can be provided. *)
+
+val feedback :
+  ?state_id:Feedback.state_id -> ?edit_id:Feedback.edit_id ->
+  ?route:Feedback.route_id -> Feedback.feedback_content -> unit
+
+val set_id_for_feedback :
+  ?route:Feedback.route_id -> Feedback.edit_or_state_id -> unit
+val set_feeder : (Feedback.feedback -> unit) -> unit
+val get_id_for_feedback : unit -> Feedback.edit_or_state_id * Feedback.route_id
+
+(** {6 Utilities} *)
 
+val string_of_ppcmds : std_ppcmds -> string
+
+(** {6 Printing combinators} *)
+
+val pr_comma : unit -> std_ppcmds
+(** Well-spaced comma. *)
+
+val pr_semicolon : unit -> std_ppcmds
+(** Well-spaced semicolon. *)
+
+val pr_bar : unit -> std_ppcmds
+(** Well-spaced pipe bar. *)
+
+val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
+(** Adds a space in front of its argument. *)
+
+val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+(** Inner object preceded with a space if [Some], nothing otherwise. *)
+
+val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+(** Same as [pr_opt] but without the leading space. *)
+
+val pr_nth : int -> std_ppcmds
+(** Ordinal number with the correct suffix (i.e. "st", "nd", "th", etc.). *)
+
+val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Concatenation of the list contents, without any separator.
+
+    Unlike all other functions below, [prlist] works lazily. If a strict
+    behavior is needed, use [prlist_strict] instead. *)
+
+val prlist_strict :  ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Same as [prlist], but strict. *)
+
+val prlist_with_sep :
+   (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** [prlist_with_sep sep pr [a ; ... ; c]] outputs
+    [pr a ++ sep() ++ ... ++ sep() ++ pr c]. *)
+
+val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** As [prlist], but on arrays. *)
+
+val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** Indexed version of [prvect]. *)
+
+val prvect_with_sep :
+   (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** As [prlist_with_sep], but on arrays. *)
+
+val prvecti_with_sep :
+   (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** Indexed version of [prvect_with_sep]. *)
 
-(** {6 ... } *)
-(** The following functions are instances of the previous ones on
-  [std_ft] and [err_ft]. *)
+val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** [pr_enum pr [a ; b ; ... ; c]] outputs
+    [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *)
+
+val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Sequence of objects separated by space (unless an element is empty). *)
+
+val surround : std_ppcmds -> std_ppcmds
+(** Surround with parenthesis. *)
+
+val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
+
+(** {6 Low-level pretty-printing functions {% \emph{%}without flush{% }%}. } *)
+
+val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit
 
 (** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *)
 
+(** These functions are low-level interface to printing and should not be used
+    in usual code. Consider using the [msg_*] function family instead. *)
+
 val pp : std_ppcmds -> unit
 val ppnl : std_ppcmds -> unit
 val pperr : std_ppcmds -> unit
 val pperrnl : std_ppcmds -> unit
-val message : string -> unit       (** = pPNL *)
-val warning : string -> unit
-val warn : std_ppcmds -> unit
+val pperr_flush : unit -> unit
 val pp_flush : unit -> unit
 val flush_all: unit -> unit
 
-(** {6 Pretty-printing functions {% \emph{%}with flush{% }%} on [stdout] and [stderr]. } *)
+(** {6 Deprecated functions} *)
+
+(** DEPRECATED. Do not use in newly written code. *)
+
+val msg_with : Format.formatter -> std_ppcmds -> unit
 
 val msg : std_ppcmds -> unit
 val msgnl : std_ppcmds -> unit
 val msgerr : std_ppcmds -> unit
 val msgerrnl : std_ppcmds -> unit
-val msg_warning : std_ppcmds -> unit
-val msg_warn : string -> unit
-
-(** Same specific display in emacs as warning, but without the "Warning:" **)
-val msg_debug : std_ppcmds -> unit
-
-val string_of_ppcmds : std_ppcmds -> string
+val message : string -> unit       (** = pPNL *)
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index 94fdb881..0d224c03 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -82,6 +82,7 @@ let set_depth_boxes v =
 let get_margin () = Some (Format.pp_get_margin !std_ft ())
 let set_margin v =
   let v = match v with None -> default_margin | Some v -> v in
+  Format.pp_set_margin Format.str_formatter v;
   Format.pp_set_margin !std_ft v;
   Format.pp_set_margin !deep_ft v
 
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index 2c2d00f3..28d2e299 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/lib/predicate.ml b/lib/predicate.ml
index e419aa6e..a60b3dad 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -54,8 +54,8 @@ module Make(Ord: OrderedType) =
     let full = (true,EltSet.empty)
 
     (* assumes the set is infinite *)
-    let is_empty (b,s) = not b & EltSet.is_empty s
-    let is_full (b,s) = b & EltSet.is_empty s
+    let is_empty (b,s) = not b && EltSet.is_empty s
+    let is_full (b,s) = b && EltSet.is_empty s
 
     let mem x (b,s) =
       if b then not (EltSet.mem x s) else EltSet.mem x s
@@ -92,6 +92,6 @@ module Make(Ord: OrderedType) =
         | ((true,_),(false,_)) -> false
 
     let equal (b1,s1) (b2,s2) =
-      b1=b2 & EltSet.equal s1 s2
+      b1=b2 && EltSet.equal s1 s2
 
   end
diff --git a/lib/profile.ml b/lib/profile.ml
index 0e4c2ebf..c55064ca 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -221,7 +221,7 @@ let loops = 10000
 let time_overhead_A_D () =
   let e = create_record () in
   let before = get_time () in
-  for i=1 to loops do
+  for _i = 1 to loops do
     (* This is a copy of profile1 for overhead estimation *)
     let dw = dummy_spent_alloc () in
     match !dummy_stack with [] -> assert false | p::_ ->
@@ -245,7 +245,7 @@ let time_overhead_A_D () =
   done;
   let after = get_time () in
   let beforeloop =  get_time () in
-  for i=1 to loops do () done;
+  for _i = 1 to loops do () done;
   let afterloop = get_time () in
   float_of_int ((after - before) - (afterloop - beforeloop))
   /. float_of_int loops
@@ -253,18 +253,18 @@ let time_overhead_A_D () =
 let time_overhead_B_C () =
   let dummy_x = 0 in
   let before = get_time () in
-  for i=1 to loops do
+  for _i = 1 to loops do
     try
       dummy_last_alloc := get_alloc ();
       let _r = dummy_f dummy_x in
       let _dw = dummy_spent_alloc () in
       let _dt = get_time () in
       ()
-    with e when e <> Sys.Break -> assert false
+    with e when Errors.noncritical e -> assert false
   done;
   let after = get_time () in
   let beforeloop =  get_time () in
-  for i=1 to loops do () done;
+  for _i = 1 to loops do () done;
   let afterloop = get_time () in
   float_of_int ((after - before) - (afterloop - beforeloop))
   /. float_of_int loops
@@ -279,7 +279,7 @@ let format_profile (table, outside, total) =
   Printf.printf
     "%-23s  %9s %9s %10s %10s %10s\n"
     "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls ";
-  let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in
+  let l = List.sort (fun (_,{tottime=p}) (_,{tottime=p'}) -> p' - p) table in
   List.iter (fun (name,e) ->
     Printf.printf
       "%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n"
@@ -352,7 +352,7 @@ let close_profile print =
 let print_profile () = close_profile true
 
 let declare_profile name =
-  if name = "___outside___" or name = "___total___" then
+  if name = "___outside___" || name = "___total___" then
     failwith ("Error: "^name^" is a reserved keyword");
   let e = create_record () in
   prof_table := (name,e)::!prof_table;
@@ -657,80 +657,57 @@ let profile7 e f a b c d g h i =
     last_alloc := get_alloc ();
     raise reraise
 
-(* Some utilities to compute the logical and physical sizes and depth
-   of ML objects *)
-
-let c = ref 0
-let s = ref 0
-let b = ref 0
-let m = ref 0
-
-let rec obj_stats d t =
-  if Obj.is_int t then m := max d !m
-  else if Obj.tag t >= Obj.no_scan_tag then
-    if Obj.tag t = Obj.string_tag then
-      (c := !c + Obj.size t; b := !b + 1; m := max d !m)
-    else if Obj.tag t = Obj.double_tag then
-      (s := !s + 2; b := !b + 1; m := max d !m)
-    else if Obj.tag t = Obj.double_array_tag then
-      (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
-    else (b := !b + 1; m := max d !m)
-  else
-    let n = Obj.size t in
-    s := !s + n; b := !b + 1;
-    block_stats (d + 1) (n - 1) t
-
-and block_stats d i t =
-  if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
-
-let obj_stats a =
-  c := 0; s:= 0; b:= 0; m:= 0;
-  obj_stats 0 (Obj.repr a);
-  (!c, !s + !b, !m)
-
-module H = Hashtbl.Make(
-  struct
-    type t = Obj.t
-    let equal = (==)
-    let hash o = Hashtbl.hash (Obj.magic o : int)
-  end)
-
-let tbl = H.create 13
-
-let rec obj_shared_size s t =
-  if Obj.is_int t then s
-  else if H.mem tbl t then s
-  else begin
-    H.add tbl t ();
-    let n = Obj.size t in
-    if Obj.tag t >= Obj.no_scan_tag then
-      if Obj.tag t = Obj.string_tag then (c := !c + n; s + 1)
-      else if Obj.tag t = Obj.double_tag then s + 3
-      else if Obj.tag t = Obj.double_array_tag then s + 2 * n + 1
-      else s + 1
-    else
-      block_shared_size (s + n + 1) (n - 1) t
-  end
-
-and block_shared_size s i t =
-  if i < 0 then s
-  else block_shared_size (obj_shared_size s (Obj.field t i)) (i-1) t
-
-let obj_shared_size a =
-  H.clear tbl;
-  c := 0;
-  let s = obj_shared_size 0 (Obj.repr a) in
-  (!c, s)
+let profile8 e f a b c d g h i j =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c d g h i j in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with reraise ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise reraise
 
 let print_logical_stats a =
-  let (c, s, d) = obj_stats a in
+  let (c, s, d) = CObj.obj_stats a in
   Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d
 
 let print_stats a =
-  let (c1, s, d) = obj_stats a in
-  let (c2, o) = obj_shared_size a in
-  Printf.printf "Size: %8d (str: %8d) (exp: %10d)  Depth: %6d\n"
-    (o + c2) c2 (s + c1) d
+  let (c1, s, d) = CObj.obj_stats a in
+  let c2 = CObj.size a in
+  Printf.printf "Size: %8d (exp: %10d)  Depth: %6d\n"
+    c2 (s + c1) d
 (*
 let _ = Gc.set { (Gc.get()) with Gc.verbose = 13 }
 *)
diff --git a/lib/profile.mli b/lib/profile.mli
index 1e45ceed..e3221cd2 100644
--- a/lib/profile.mli
+++ b/lib/profile.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -100,6 +100,10 @@ val profile7 :
   profile_key ->
   ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h)
     -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h
+val profile8 :
+  profile_key ->
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i)
+    -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i
 
 
 (** Some utilities to compute the logical and physical sizes and depth
@@ -113,12 +117,3 @@ val print_logical_stats : 'a -> unit
    This function allocates itself a lot (the same order of magnitude
    as the physical size of its argument) *)
 val print_stats : 'a -> unit
-
-(** Return logical size (first for strings, then for not strings),
-   (in words) and depth of its argument 
-   This function allocates itself a lot *)
-val obj_stats : 'a -> int * int * int
-
-(** Return physical size of its argument (string part and rest) 
-   This function allocates itself a lot *)
-val obj_shared_size : 'a -> int * int
diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml
new file mode 100644
index 00000000..f4d7bb7b
--- /dev/null
+++ b/lib/remoteCounter.ml
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type 'a getter = unit -> 'a
+type 'a installer = ('a getter) -> unit
+
+type remote_counters_status = (string * Obj.t) list
+
+let counters : remote_counters_status ref = ref []
+
+let (!!) x = !(!x)
+
+let new_counter ~name a ~incr ~build =
+  assert(not (List.mem_assoc name !counters));
+  let data = ref (ref a) in
+  counters := (name, Obj.repr data) :: !counters;
+  let m = Mutex.create () in
+  let mk_thsafe_getter f () =
+    (* - slaves must use a remote counter getter, not this one! *)
+    (* - in the main process there is a race condition between slave
+         managers (that are threads) and the main thread, hence the mutex *)
+    if Flags.async_proofs_is_worker () then
+      Errors.anomaly(Pp.str"Slave processes must install remote counters");
+    Mutex.lock m; let x = f () in Mutex.unlock m;
+    build x in
+  let getter = ref(mk_thsafe_getter (fun () -> !data := incr !!data; !!data)) in
+  let installer f =
+    if not (Flags.async_proofs_is_worker ()) then
+      Errors.anomaly(Pp.str"Only slave processes can install a remote counter");
+    getter := f in
+  (fun () -> !getter ()), installer
+
+let backup () = !counters
+
+let snapshot () =
+  List.map (fun (n,v) -> n, Obj.repr (ref (ref !!(Obj.obj v)))) !counters
+
+let restore l =
+  List.iter (fun (name, data) ->
+    assert(List.mem_assoc name !counters);
+    let dataref = Obj.obj (List.assoc name !counters) in
+    !dataref := !!(Obj.obj data))
+  l
diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli
new file mode 100644
index 00000000..f3eca418
--- /dev/null
+++ b/lib/remoteCounter.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Remote counters are *global* counters for fresh ids.  In the master/slave
+ * scenario, the slave installs a getter that asks the master for a fresh
+ * value.  In the scenario of a slave that runs after the death of the master
+ * on some marshalled data, a backup of all counters status should be taken and
+ * restored to avoid reusing ids.
+ * Counters cannot be created by threads, they must be created once and forall
+ * as toplevel module declarations. *)
+
+
+type 'a getter = unit -> 'a
+type 'a installer = ('a getter) -> unit
+
+val new_counter : name:string ->
+  'a -> incr:('a -> 'a) -> build:('a -> 'b) -> 'b getter * 'b installer
+
+type remote_counters_status
+val backup : unit -> remote_counters_status
+(* like backup but makes a copy so that further increment does not alter
+ * the snapshot *)
+val snapshot : unit -> remote_counters_status
+val restore : remote_counters_status -> unit
diff --git a/lib/richpp.ml b/lib/richpp.ml
new file mode 100644
index 00000000..745b7d2a
--- /dev/null
+++ b/lib/richpp.ml
@@ -0,0 +1,177 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+type 'annotation located = {
+  annotation : 'annotation option;
+  startpos   : int;
+  endpos     : int
+}
+
+let rich_pp annotate ppcmds =
+  (** First, we use Format to introduce tags inside
+      the pretty-printed document.
+
+      Each inserted tag is a fresh index that we keep in sync with the contents
+      of annotations.
+  *)
+  let annotations = ref [] in
+  let index = ref (-1) in
+  let pp_tag obj =
+    let () = incr index in
+    let () = annotations := obj :: !annotations in
+    string_of_int !index
+  in
+
+  let tagged_pp = Format.(
+
+    (** Warning: The following instructions are valid only if
+        [str_formatter] is not used for another purpose in
+        Pp.pp_with. *)
+
+    let ft = str_formatter in
+
+    (** We reuse {!Format} standard way of producing tags
+        inside pretty-printing. *)
+    pp_set_tags ft true;
+
+    (** The whole output must be a valid document. To that
+        end, we nest the document inside a tag named <pp>. *)
+    pp_open_tag ft "pp";
+
+    (** XML ignores spaces. The problem is that our pretty-printings
+        are based on spaces to indent. To solve that problem, we
+        systematically output non-breakable spaces, which are properly
+        honored by XML.
+
+        To do so, we reconfigure the [str_formatter] temporarily by
+        hijacking the function that output spaces. *)
+    let out, flush, newline, std_spaces =
+      pp_get_all_formatter_output_functions ft ()
+    in
+    let set = pp_set_all_formatter_output_functions ft ~out ~flush ~newline in
+    set ~spaces:(fun k ->
+      for i = 0 to k - 1 do
+        Buffer.add_string stdbuf "&nbsp;"
+      done
+    );
+
+    (** Some characters must be escaped in XML. This is done by the
+        following rewriting of the strings held by pretty-printing
+        commands. *)
+    Pp.(pp_with ~pp_tag ft (rewrite Xml_printer.pcdata_to_string ppcmds));
+
+    (** Insert </pp>. *)
+    pp_close_tag ft ();
+
+    (** Get the final string. *)
+    let output = flush_str_formatter () in
+
+    (** Finalize by restoring the state of the [str_formatter] and the
+        default behavior of Format. By the way, there may be a bug here:
+        there is no {!Format.pp_get_tags} and therefore if the tags flags
+        was already set to true before executing this piece of code, the
+        state of Format is not restored. *)
+    set ~spaces:std_spaces;
+    pp_set_tags ft false;
+    output
+  )
+  in
+  (** Second, we retrieve the final function that relates
+      each tag to an annotation. *)
+  let objs = CArray.rev_of_list !annotations in
+  let get index = annotate objs.(index) in
+
+  (** Third, we parse the resulting string. It is a valid XML
+      document (in the sense of Xml_parser). As blanks are
+      meaningful we deactivate canonicalization in the XML
+      parser. *)
+  let xml_pp =
+    try
+      Xml_parser.(parse ~do_not_canonicalize:true (make (SString tagged_pp)))
+    with Xml_parser.Error e ->
+      Printf.eprintf
+        "Broken invariant (RichPp): \n\
+         The output semi-structured pretty-printing is ill-formed.\n\
+         Please report.\n\
+         %s"
+        (Xml_parser.error e);
+      exit 1
+  in
+
+  (** Fourth, the low-level XML is turned into a high-level
+      semi-structured document that contains a located annotation in
+      every node. During the traversal of the low-level XML document,
+      we build a raw string representation of the pretty-print. *)
+  let rec node buffer = function
+    | Element (index, [], cs) ->
+      let startpos, endpos, cs = children buffer cs in
+      let annotation = try get (int_of_string index) with _ -> None in
+      (Element (index, { annotation; startpos; endpos }, cs), endpos)
+
+    | PCData s ->
+      Buffer.add_string buffer s;
+      (PCData s, Buffer.length buffer)
+
+    | _ ->
+      assert false (* Because of the form of XML produced by Format. *)
+
+  and children buffer cs =
+    let startpos   = Buffer.length buffer in
+    let cs, endpos =
+      List.fold_left (fun (cs, endpos) c ->
+        let c, endpos = node buffer c in
+        (c :: cs, endpos)
+      ) ([], startpos) cs
+    in
+    (startpos, endpos, List.rev cs)
+  in
+  let pp_buffer = Buffer.create 13 in
+  let xml, _ = node pp_buffer xml_pp in
+
+  (** We return the raw pretty-printing and its annotations tree. *)
+  (Buffer.contents pp_buffer, xml)
+
+let annotations_positions xml =
+  let rec node accu = function
+    | Element (_, { annotation = Some annotation; startpos; endpos }, cs) ->
+      children ((annotation, (startpos, endpos)) :: accu) cs
+    | Element (_, _, cs) ->
+      children accu cs
+    | _ ->
+      accu
+  and children accu cs =
+    List.fold_left node accu cs
+  in
+  node [] xml
+
+let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
+  let rec node = function
+    | Element (index, { annotation; startpos; endpos }, cs) ->
+      let attributes =
+        [ "startpos", string_of_int startpos;
+          "endpos", string_of_int endpos
+        ]
+        @ (match annotation with
+          | None -> []
+          | Some annotation -> attributes_of_annotation annotation
+        )
+      in
+      let tag =
+        match annotation with
+          | None -> index
+          | Some annotation -> tag_of_annotation annotation
+      in
+      Element (tag, attributes, List.map node cs)
+    | PCData s ->
+      PCData s
+  in
+  node xml
+
+
diff --git a/lib/richpp.mli b/lib/richpp.mli
new file mode 100644
index 00000000..446ee1a0
--- /dev/null
+++ b/lib/richpp.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module offers semi-structured pretty-printing. *)
+
+(** Each annotation of the semi-structured document refers to the
+    substring it annotates. *)
+type 'annotation located = {
+  annotation : 'annotation option;
+  startpos   : int;
+  endpos     : int
+}
+
+(** [rich_pp get_annotations ppcmds] returns the interpretation
+    of [ppcmds] as a string as well as a semi-structured document
+    that represents (located) annotations of this string.
+    The [get_annotations] function is used to convert tags into the desired
+    annotation. If this function returns [None], then no annotation is put. *)
+val rich_pp :
+  (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds ->
+  string * 'annotation located Xml_datatype.gxml
+
+(** [annotations_positions ssdoc] returns a list associating each
+    annotations with its position in the string from which [ssdoc] is
+    built. *)
+val annotations_positions :
+  'annotation located Xml_datatype.gxml ->
+  ('annotation * (int * int)) list
+
+(** [xml_of_rich_pp ssdoc] returns an XML representation of the
+    semi-structured document [ssdoc]. *)
+val xml_of_rich_pp :
+  ('annotation -> string) ->
+  ('annotation -> (string * string) list) ->
+  'annotation located Xml_datatype.gxml ->
+  Xml_datatype.xml
diff --git a/lib/rtree.ml b/lib/rtree.ml
index cfac6aa4..f395c086 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,17 +8,15 @@
 
 open Util
 
-
 (* Type of regular trees:
    - Param denotes tree variables (like de Bruijn indices)
      the first int is the depth of the occurrence, and the second int
-     is the index in the array of trees introduced at that depth
+     is the index in the array of trees introduced at that depth.
+     Warning: Param's indices both start at 0!
    - Node denotes the usual tree node, labelled with 'a
    - Rec(j,v1..vn) introduces infinite tree. It denotes
      v(j+1) with parameters 0..n-1 replaced by
      Rec(0,v1..vn)..Rec(n-1,v1..vn) respectively.
-     Parameters n and higher denote parameters global to the
-     current Rec node (as usual in de Bruijn binding system)
  *)
 type 'a t =
     Param of int * int
@@ -36,27 +34,26 @@ let rec lift_rtree_rec depth n = function
   | Rec(j,defs) ->
       Rec(j, Array.map (lift_rtree_rec (depth+1) n) defs)
 
-let lift n t = if n=0 then t else lift_rtree_rec 0 n t
+let lift n t = if Int.equal n 0 then t else lift_rtree_rec 0 n t
 
 (* The usual subst operation *)
 let rec subst_rtree_rec depth sub = function
     Param (i,j) as t ->
       if i < depth then t
-      else if i-depth < Array.length sub then
-        lift depth sub.(i-depth).(j)
-      else Param (i-Array.length sub,j)
+      else if i = depth then
+        lift depth (Rec (j, sub))
+      else Param (i - 1, j)
   | Node (l,sons) -> Node (l,Array.map (subst_rtree_rec depth sub) sons)
   | Rec(j,defs) ->
       Rec(j, Array.map (subst_rtree_rec (depth+1) sub) defs)
 
-let subst_rtree sub t = subst_rtree_rec 0 [|sub|] t
+let subst_rtree sub t = subst_rtree_rec 0 sub t
 
 (* To avoid looping, we must check that every body introduces a node
    or a parameter *)
 let rec expand = function
   | Rec(j,defs) ->
-      let sub = Array.init (Array.length defs) (fun i -> Rec(i,defs)) in
-      expand (subst_rtree sub defs.(j))
+      expand (subst_rtree defs defs.(j))
   | t -> t
 
 (* Given a vector of n bodies, builds the n mutual recursive trees.
@@ -65,12 +62,13 @@ let rec expand = function
    directly one of the parameters of depth 0. Some care is taken to
    accept definitions like  rec X=Y and Y=f(X,Y) *)
 let mk_rec defs =
-  let rec check histo d =
-    match expand d with
-        Param(0,j) when List.mem j histo -> failwith "invalid rec call"
-      | Param(0,j) -> check (j::histo) defs.(j)
-      | _ -> () in
-  Array.mapi (fun i d -> check [i] d; Rec(i,defs)) defs
+  let rec check histo d = match expand d with
+  | Param (0, j) ->
+    if Int.Set.mem j histo then failwith "invalid rec call"
+    else check (Int.Set.add j histo) defs.(j)
+  | _ -> ()
+  in
+  Array.mapi (fun i d -> check (Int.Set.singleton i) d; Rec(i,defs)) defs
 (*
 let v(i,j) = lift i (mk_rec_calls(j+1)).(j);;
 let r = (mk_rec[|(mk_rec[|v(1,0)|]).(0)|]).(0);;
@@ -100,69 +98,96 @@ let rec map f t = match t with
   | Node (a,sons) -> Node (f a, Array.map (map f) sons)
   | Rec(j,defs) -> Rec (j, Array.map (map f) defs)
 
-let rec smartmap f t = match t with
+let smartmap f t = match t with
     Param _ -> t
   | Node (a,sons) ->
-      let a'=f a and sons' = Util.array_smartmap (map f) sons in
-	if a'==a && sons'==sons then
-	  t
-	else
-	  Node (a',sons')
+      let a'=f a and sons' = Array.smartmap (map f) sons in
+      if a'==a && sons'==sons then t
+      else Node (a',sons')
   | Rec(j,defs) ->
-      let defs' = Util.array_smartmap (map f) defs in
-	if defs'==defs then
-	  t
-	else
-	  Rec(j,defs')
-
-(* Fixpoint operator on trees:
-   f is the body of the fixpoint. Arguments passed to f are:
-   - a boolean telling if the subtree has already been seen
-   - the current subtree
-   - a function to make recursive calls on subtrees
- *)
-let fold f t =
-  let rec fold histo t =
-    let seen = List.mem t histo in
-    let nhisto = if not seen then t::histo else histo in
-    f seen (expand t) (fold nhisto) in
-  fold [] t
-
-
-(* Tests if a given tree is infinite, i.e. has an branch of infinte length. *)
-let is_infinite t = fold
-  (fun seen t is_inf ->
-    seen ||
-    (match t with
-        Node(_,v) -> array_exists is_inf v
-      | Param _ -> false
-      | _ -> assert false))
-  t
-
-let fold2 f t x =
-  let rec fold histo t x =
-    let seen = List.mem (t,x) histo in
-    let nhisto = if not seen then (t,x)::histo else histo in
-    f seen (expand t) x (fold nhisto) in
-  fold [] t x
-
-let compare_rtree f = fold2
-  (fun seen t1 t2 cmp ->
-    seen ||
-    let b = f t1 t2 in
-    if b < 0 then false
-    else if b > 0 then true
-    else match expand t1, expand t2 with
-        Node(_,v1), Node(_,v2) when Array.length v1 = Array.length v2 ->
-          array_for_all2 cmp v1 v2
-      | _ -> false)
-
-let eq_rtree cmp t1 t2 =
-  t1 == t2 || t1=t2 ||
-  compare_rtree
-    (fun t1 t2 ->
-      if cmp (fst(dest_node t1)) (fst(dest_node t2)) then 0
-      else (-1)) t1 t2
+      let defs' = Array.smartmap (map f) defs in
+      if defs'==defs then t
+      else Rec(j,defs')
+
+(** Structural equality test, parametrized by an equality on elements *)
+
+let rec raw_eq cmp t t' = match t, t' with
+  | Param (i,j), Param (i',j') -> Int.equal i i' && Int.equal j j'
+  | Node (x, a), Node (x', a') -> cmp x x' && Array.equal (raw_eq cmp) a a'
+  | Rec (i, a), Rec (i', a') -> Int.equal i i' && Array.equal (raw_eq cmp) a a'
+  | _ -> false
+
+let raw_eq2 cmp (t,u) (t',u') = raw_eq cmp t t' && raw_eq cmp u u'
+
+(** Equivalence test on expanded trees. It is parametrized by two
+    equalities on elements:
+    - [cmp] is used when checking for already seen trees
+    - [cmp'] is used when comparing node labels. *)
+
+let equiv cmp cmp' =
+  let rec compare histo t t' =
+    List.mem_f (raw_eq2 cmp) (t,t') histo ||
+    match expand t, expand t' with
+    | Node(x,v), Node(x',v') ->
+        cmp' x x' &&
+        Int.equal (Array.length v) (Array.length v') &&
+        Array.for_all2 (compare ((t,t')::histo)) v v'
+    | _ -> false
+  in compare []
+
+(** The main comparison on rtree tries first physical equality, then
+    the structural one, then the logical equivalence *)
+
+let equal cmp t t' =
+  t == t' || raw_eq cmp t t' || equiv cmp cmp t t'
+
+(** Deprecated alias *)
+let eq_rtree = equal
+
+(** Intersection of rtrees of same arity *)
+let rec inter cmp interlbl def n histo t t' =
+  try
+    let (i,j) = List.assoc_f (raw_eq2 cmp) (t,t') histo in
+    Param (n-i-1,j)
+  with Not_found ->
+  match t, t' with
+  | Param (i,j), Param (i',j') ->
+      assert (Int.equal i i' && Int.equal j j'); t
+  | Node (x, a), Node (x', a') ->
+      (match interlbl x x' with
+      | None -> mk_node def [||]
+      | Some x'' -> Node (x'', Array.map2 (inter cmp interlbl def n histo) a a'))
+  | Rec (i,v), Rec (i',v') ->
+     (* If possible, we preserve the shape of input trees *)
+     if Int.equal i i' && Int.equal (Array.length v) (Array.length v') then
+       let histo = ((t,t'),(n,i))::histo in
+       Rec(i, Array.map2 (inter cmp interlbl def (n+1) histo) v v')
+     else
+     (* Otherwise, mutually recursive trees are transformed into nested trees *)
+       let histo = ((t,t'),(n,0))::histo in
+       Rec(0, [|inter cmp interlbl def (n+1) histo (expand t) (expand t')|])
+  | Rec _, _ -> inter cmp interlbl def n histo (expand t) t'
+  | _ , Rec _ -> inter cmp interlbl def n histo t (expand t')
+  | _ -> assert false
+
+let inter cmp interlbl def t t' = inter cmp interlbl def 0 [] t t'
+
+(** Inclusion of rtrees. We may want a more efficient implementation. *)
+let incl cmp interlbl def t t' =
+  equal cmp t (inter cmp interlbl def t t')
+
+(** Tests if a given tree is infinite, i.e. has a branch of infinite length.
+   This corresponds to a cycle when visiting the expanded tree.
+   We use a specific comparison to detect already seen trees. *)
+
+let is_infinite cmp t =
+  let rec is_inf histo t =
+    List.mem_f (raw_eq cmp) t histo ||
+    match expand t with
+    | Node (_,v) -> Array.exists (is_inf (t::histo)) v
+    | _ -> false
+  in
+  is_inf [] t
 
 (* Pretty-print a tree (not so pretty) *)
 open Pp
@@ -173,11 +198,11 @@ let rec pp_tree prl t =
     | Node(lab,[||]) -> hov 2 (str"("++prl lab++str")")
     | Node(lab,v) ->
         hov 2 (str"("++prl lab++str","++brk(1,0)++
-               Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str")")
+               prvect_with_sep pr_comma (pp_tree prl) v++str")")
     | Rec(i,v) ->
-        if Array.length v = 0 then str"Rec{}"
-        else if Array.length v = 1 then
+        if Int.equal (Array.length v) 0 then str"Rec{}"
+        else if Int.equal (Array.length v) 1 then
           hov 2 (str"Rec{"++pp_tree prl v.(0)++str"}")
         else
           hov 2 (str"Rec{"++int i++str","++brk(1,0)++
-                 Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str"}")
+                 prvect_with_sep pr_comma (pp_tree prl) v++str"}")
diff --git a/lib/rtree.mli b/lib/rtree.mli
index 8b12fee1..0b9424b8 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Type of regular tree with nodes labelled by values of type 'a 
+(** Type of regular tree with nodes labelled by values of type 'a
    The implementation uses de Bruijn indices, so binding capture
    is avoided by the lift operator (see example below) *)
 type 'a t
@@ -49,22 +49,26 @@ val dest_node  : 'a t -> 'a * 'a t array
 (** dest_param is not needed for closed trees (i.e. with no free variable) *)
 val dest_param : 'a t -> int * int
 
-(** Tells if a tree has an infinite branch *)
-val is_infinite : 'a t -> bool
-
-(** [compare_rtree f t1 t2] compares t1 t2 (top-down).
-   f is called on each node: if the result is negative then the
-   traversal ends on false, it is is positive then deeper nodes are
-   not examined, and the traversal continues on respective siblings,
-   and if it is 0, then the traversal continues on sons, pairwise.
-   In this latter case, if the nodes do not have the same number of
-   sons, then the traversal ends on false.
-   In case of loop, the traversal is successful and it resumes on
-   siblings.
- *)
-val compare_rtree : ('a t -> 'b t -> int) -> 'a t -> 'b t -> bool
+(** Tells if a tree has an infinite branch. The first arg is a comparison
+    used to detect already seen elements, hence loops *)
+val is_infinite : ('a -> 'a -> bool) -> 'a t -> bool
 
-val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+(** [Rtree.equiv eq eqlab t1 t2] compares t1 t2 (top-down).
+   If t1 and t2 are both nodes, [eqlab] is called on their labels,
+   in case of success deeper nodes are examined.
+   In case of loop (detected via structural equality parametrized
+   by [eq]), then the comparison is successful. *)
+val equiv :
+  ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+(** [Rtree.equal eq t1 t2] compares t1 and t2, first via physical
+    equality, then by structural equality (using [eq] on elements),
+    then by logical equivalence [Rtree.equiv eq eq] *)
+val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+val inter : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> 'a t
+
+val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> bool
 
 (** Iterators *)
 
@@ -72,9 +76,9 @@ val map : ('a -> 'b) -> 'a t -> 'b t
 
 (** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *)
 val smartmap : ('a -> 'a) -> 'a t -> 'a t
-val fold : (bool -> 'a t -> ('a t -> 'b) -> 'b) -> 'a t -> 'b
-val fold2 :
-  (bool -> 'a t -> 'b -> ('a t -> 'b -> 'c) -> 'c) -> 'a t -> 'b -> 'c
 
 (** A rather simple minded pretty-printer *)
 val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+
+val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+(** @deprecated Same as [Rtree.equal] *)
diff --git a/lib/serialize.ml b/lib/serialize.ml
new file mode 100644
index 00000000..aa2e3f02
--- /dev/null
+++ b/lib/serialize.ml
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+exception Marshal_error
+
+(** Utility functions *)
+
+let rec get_attr attr = function
+  | [] -> raise Not_found
+  | (k, v) :: l when CString.equal k attr -> v
+  | _ :: l -> get_attr attr l
+
+let massoc x l =
+  try get_attr x l
+  with Not_found -> raise Marshal_error
+
+let constructor t c args = Element (t, ["val", c], args)
+let do_match t mf = function
+  | Element (s, attrs, args) when CString.equal s t ->
+      let c = massoc "val" attrs in
+      mf c args
+  | _ -> raise Marshal_error
+
+let singleton = function
+  | [x] -> x
+  | _ -> raise Marshal_error
+
+let raw_string = function
+  | [] -> ""
+  | [PCData s] -> s
+  | _ -> raise Marshal_error
+
+(** Base types *)
+
+let of_unit () = Element ("unit", [], [])
+let to_unit : xml -> unit = function
+  | Element ("unit", [], []) -> ()
+  | _ -> raise Marshal_error
+
+let of_bool (b : bool) : xml =
+  if b then constructor "bool" "true" []
+  else constructor "bool" "false" []
+let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with
+  | "true" -> true
+  | "false" -> false
+  | _ -> raise Marshal_error)
+
+let of_list (f : 'a -> xml) (l : 'a list) =
+  Element ("list", [], List.map f l)
+let to_list (f : xml -> 'a) : xml -> 'a list = function
+  | Element ("list", [], l) -> List.map f l
+  | _ -> raise Marshal_error
+
+let of_option (f : 'a -> xml) : 'a option -> xml = function
+  | None -> Element ("option", ["val", "none"], [])
+  | Some x -> Element ("option", ["val", "some"], [f x])
+let to_option (f : xml -> 'a) : xml -> 'a option = function
+  | Element ("option", ["val", "none"], []) -> None
+  | Element ("option", ["val", "some"], [x]) -> Some (f x)
+  | _ -> raise Marshal_error
+
+let of_string (s : string) : xml = Element ("string", [], [PCData s])
+let to_string : xml -> string = function
+  | Element ("string", [], l) -> raw_string l
+  | _ -> raise Marshal_error
+
+let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)])
+let to_int : xml -> int = function
+  | Element ("int", [], [PCData s]) ->
+    (try int_of_string s with Failure _ -> raise Marshal_error)
+  | _ -> raise Marshal_error
+
+let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml =
+  Element ("pair", [], [f (fst x); g (snd x)])
+let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function
+  | Element ("pair", [], [x; y]) -> (f x, g y)
+  | _ -> raise Marshal_error
+
+let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function
+  | CSig.Inl x -> Element ("union", ["val","in_l"], [f x])
+  | CSig.Inr x -> Element ("union", ["val","in_r"], [g x])
+let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function
+  | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x)
+  | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x)
+  | _ -> raise Marshal_error
+
+(** More elaborate types *)
+
+let of_edit_id i = Element ("edit_id",["val",string_of_int i],[])
+let to_edit_id = function
+  | Element ("edit_id",["val",i],[]) ->
+      let id = int_of_string i in
+      assert (id <= 0 );
+      id
+  | _ -> raise Marshal_error
+
+let of_loc loc =
+  let start, stop = Loc.unloc loc in
+  Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[])
+let to_loc xml =
+  match xml with
+  | Element ("loc", l,[]) ->
+      (try
+        let start = massoc "start" l in
+        let stop = massoc "stop" l in
+        Loc.make_loc (int_of_string start, int_of_string stop)
+      with Not_found | Invalid_argument _ -> raise Marshal_error)
+  | _ -> raise Marshal_error
+
diff --git a/lib/serialize.mli b/lib/serialize.mli
new file mode 100644
index 00000000..34d3e054
--- /dev/null
+++ b/lib/serialize.mli
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+exception Marshal_error
+
+val massoc: string -> (string * string) list -> string
+val constructor: string -> string -> xml list -> xml
+val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b
+val singleton: 'a list -> 'a
+val raw_string: xml list -> string
+val of_unit: unit -> xml
+val to_unit: xml -> unit
+val of_bool: bool -> xml
+val to_bool: xml -> bool
+val of_list: ('a -> xml) -> 'a list -> xml
+val to_list: (xml -> 'a) -> xml -> 'a list
+val of_option: ('a -> xml) -> 'a option -> xml
+val to_option: (xml -> 'a) -> xml -> 'a option
+val of_string: string -> xml
+val to_string: xml -> string
+val of_int: int -> xml
+val to_int: xml -> int
+val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml
+val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b
+val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml
+val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union
+val of_edit_id: int -> xml
+val to_edit_id: xml -> int
+val of_loc : Loc.t -> xml
+val to_loc : xml -> Loc.t
diff --git a/lib/spawn.ml b/lib/spawn.ml
new file mode 100644
index 00000000..9b63be70
--- /dev/null
+++ b/lib/spawn.ml
@@ -0,0 +1,258 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+let proto_version = 0
+let prefer_sock = Sys.os_type = "Win32"
+let accept_timeout = 2.0
+
+let pr_err s = Printf.eprintf "(Spawn  ,%d) %s\n%!" (Unix.getpid ()) s
+let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+
+type req = ReqDie | ReqStats | Hello of int * int
+type resp = RespStats of Gc.stat
+
+module type Control = sig
+  type handle
+
+  val kill : handle -> unit
+  val stats : handle -> Gc.stat
+  val wait : handle -> Unix.process_status
+  val unixpid : handle -> int
+  val uid : handle -> string
+  val is_alive : handle -> bool
+
+end
+
+module type Empty = sig end
+
+module type MainLoopModel = sig
+  type async_chan
+  type condition
+  type watch_id
+
+  val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id
+  val remove_watch : watch_id -> unit
+  val read_all : async_chan -> string
+  val async_chan_of_file : Unix.file_descr -> async_chan
+  val async_chan_of_socket : Unix.file_descr -> async_chan
+end
+
+(* Common code *)
+let assert_ b s = if not b then Errors.anomaly (Pp.str s)
+
+let mk_socket_channel () =
+  let open Unix in
+  let s = socket PF_INET SOCK_STREAM 0 in
+  bind s (ADDR_INET (inet_addr_loopback,0));
+  listen s 1;
+  match getsockname s with
+  | ADDR_INET(host, port) ->
+      s, string_of_inet_addr host ^":"^ string_of_int port
+  | _ -> assert false
+
+let accept s =
+  let r, _, _ = Unix.select [s] [] [] accept_timeout in
+  if r = [] then raise (Failure (Printf.sprintf
+    "The spawned process did not connect back in %2.1fs" accept_timeout));
+  let cs, _ = Unix.accept s in
+  Unix.close s;
+  let cin, cout = Unix.in_channel_of_descr cs, Unix.out_channel_of_descr cs in
+  set_binary_mode_in cin true;
+  set_binary_mode_out cout true;
+  cs, cin, cout
+
+let handshake cin cout =
+  try
+    output_value cout (Hello (proto_version,Unix.getpid ())); flush cout;
+    match input_value cin with
+    | Hello(v, pid) when v = proto_version ->
+        prerr_endline (Printf.sprintf "Handshake with %d OK" pid);
+        pid
+    | _ -> raise (Failure "handshake protocol")
+  with
+  | Failure s | Invalid_argument s | Sys_error s ->
+      pr_err ("Handshake failed: "  ^ s); raise (Failure "handshake")
+  | End_of_file ->
+      pr_err "Handshake failed: End_of_file"; raise (Failure "handshake")
+
+let spawn_sock env prog args =
+  let main_sock, main_sock_name = mk_socket_channel () in
+  let extra = [| prog; "-main-channel"; main_sock_name |] in
+  let args = Array.append extra args in
+  prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args));
+  let pid =
+    Unix.create_process_env prog args env Unix.stdin Unix.stdout Unix.stderr in
+  if pid = 0 then begin
+    Unix.sleep 1; (* to avoid respawning like crazy *)
+    raise (Failure "create_process failed")
+  end;
+  let cs, cin, cout = accept main_sock in
+  pid, cin, cout, cs
+
+let spawn_pipe env prog args =
+  let master2worker_r,master2worker_w = Unix.pipe () in
+  let worker2master_r,worker2master_w = Unix.pipe () in
+  let extra = [| prog; "-main-channel"; "stdfds" |] in
+  let args = Array.append extra args in
+  Unix.set_close_on_exec master2worker_w;
+  Unix.set_close_on_exec worker2master_r;
+  prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args));
+  let pid =
+    Unix.create_process_env
+      prog args env master2worker_r worker2master_w Unix.stderr in
+  if pid = 0 then begin
+    Unix.sleep 1; (* to avoid respawning like crazy *)
+    raise (Failure "create_process failed")
+  end;
+  prerr_endline ("PID " ^ string_of_int pid);
+  Unix.close master2worker_r;
+  Unix.close worker2master_w;
+  let cin = Unix.in_channel_of_descr worker2master_r in
+  let cout = Unix.out_channel_of_descr master2worker_w in
+  set_binary_mode_in cin true;
+  set_binary_mode_out cout true;
+  pid, cin, cout, worker2master_r
+
+let filter_args args =
+  let rec aux = function
+    | "-control-channel" :: _ :: rest -> aux rest
+    | "-main-channel" :: _ :: rest -> aux rest
+    | x :: rest -> x :: aux rest
+    | [] -> [] in
+  Array.of_list (aux (Array.to_list args))
+
+let spawn_with_control prefer_sock env prog args =
+  let control_sock, control_sock_name = mk_socket_channel () in
+  let extra = [| "-control-channel"; control_sock_name |] in
+  let args = Array.append extra (filter_args args) in
+  let (pid, cin, cout, s), is_sock =
+    if Sys.os_type <> "Unix" || prefer_sock
+    then spawn_sock env prog args, true
+    else spawn_pipe env prog args, false in
+  let _, oob_resp, oob_req = accept control_sock in
+  pid, oob_resp, oob_req, cin, cout, s, is_sock
+
+let output_death_sentence pid oob_req =
+  prerr_endline ("death sentence for " ^ pid);
+  try output_value oob_req ReqDie; flush oob_req
+  with e -> prerr_endline ("death sentence: " ^ Printexc.to_string e)
+
+(* spawn a process and read its output asynchronously *)
+module Async(ML : MainLoopModel) = struct
+
+type process = {
+  cin  : in_channel;
+  cout : out_channel;
+  oob_resp : in_channel;
+  oob_req  : out_channel;
+  gchan : ML.async_chan;
+  pid : int;
+  mutable watch : ML.watch_id option;
+  mutable alive : bool;
+}
+
+type callback = ML.condition list -> read_all:(unit -> string) -> bool
+type handle = process
+
+let is_alive p = p.alive
+let uid { pid; } = string_of_int pid
+let unixpid { pid; } = pid
+
+let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) =
+  p.alive <- false;
+  if not alive then prerr_endline "This process is already dead"
+  else begin try
+    Option.iter ML.remove_watch watch;
+    output_death_sentence (uid p) oob_req;
+    close_in_noerr cin;
+    close_out_noerr cout;
+    if Sys.os_type = "Unix" then Unix.kill unixpid 9;
+    p.watch <- None
+  with e -> prerr_endline ("kill: "^Printexc.to_string e) end
+
+let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ())
+    prog args callback
+=
+  let pid, oob_resp, oob_req, cin, cout, main, is_sock =
+    spawn_with_control prefer_sock env prog args in
+  Unix.set_nonblock main;
+  let gchan =
+    if is_sock then ML.async_chan_of_socket main
+    else ML.async_chan_of_file main in
+  let alive, watch = true, None in
+  let p = { cin; cout; gchan; pid; oob_resp; oob_req; alive; watch } in
+  p.watch <- Some (
+    ML.add_watch ~callback:(fun cl ->
+      try
+        let live = callback cl ~read_all:(fun () -> ML.read_all gchan) in
+        if not live then kill p;
+        live
+      with e when Errors.noncritical e ->
+        pr_err ("Async reader raised: " ^ (Printexc.to_string e));
+        kill p;
+        false) gchan
+  );
+  p, cout
+
+let stats { oob_req; oob_resp; alive } =
+  assert_ alive "This process is dead";
+  output_value oob_req ReqStats;
+  flush oob_req;
+  input_value oob_resp
+
+let rec wait p =
+  try snd (Unix.waitpid [] p.pid)
+  with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> wait p
+  | Unix.Unix_error _ -> Unix.WEXITED 0o400
+
+end
+
+module Sync(T : Empty) = struct
+
+type process = {
+  cin  : in_channel;
+  cout : out_channel;
+  oob_resp : in_channel;
+  oob_req  : out_channel;
+  pid : int;
+  mutable alive : bool;
+}
+
+type handle = process
+
+let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) prog args =
+  let pid, oob_resp, oob_req, cin, cout, _, _ =
+    spawn_with_control prefer_sock env prog args in
+  { cin; cout; pid; oob_resp; oob_req; alive = true }, cin, cout
+
+let is_alive p = p.alive
+let uid { pid; } = string_of_int pid
+let unixpid { pid = pid; } = pid
+
+let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) =
+  p.alive <- false;
+  if not alive then prerr_endline "This process is already dead"
+  else begin try
+    output_death_sentence (uid p) oob_req;
+    close_in_noerr cin;
+    close_out_noerr cout;
+    if Sys.os_type = "Unix" then Unix.kill unixpid 9;
+  with e -> prerr_endline ("kill: "^Printexc.to_string e) end
+
+let stats { oob_req; oob_resp; alive } =
+  assert_ alive "This process is dead";
+  output_value oob_req ReqStats;
+  flush oob_req;
+  let RespStats g = input_value oob_resp in g
+
+let wait { pid = unixpid } =
+  try snd (Unix.waitpid [] unixpid)
+  with Unix.Unix_error _ -> Unix.WEXITED 0o400
+
+end
diff --git a/lib/spawn.mli b/lib/spawn.mli
new file mode 100644
index 00000000..8022573b
--- /dev/null
+++ b/lib/spawn.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* This module implements spawning/killing managed processes with a
+ * synchronous or asynchronous comunication channel that works with
+ * threads or with a glib like main loop model.
+ *
+ * This module requires no threads and no main loop model.  It takes care
+ * of using the fastest communication channel given the underlying OS and
+ * the requested kind of communication.
+ *
+ * The spawned process must use the Spawned module to init its communication
+ * channels.
+ *)
+
+(* This is the control panel for managed processes *)
+module type Control = sig
+  type handle
+
+  val kill : handle -> unit
+  val stats : handle -> Gc.stat
+  val wait : handle -> Unix.process_status
+  val unixpid : handle -> int
+  
+  (* What is used in debug messages *)
+  val uid : handle -> string
+
+  val is_alive : handle -> bool
+end
+
+(* Abstraction to work with both threads and main loop models *)
+module type Empty = sig end
+
+module type MainLoopModel = sig
+  type async_chan
+  type condition
+  type watch_id
+
+  val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id
+  val remove_watch : watch_id -> unit
+  val read_all : async_chan -> string
+  val async_chan_of_file : Unix.file_descr -> async_chan
+  val async_chan_of_socket : Unix.file_descr -> async_chan
+end
+
+(* spawn a process and read its output asynchronously *)
+module Async(ML : MainLoopModel) : sig
+  type process
+
+  (* If the returned value is false the callback is never called again and
+   * the process is killed *)
+  type callback = ML.condition list -> read_all:(unit -> string) -> bool
+  
+  val spawn :
+    ?prefer_sock:bool -> ?env:string array -> string -> string array ->
+      callback -> process * out_channel
+
+  include Control with type handle = process
+end
+
+(* spawn a process and read its output synchronously *)
+module Sync(T : Empty) : sig
+  type process
+  
+  val spawn :
+    ?prefer_sock:bool -> ?env:string array -> string -> string array ->
+      process * in_channel * out_channel
+
+  include Control with type handle = process
+end
+
+(* This is exported to separate the Spawned module, that for simplicity assumes
+ * Threads so it is in a separate file *)
+type req = ReqDie | ReqStats | Hello of int * int
+val proto_version : int
+type resp = RespStats of Gc.stat
diff --git a/lib/stateid.ml b/lib/stateid.ml
new file mode 100644
index 00000000..59cf206e
--- /dev/null
+++ b/lib/stateid.ml
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+type t = int
+let initial = 1
+let dummy = 0
+let fresh, in_range =
+  let cur = ref initial in
+  (fun () -> incr cur; !cur), (fun id -> id >= 0 && id <= !cur)
+let to_string = string_of_int
+let of_int id = assert(in_range id); id
+let to_int id = id
+let newer_than id1 id2 = id1 > id2
+
+let of_xml = function
+  | Element ("state_id",["val",i],[]) ->
+      let id = int_of_string i in
+      (* Coqide too to parse ids too, but cannot check if they are valid.
+       * Hence we check for validity only if we are an ide slave. *)
+      if !Flags.ide_slave then assert(in_range id);
+      id
+  | _ -> raise (Invalid_argument "to_state_id")
+let to_xml i = Element ("state_id",["val",string_of_int i],[])
+
+let state_id_info : (t * t) Exninfo.t = Exninfo.make ()
+let add exn ?(valid = initial) id =
+  Exninfo.add exn state_id_info (valid, id)
+let get exn = Exninfo.get exn state_id_info
+
+let equal = Int.equal
+let compare = Int.compare
+
+module Set = Set.Make(struct type t = int let compare = compare end)
+
+type ('a,'b) request = {
+  exn_info : t * t;
+  stop : t;
+  document : 'b;
+  loc : Loc.t;
+  uuid     : 'a;
+  name     : string
+}
+
diff --git a/lib/stateid.mli b/lib/stateid.mli
new file mode 100644
index 00000000..2c12c30c
--- /dev/null
+++ b/lib/stateid.mli
@@ -0,0 +1,45 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+type t
+
+val equal : t -> t -> bool
+val compare : t -> t -> int
+
+module Set : Set.S with type elt = t
+
+val initial : t
+val dummy : t
+val fresh : unit -> t
+val to_string : t -> string
+val of_int : int -> t
+val to_int : t -> int
+val newer_than : t -> t -> bool
+
+(* XML marshalling *)
+val to_xml : t -> xml
+val of_xml : xml -> t
+
+(* Attaches to an exception the concerned state id, plus an optional
+ * state id that is a valid state id before the error.
+ * Backtracking to the valid id is safe.
+ * The initial_state_id is assumed to be safe. *)
+val add : Exninfo.info -> ?valid:t -> t -> Exninfo.info
+val get : Exninfo.info -> (t * t) option
+
+type ('a,'b) request = {
+  exn_info : t * t;
+  stop : t;
+  document : 'b;
+  loc : Loc.t;
+  uuid     : 'a;
+  name     : string
+}
+
diff --git a/lib/store.ml b/lib/store.ml
index 28eb65c8..a1788f7d 100644
--- a/lib/store.ml
+++ b/lib/store.ml
@@ -6,56 +6,86 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*** This module implements an "untyped store", in this particular case we
-        see it as an extensible record whose fields are left unspecified. ***)
+(** This module implements an "untyped store", in this particular case
+    we see it as an extensible record whose fields are left
+    unspecified. ***)
 
-(* We give a short implementation of a universal type. This is mostly equivalent
-    to what is proposed by module Dyn.ml, except that it requires no explicit tag. *)
-module type Universal = sig
-  type t
-  
-  type 'a etype = {
-     put : 'a -> t ;
-     get : t -> 'a option
-  }
+(** We use a dynamic "name" allocator. But if we needed to serialise
+    stores, we might want something static to avoid troubles with
+    plugins order. *)
 
-  val embed : unit -> 'a etype
+module type T =
+sig
 end
 
-(* We use a dynamic "name" allocator. But if we needed to serialise stores, we
-might want something static to avoid troubles with plugins order. *)
+module type S =
+sig
+  type t
+  type 'a field
+  val empty : t
+  val set : t -> 'a field -> 'a -> t
+  val get : t -> 'a field -> 'a option
+  val remove : t -> 'a field -> t
+  val merge : t -> t -> t
+  val field : unit -> 'a field
+end
 
-let next =
-  let count = ref 0 in fun () ->
-  let n = !count in
-  incr count;
-  n
+module Make (M : T) : S =
+struct
 
-type t = Obj.t Util.Intmap.t
+  let next =
+    let count = ref 0 in fun () ->
+      let n = !count in
+      incr count;
+      n
 
-module Field = struct
-  type 'a field = {
-    set : 'a -> t -> t ;
-    get : t -> 'a option ;
-    remove : t -> t 
-  }
-  type 'a t = 'a field
-end
+  type t = Obj.t option array
+  (** Store are represented as arrays. For small values, which is typicial,
+      is slightly quicker than other implementations. *)
+
+type 'a field = int
+
+let allocate len : t = Array.make len None
+
+let empty : t = [||]
 
-open Field
-
-let empty = Util.Intmap.empty
-
-let field () =
-  let fid = next () in
-  let set a s =
-    Util.Intmap.add fid (Obj.repr a) s
-  in
-  let get s =
-    try Some (Obj.obj (Util.Intmap.find fid s))
-    with Not_found -> None
-  in
-  let remove s =
-    Util.Intmap.remove fid s
-  in
-  { set = set ; get = get ; remove = remove }
+let set (s : t) (i : 'a field) (v : 'a) : t =
+  let len = Array.length s in
+  let nlen = if i < len then len else succ i in
+  let () = assert (0 <= i) in
+  let ans = allocate nlen in
+  Array.blit s 0 ans 0 len;
+  Array.unsafe_set ans i (Some (Obj.repr v));
+  ans
+
+let get (s : t) (i : 'a field) : 'a option =
+  let len = Array.length s in
+  if len <= i then None
+  else Obj.magic (Array.unsafe_get s i)
+
+let remove (s : t) (i : 'a field) =
+  let len = Array.length s in
+  let () = assert (0 <= i) in
+  let ans = allocate len in
+  Array.blit s 0 ans 0 len;
+  if i < len then Array.unsafe_set ans i None;
+  ans
+
+let merge (s1 : t) (s2 : t) : t =
+  let len1 = Array.length s1 in
+  let len2 = Array.length s2 in
+  let nlen = if len1 < len2 then len2 else len1 in
+  let ans = allocate nlen in
+  (** Important: No more allocation from here. *)
+  Array.blit s2 0 ans 0 len2;
+  for i = 0 to pred len1 do
+    let v = Array.unsafe_get s1 i in
+    match v with
+    | None -> ()
+    | Some _ -> Array.unsafe_set ans i v
+  done;
+  ans
+
+let field () = next ()
+
+end
diff --git a/lib/store.mli b/lib/store.mli
index 5df0c99a..8eab314e 100644
--- a/lib/store.mli
+++ b/lib/store.mli
@@ -9,17 +9,38 @@
 (*** This module implements an "untyped store", in this particular case we
         see it as an extensible record whose fields are left unspecified. ***)
 
-type t
-
-module Field : sig
-  type 'a field = {
-    set : 'a -> t -> t ;
-    get : t -> 'a option ;
-    remove : t -> t 
-  }
-  type 'a t = 'a field
+module type T =
+sig
+(** FIXME: Waiting for first-class modules... *)
 end
 
-val empty : t
+module type S =
+sig
+  type t
+  (** Type of stores *)
 
-val field : unit -> 'a Field.field
+  type 'a field
+  (** Type of field of such stores *)
+
+  val empty : t
+  (** Empty store *)
+
+  val set : t -> 'a field -> 'a -> t
+  (** Set a field *)
+
+  val get : t -> 'a field -> 'a option
+  (** Get the value of a field, if any *)
+
+  val remove : t -> 'a field -> t
+  (** Unset the value of the field *)
+
+  val merge : t -> t -> t
+  (** [merge s1 s2] adds all the fields of [s1] into [s2]. *)
+
+  val field : unit -> 'a field
+  (** Create a new field *)
+
+end
+
+module Make (M : T) : S
+(** Create a new store type. *)
diff --git a/lib/system.ml b/lib/system.ml
index 8f436366..73095f9c 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,126 +9,10 @@
 (* $Id$ *)
 
 open Pp
+open Errors
 open Util
 open Unix
 
-(* Expanding shell variables and home-directories *)
-
-let safe_getenv_def var def =
-  try
-    Sys.getenv var
-  with Not_found ->
-    warning ("Environment variable "^var^" not found: using '"^def^"' .");
-    flush_all ();
-    def
-
-let getenv_else s dft = try Sys.getenv s with Not_found -> dft
-
-(* On win32, the home directory is probably not in $HOME, but in
-   some other environment variable *)
-
-let home =
-  try Sys.getenv "HOME" with Not_found ->
-    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
-      try Sys.getenv "USERPROFILE" with Not_found ->
-	warning ("Cannot determine user home directory, using '.' .");
-	flush_all ();
-	Filename.current_dir_name
-
-let safe_getenv n = safe_getenv_def n ("$"^n)
-
-let rec expand_atom s i =
-  let l = String.length s in
-  if i<l && (is_digit s.[i] or is_letter s.[i] or s.[i] = '_')
-  then expand_atom s (i+1)
-  else i
-
-let rec expand_macros s i =
-  let l = String.length s in
-  if i=l then s else
-    match s.[i] with
-      | '$' ->
-	  let n = expand_atom s (i+1) in
-	  let v = safe_getenv (String.sub s (i+1) (n-i-1)) in
-	  let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
-	  expand_macros s (i + String.length v)
-      | '~' when i = 0 ->
-	  let n = expand_atom s (i+1) in
-	  let v =
-	    if n=i+1 then home
-	    else (getpwnam (String.sub s (i+1) (n-i-1))).pw_dir
-	  in
-	  let s = v^(String.sub s n (l-n)) in
-	  expand_macros s (String.length v)
-      | c -> expand_macros s (i+1)
-
-let expand_path_macros s = expand_macros s 0
-
-(* Files and load path. *)
-
-type physical_path = string
-type load_path = physical_path list
-
-let physical_path_of_string s = s
-let string_of_physical_path p = p
-
-(* 
- * Split a path into a list of directories. A one-liner with Str, but Coq
- * doesn't seem to use this library at all, so here is a slighly longer version.
- *)
-
-let lpath_from_path path path_separator =
-  let n = String.length path in
-  let rec aux i l =
-    if i < n then
-      let j =
-        try String.index_from path i path_separator
-        with Not_found -> n
-      in
-      let dir = String.sub path i (j-i) in
-      aux (j+1) (dir::l)
-    else
-      l
-  in List.rev (aux 0 [])
-
-(* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p =
-  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
-  let n = String.length curdir in
-  let l = String.length p in
-  if l > n && String.sub p 0 n = curdir then
-    let n' =
-      let sl = String.length Filename.dir_sep in
-      let i = ref n in
-	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
-    remove_path_dot (String.sub p n' (l - n'))
-  else
-    p
-
-let strip_path p =
-  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
-  let n = String.length cwd in
-  let l = String.length p in
-  if l > n && String.sub p 0 n = cwd then
-    let n' =
-      let sl = String.length Filename.dir_sep in
-      let i = ref n in
-	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
-    remove_path_dot (String.sub p n' (l - n'))
-  else
-    remove_path_dot p
-
-let canonical_path_name p =
-  let current = Sys.getcwd () in
-  try
-    Sys.chdir p;
-    let p' = Sys.getcwd () in
-    Sys.chdir current;
-    p'
-  with Sys_error _ ->
-    (* We give up to find a canonical name and just simplify it... *)
-    strip_path p
-
 (* All subdirectories, recursively *)
 
 let exists_dir dir =
@@ -139,9 +23,9 @@ let skipped_dirnames = ref ["CVS"; "_darcs"]
 let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
 
 let ok_dirname f =
-  f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) &&
-  try ignore (check_ident f); true
-  with e when e <> Sys.Break -> false
+  not (String.is_empty f) && f.[0] != '.' &&
+  not (String.List.mem f !skipped_dirnames) &&
+  (match Unicode.ident_refutation f with None -> true | _ -> false)
 
 let all_subdirs ~unix_path:root =
   let l = ref [] in
@@ -154,11 +38,13 @@ let all_subdirs ~unix_path:root =
 	if ok_dirname f then
 	  let file = Filename.concat dir f in
 	  try
-	    if (stat file).st_kind = S_DIR then begin
-	      let newrel = rel@[f] in
+            begin match (stat file).st_kind with
+	    | S_DIR ->
+	      let newrel = rel @ [f] in
 	      add file newrel;
 	      traverse file newrel
-	    end
+            | _ -> ()
+            end
 	  with Unix_error (e,s1,s2) -> ()
       done
     with End_of_file ->
@@ -167,28 +53,43 @@ let all_subdirs ~unix_path:root =
   if exists_dir root then traverse root [];
   List.rev !l
 
+let rec search paths test =
+  match paths with
+  | [] -> []
+  | lpe :: rem -> test lpe @ search rem test
+
 let where_in_path ?(warn=true) path filename =
-  let rec search = function
-    | lpe :: rem ->
-	let f = Filename.concat lpe filename in
-	  if Sys.file_exists f
-	  then (lpe,f) :: search rem
-	  else search rem
-    | [] -> [] in
-  let rec check_and_warn l =
-    match l with
-      | [] -> raise Not_found
-      | (lpe, f) :: l' ->
-	  if warn & l' <> [] then
-	    msg_warning
-	      (str filename ++ str " has been found in" ++ spc () ++
-	       hov 0 (str "[ " ++
-	         hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon())
-		   (fun (lpe,_) -> str lpe) l)
-	         ++ str " ];") ++ fnl () ++
-	       str "loading " ++ str f);
-	  (lpe, f) in
-  check_and_warn (search path)
+  let check_and_warn l = match l with
+  | [] -> raise Not_found
+  | (lpe, f) :: l' ->
+    let () = match l' with
+    | _ :: _ when warn ->
+      msg_warning
+        (str filename ++ str " has been found in" ++ spc () ++
+          hov 0 (str "[ " ++
+            hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon())
+              (fun (lpe,_) -> str lpe) l)
+            ++ str " ];") ++ fnl () ++
+          str "loading " ++ str f)
+    | _ -> ()
+    in
+    (lpe, f)
+  in
+  check_and_warn (search path (fun lpe ->
+    let f = Filename.concat lpe filename in
+    if Sys.file_exists f then [lpe,f] else []))
+
+let where_in_path_rex path rex =
+  search path (fun lpe ->
+    try
+      let files = Sys.readdir lpe in
+      CList.map_filter (fun name ->
+        try
+          ignore(Str.search_forward rex name 0);
+          Some (lpe,Filename.concat lpe name)
+        with Not_found -> None)
+      (Array.to_list files)
+    with Sys_error _ -> [])
 
 let find_file_in_path ?(warn=true) paths filename =
   if not (Filename.is_implicit filename) then
@@ -209,56 +110,87 @@ let is_in_path lpath filename =
   try ignore (where_in_path ~warn:false lpath filename); true
   with Not_found -> false
 
-let path_separator = if Sys.os_type = "Unix" then ':' else ';'
-
 let is_in_system_path filename =
-  let path = try Sys.getenv "PATH" 
+  let path = try Sys.getenv "PATH"
              with Not_found -> error "system variable PATH not found" in
-  let lpath = lpath_from_path path path_separator in
+  let lpath = CUnix.path_to_list path in
   is_in_path lpath filename
 
-let make_suffix name suffix =
-  if Filename.check_suffix name suffix then name else (name ^ suffix)
-
-let file_readable_p name =
-  try access name [R_OK];true with Unix_error (_, _, _) -> false
-
 let open_trapping_failure name =
   try open_out_bin name
-  with e when e <> Sys.Break -> error ("Can't open " ^ name)
+  with e when Errors.noncritical e -> error ("Can't open " ^ name)
 
 let try_remove filename =
   try Sys.remove filename
-  with e when e <> Sys.Break ->
-    msgnl (str"Warning: " ++ str"Could not remove file " ++
-             str filename ++ str" which is corrupted!" )
+  with e when Errors.noncritical e ->
+    msg_warning
+      (str"Could not remove file " ++ str filename ++ str" which is corrupted!")
 
-let marshal_out ch v = Marshal.to_channel ch v []
+let error_corrupted file s = error (file ^": " ^ s ^ ". Try to rebuild it.")
+
+let input_binary_int f ch =
+  try input_binary_int ch
+  with
+  | End_of_file -> error_corrupted f "premature end of file"
+  | Failure s -> error_corrupted f s
+let output_binary_int ch x = output_binary_int ch x; flush ch
+
+let marshal_out ch v = Marshal.to_channel ch v []; flush ch
 let marshal_in filename ch =
   try Marshal.from_channel ch
   with
-    | End_of_file -> error "corrupted file: reached end of file"
-    | Failure _ (* e.g. "truncated object" *) ->
-        error (filename ^ " is corrupted, try to rebuild it.")
+  | End_of_file -> error_corrupted filename "premature end of file"
+  | Failure s -> error_corrupted filename s
+
+let digest_out = Digest.output
+let digest_in filename ch =
+  try Digest.input ch
+  with
+  | End_of_file -> error_corrupted filename "premature end of file"
+  | Failure s -> error_corrupted filename s
+
+let marshal_out_segment f ch v =
+  let start = pos_out ch in
+  output_binary_int ch 0;  (* dummy value for stop *)
+  marshal_out ch v;
+  let stop = pos_out ch in
+  seek_out ch start;
+  output_binary_int ch stop;
+  seek_out ch stop;
+  digest_out ch (Digest.file f)
+
+let marshal_in_segment f ch =
+  let stop = (input_binary_int f ch : int) in
+  let v = marshal_in f ch in
+  let digest = digest_in f ch in
+  v, stop, digest
+
+let skip_in_segment f ch =
+  let stop = (input_binary_int f ch : int) in
+  seek_in ch stop;
+  stop, digest_in f ch
 
 exception Bad_magic_number of string
 
-let raw_extern_intern magic suffix =
-  let extern_state name =
-    let filename = make_suffix name suffix in
+let raw_extern_intern magic =
+  let extern_state filename =
     let channel = open_trapping_failure filename in
     output_binary_int channel magic;
-    filename,channel
+    filename, channel
   and intern_state filename =
-    let channel = open_in_bin filename in
-    if input_binary_int channel <> magic then
-      raise (Bad_magic_number filename);
-    channel
+    try
+      let channel = open_in_bin filename in
+      if not (Int.equal (input_binary_int filename channel) magic) then
+        raise (Bad_magic_number filename);
+      channel
+    with
+    | End_of_file -> error_corrupted filename "premature end of file"
+    | Failure s | Sys_error s -> error_corrupted filename s
   in
   (extern_state,intern_state)
 
-let extern_intern ?(warn=true) magic suffix =
-  let (raw_extern,raw_intern) = raw_extern_intern magic suffix in
+let extern_intern ?(warn=true) magic =
+  let (raw_extern,raw_intern) = raw_extern_intern magic in
   let extern_state name val_0 =
     try
       let (filename,channel) = raw_extern name in
@@ -266,11 +198,13 @@ let extern_intern ?(warn=true) magic suffix =
         marshal_out channel val_0;
         close_out channel
       with reraise ->
-	begin try_remove filename; raise reraise end
+	let reraise = Errors.push reraise in
+        let () = try_remove filename in
+        iraise reraise
     with Sys_error s -> error ("System error: " ^ s)
   and intern_state paths name =
     try
-      let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in
+      let _,filename = find_file_in_path ~warn paths name in
       let channel = raw_intern filename in
       let v = marshal_in filename channel in
       close_in channel;
@@ -284,79 +218,47 @@ let with_magic_number_check f a =
   try f a
   with Bad_magic_number fname ->
     errorlabstrm "with_magic_number_check"
-    (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++ 
+    (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++
     strbrk "It is corrupted or was compiled with another version of Coq.")
 
-(* Communication through files with another executable *)
-
-let connect writefun readfun com =
-  let name = Filename.basename com in
-  let tmp_to = Filename.temp_file ("coq-"^name^"-in") ".xml" in
-  let tmp_from = Filename.temp_file ("coq-"^name^"-out") ".xml" in
-  let ch_to_in,ch_to_out =
-    try open_in tmp_to, open_out tmp_to
-    with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in
-  let ch_from_in,ch_from_out =
-    try open_in tmp_from, open_out tmp_from
-    with Sys_error s ->
-      close_out ch_to_out; close_in ch_to_in;
-      error ("Cannot set connection from "^com^"("^s^")") in
-  writefun ch_to_out;
-  close_out ch_to_out;
-  let pid =
-    let ch_to' = Unix.descr_of_in_channel ch_to_in in
-    let ch_from' = Unix.descr_of_out_channel ch_from_out in
-    try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout
-    with Unix.Unix_error (err,_,_) ->
-      close_in ch_to_in; close_in ch_from_in; close_out ch_from_out;
-      unlink tmp_from; unlink tmp_to;
-      error ("Cannot execute "^com^"("^(Unix.error_message err)^")") in
-  close_in ch_to_in;
-  close_out ch_from_out;
-  (match snd (Unix.waitpid [] pid) with
-    | Unix.WEXITED 127 -> error (com^": cannot execute")
-    | Unix.WEXITED 0 -> ()
-    | _ -> error (com^" exited abnormally"));
-  let a = readfun ch_from_in in
-  close_in ch_from_in;
-  unlink tmp_from;
-  unlink tmp_to;
-  a
-
-let run_command converter f c =
-  let result = Buffer.create 127 in
-  let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
-  let buff = String.make 127 ' ' in
-  let buffe = String.make 127 ' ' in
-  let n = ref 0 in
-  let ne = ref 0 in
-
-  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
-    !n+ !ne <> 0
-  do
-    let r = converter (String.sub buff 0 !n) in
-    f r;
-    Buffer.add_string result r;
-    let r = converter (String.sub buffe 0 !ne) in
-    f r;
-    Buffer.add_string result r
-  done;
-  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
-
 (* Time stamps. *)
 
 type time = float * float * float
 
 let get_time () =
-  let t = times ()  in
-  (time(), t.tms_utime, t.tms_stime)
+  let t = Unix.times ()  in
+  (Unix.gettimeofday(), t.tms_utime, t.tms_stime)
 
-let time_difference (t1,_,_) (t2,_,_) = t2 -. t1
+(* Keep only 3 significant digits *)
+let round f = (floor (f *. 1e3)) *. 1e-3
+
+let time_difference (t1,_,_) (t2,_,_) = round (t2 -. t1)
 
 let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) =
-  real (stopreal -. startreal) ++ str " secs " ++
+  real (round (stopreal -. startreal)) ++ str " secs " ++
   str "(" ++
-  real ((-.) ustop ustart) ++ str "u" ++
+  real (round (ustop -. ustart)) ++ str "u" ++
   str "," ++
-  real ((-.) sstop sstart) ++ str "s" ++
+  real (round (sstop -. sstart)) ++ str "s" ++
   str ")"
+
+let with_time time f x =
+  let tstart = get_time() in
+  let msg = if time then "" else "Finished transaction in " in
+  try
+    let y = f x in
+    let tend = get_time() in
+    let msg2 = if time then "" else " (successful)" in
+    msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
+    y
+  with e ->
+    let tend = get_time() in
+    let msg = if time then "" else "Finished failing transaction in " in
+    let msg2 = if time then "" else " (failure)" in
+    msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
+    raise e
+
+let process_id () =
+  if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id
+  else Printf.sprintf "master:%d" (Thread.id (Thread.self ()))
+    
diff --git a/lib/system.mli b/lib/system.mli
index b56e65a4..a3d66d57 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** System utilities *)
+(** {5 Coqtop specific system utilities} *)
 
 (** {6 Files and load paths} *)
 
@@ -14,63 +14,50 @@
     given by the user. For efficiency, we keep the full path (field
     [directory]), the root path and the path relative to the root. *)
 
-type physical_path = string
-type load_path = physical_path list
-
-val canonical_path_name : string -> string
-
 val exclude_search_in_dirname : string -> unit
 
-val all_subdirs : unix_path:string -> (physical_path * string list) list
-val is_in_path : load_path -> string -> bool
+val all_subdirs : unix_path:string -> (CUnix.physical_path * string list) list
+val is_in_path : CUnix.load_path -> string -> bool
 val is_in_system_path : string -> bool
-val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string
-
-val physical_path_of_string : string -> physical_path
-val string_of_physical_path : physical_path -> string
-
-val make_suffix : string -> string -> string
-val file_readable_p : string -> bool
-
-val expand_path_macros : string -> string
-val getenv_else : string -> string -> string
-val home : string
+val where_in_path :
+  ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
+val where_in_path_rex :
+  CUnix.load_path -> Str.regexp -> (CUnix.physical_path * string) list
 
 val exists_dir : string -> bool
 
 val find_file_in_path :
-  ?warn:bool -> load_path -> string -> physical_path * string
+  ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
 
 (** {6 I/O functions } *)
 (** Generic input and output functions, parameterized by a magic number
   and a suffix. The intern functions raise the exception [Bad_magic_number]
   when the check fails, with the full file name. *)
 
-val marshal_out : out_channel -> 'a -> unit
-val marshal_in : string -> in_channel -> 'a
-
 exception Bad_magic_number of string
 
-val raw_extern_intern : int -> string ->
+val raw_extern_intern : int ->
   (string -> string * out_channel) * (string -> in_channel)
 
-val extern_intern : ?warn:bool -> int -> string ->
-  (string -> 'a -> unit) * (load_path -> string -> 'a)
+val extern_intern : ?warn:bool -> int ->
+  (string -> 'a -> unit) * (CUnix.load_path -> string -> 'a)
 
 val with_magic_number_check : ('a -> 'b) -> 'a -> 'b
 
-(** {6 Sending/receiving once with external executable } *)
+(** Clones of Marshal.to_channel (with flush) and
+    Marshal.from_channel (with nice error message) *)
+
+val marshal_out : out_channel -> 'a -> unit
+val marshal_in : string -> in_channel -> 'a
 
-val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a
+(** Clones of Digest.output and Digest.input (with nice error message) *)
 
-(** {6 Executing commands } *)
-(** [run_command converter f com] launches command [com], and returns
-    the contents of stdout and stderr that have been processed with
-    [converter]; the processed contents of stdout and stderr is also
-    passed to [f] *)
+val digest_out : out_channel -> Digest.t -> unit
+val digest_in : string -> in_channel -> Digest.t
 
-val run_command : (string -> string) -> (string -> unit) -> string ->
-  Unix.process_status * string
+val marshal_out_segment : string -> out_channel -> 'a -> unit
+val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t
+val skip_in_segment : string -> in_channel -> int * Digest.t
 
 (** {6 Time stamps.} *)
 
@@ -79,3 +66,8 @@ type time
 val get_time : unit -> time
 val time_difference : time -> time -> float (** in seconds *)
 val fmt_time_difference : time -> time -> Pp.std_ppcmds
+
+val with_time : bool -> ('a -> 'b) -> 'a -> 'b
+
+(** {6 Name of current process.} *)
+val process_id : unit -> string
diff --git a/lib/terminal.ml b/lib/terminal.ml
new file mode 100644
index 00000000..1e6c2557
--- /dev/null
+++ b/lib/terminal.ml
@@ -0,0 +1,284 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type color = [
+  `DEFAULT
+| `BLACK
+| `RED
+| `GREEN
+| `YELLOW
+| `BLUE
+| `MAGENTA
+| `CYAN
+| `WHITE
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE
+| `INDEX of int
+| `RGB of (int * int * int)
+]
+
+type style = {
+  fg_color : color option;
+  bg_color : color option;
+  bold : bool option;
+  italic : bool option;
+  underline : bool option;
+  negative : bool option;
+}
+
+let set o1 o2 = match o1 with
+| None -> o2
+| Some _ ->
+  match o2 with
+  | None -> o1
+  | Some _ -> o2
+
+let default = {
+  fg_color = None;
+  bg_color = None;
+  bold = None;
+  italic = None;
+  underline = None;
+  negative = None;
+}
+
+let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style () =
+  let st = match style with
+  | None -> default
+  | Some st -> st
+  in
+  {
+    fg_color = set st.fg_color fg_color;
+    bg_color = set st.bg_color bg_color;
+    bold = set st.bold bold;
+    italic = set st.italic italic;
+    underline = set st.underline underline;
+    negative = set st.negative negative;
+  }
+
+let merge s1 s2 =
+  {
+    fg_color = set s1.fg_color s2.fg_color;
+    bg_color = set s1.bg_color s2.bg_color;
+    bold = set s1.bold s2.bold;
+    italic = set s1.italic s2.italic;
+    underline = set s1.underline s2.underline;
+    negative = set s1.negative s2.negative;
+  }
+
+let base_color = function
+| `DEFAULT -> 9
+| `BLACK -> 0
+| `RED -> 1
+| `GREEN -> 2
+| `YELLOW -> 3
+| `BLUE -> 4
+| `MAGENTA -> 5
+| `CYAN -> 6
+| `WHITE -> 7
+| `LIGHT_BLACK -> 0
+| `LIGHT_RED -> 1
+| `LIGHT_GREEN -> 2
+| `LIGHT_YELLOW -> 3
+| `LIGHT_BLUE -> 4
+| `LIGHT_MAGENTA -> 5
+| `LIGHT_CYAN -> 6
+| `LIGHT_WHITE -> 7
+| _ -> invalid_arg "base_color"
+
+let extended_color off = function
+| `INDEX i -> [off + 8; 5; i]
+| `RGB (r, g, b) -> [off + 8; 2; r; g; b]
+| _ -> invalid_arg "extended_color"
+
+let is_light = function
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE -> true
+| _ -> false
+
+let is_extended = function
+| `INDEX _ | `RGB _ -> true
+| _ -> false
+
+let eval st =
+  let fg = match st.fg_color with
+  | None -> []
+  | Some c ->
+    if is_light c then [90 + base_color c]
+    else if is_extended c then extended_color 30 c
+    else [30 + base_color c]
+  in
+  let bg = match st.bg_color with
+  | None -> []
+  | Some c ->
+    if is_light c then [100 + base_color c]
+    else if is_extended c then extended_color 40 c
+    else [40 + base_color c]
+  in
+  let bold = match st.bold with
+  | None -> []
+  | Some true -> [1]
+  | Some false -> [22]
+  in
+  let italic = match st.italic with
+  | None -> []
+  | Some true -> [3]
+  | Some false -> [23]
+  in
+  let underline = match st.underline with
+  | None -> []
+  | Some true -> [4]
+  | Some false -> [24]
+  in
+  let negative = match st.negative with
+  | None -> []
+  | Some true -> [7]
+  | Some false -> [27]
+  in
+  let tags = fg @ bg @ bold @ italic @ underline @ negative in
+  let tags = List.map string_of_int tags in
+  Printf.sprintf "\027[%sm" (String.concat ";" tags)
+
+let reset = "\027[0m"
+
+let reset_style = {
+  fg_color = Some `DEFAULT;
+  bg_color = Some `DEFAULT;
+  bold = Some false;
+  italic = Some false;
+  underline = Some false;
+  negative = Some false;
+}
+
+let has_style t = Unix.isatty t
+
+let split c s =
+  let len = String.length s in
+  let rec split n =
+    try
+      let pos = String.index_from s n c in
+      let dir = String.sub s n (pos-n) in
+      dir :: split (succ pos)
+    with
+      | Not_found -> [String.sub s n (len-n)]
+  in
+  if len = 0 then [] else split 0
+
+let check_char i = if i < 0 || i > 255 then invalid_arg "check_char"
+
+let parse_color off rem = match off with
+| 0 -> (`BLACK, rem)
+| 1 -> (`RED, rem)
+| 2 -> (`GREEN, rem)
+| 3 -> (`YELLOW, rem)
+| 4 -> (`BLUE, rem)
+| 5 -> (`MAGENTA, rem)
+| 6 -> (`CYAN, rem)
+| 7 -> (`WHITE, rem)
+| 9 -> (`DEFAULT, rem)
+| 8 ->
+  begin match rem with
+  | 5 :: i :: rem ->
+    check_char i;
+    (`INDEX i, rem)
+  | 2 :: r :: g :: b :: rem ->
+    check_char r;
+    check_char g;
+    check_char b;
+    (`RGB (r, g, b), rem)
+  | _ -> invalid_arg "parse_color"
+  end
+| _ -> invalid_arg "parse_color"
+
+let set_light = function
+| `BLACK -> `LIGHT_BLACK
+| `RED -> `LIGHT_RED
+| `GREEN -> `LIGHT_GREEN
+| `YELLOW -> `LIGHT_YELLOW
+| `BLUE -> `LIGHT_BLUE
+| `MAGENTA -> `LIGHT_MAGENTA
+| `CYAN -> `LIGHT_CYAN
+| `WHITE -> `LIGHT_WHITE
+| _ -> invalid_arg "parse_color"
+
+let rec parse_style style = function
+| [] -> style
+| 0 :: rem ->
+  let style = merge style reset_style in
+  parse_style style rem
+| 1 :: rem ->
+  let style = make ~style ~bold:true () in
+  parse_style style rem
+| 3 :: rem ->
+  let style = make ~style ~italic:true () in
+  parse_style style rem
+| 4 :: rem ->
+  let style = make ~style ~underline:true () in
+  parse_style style rem
+| 7 :: rem ->
+  let style = make ~style ~negative:true () in
+  parse_style style rem
+| 22 :: rem ->
+  let style = make ~style ~bold:false () in
+  parse_style style rem
+| 23 :: rem ->
+  let style = make ~style ~italic:false () in
+  parse_style style rem
+| 24 :: rem ->
+  let style = make ~style ~underline:false () in
+  parse_style style rem
+| 27 :: rem ->
+  let style = make ~style ~negative:false () in
+  parse_style style rem
+| code :: rem when (30 <= code && code < 40) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~fg_color:color () in
+  parse_style style rem
+| code :: rem when (40 <= code && code < 50) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~bg_color:color () in
+  parse_style style rem
+| code :: rem when (90 <= code && code < 100) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~fg_color:(set_light color) () in
+  parse_style style rem
+| code :: rem when (100 <= code && code < 110) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~bg_color:(set_light color) () in
+  parse_style style rem
+| _ :: rem -> parse_style style rem
+
+(** Parse LS_COLORS-like strings *)
+let parse s =
+  let defs = split ':' s in
+  let fold accu s = match split '=' s with
+  | [name; attrs] ->
+    let attrs = split ';' attrs in
+    let accu =
+      try
+        let attrs = List.map int_of_string attrs in
+        let attrs = parse_style (make ()) attrs in
+        (name, attrs) :: accu
+      with _ -> accu
+    in
+    accu
+  | _ -> accu
+  in
+  List.fold_left fold [] defs
diff --git a/lib/terminal.mli b/lib/terminal.mli
new file mode 100644
index 00000000..f308ede3
--- /dev/null
+++ b/lib/terminal.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type color = [
+  `DEFAULT
+| `BLACK
+| `RED
+| `GREEN
+| `YELLOW
+| `BLUE
+| `MAGENTA
+| `CYAN
+| `WHITE
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE
+| `INDEX of int
+| `RGB of (int * int * int)
+]
+
+type style = {
+  fg_color : color option;
+  bg_color : color option;
+  bold : bool option;
+  italic : bool option;
+  underline : bool option;
+  negative : bool option;
+}
+
+val make : ?fg_color:color -> ?bg_color:color ->
+  ?bold:bool -> ?italic:bool -> ?underline:bool ->
+  ?negative:bool -> ?style:style -> unit -> style
+(** Create a style from the given flags. It is derived from the optional
+    [style] argument if given. *)
+
+val merge : style -> style -> style
+(** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *)
+
+val eval : style -> string
+(** Generate an escape sequence from a style. *)
+
+val reset : string
+(** This escape sequence resets all attributes. *)
+
+val has_style : Unix.file_descr -> bool
+(** Whether an output file descriptor handles styles. Very heuristic, only
+    checks it is a terminal. *)
+
+val parse : string -> (string * style) list
+(** Parse strings describing terminal styles in the LS_COLORS syntax. For
+    robustness, ignore meaningless entries and drops undefined styles. *)
diff --git a/lib/trie.ml b/lib/trie.ml
new file mode 100644
index 00000000..e369e6ad
--- /dev/null
+++ b/lib/trie.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module type S =
+sig
+  type label
+  type data
+  type t
+  val empty : t
+  val get : t -> data
+  val next : t -> label -> t
+  val labels : t -> label list
+  val add : label list -> data -> t -> t
+  val remove : label list -> data -> t -> t
+  val iter : (label list -> data -> unit) -> t -> unit
+end
+
+module type Grp =
+sig
+  type t
+  val nil : t
+  val is_nil : t -> bool
+  val add : t -> t -> t
+  val sub : t -> t -> t
+end
+
+module Make (Y : Map.OrderedType) (X : Grp) =
+struct
+
+module T_codom = Map.Make(Y)
+
+type data = X.t
+type label = Y.t
+type t = Node of X.t * t T_codom.t
+
+let codom_for_all f m =
+  let fold key v accu = f v && accu in
+  T_codom.fold fold m true
+
+let empty = Node (X.nil, T_codom.empty)
+
+let next (Node (_,m)) lbl = T_codom.find lbl m
+
+let get (Node (hereset,_)) = hereset
+
+let labels (Node (_,m)) =
+  (** FIXME: this is order-dependent. Try to find a more robust presentation? *)
+  List.rev (T_codom.fold (fun x _ acc -> x::acc) m [])
+
+let is_empty_node (Node(a,b)) = (X.is_nil a) && (T_codom.is_empty b)
+
+let assure_arc m lbl =
+  if T_codom.mem lbl m then
+    m
+  else
+    T_codom.add lbl (Node (X.nil,T_codom.empty)) m
+
+let cleanse_arcs (Node (hereset,m)) =
+  let m = if codom_for_all is_empty_node m then T_codom.empty else m in
+  Node(hereset, m)
+
+let rec at_path f (Node (hereset,m)) = function
+  | [] ->
+      cleanse_arcs (Node(f hereset,m))
+  | h::t ->
+      let m = assure_arc m h in
+      cleanse_arcs (Node(hereset,
+                         T_codom.add h (at_path f (T_codom.find h m) t) m))
+
+let add path v tm =
+  at_path (fun hereset -> X.add v hereset) tm path
+
+let remove path v tm =
+  at_path (fun hereset -> X.sub hereset v) tm path
+
+let iter f tlm =
+  let rec apprec pfx (Node(hereset,m)) =
+    let path = List.rev pfx in
+    f path hereset;
+    T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
+  in
+  apprec [] tlm
+
+end
diff --git a/lib/trie.mli b/lib/trie.mli
new file mode 100644
index 00000000..81847485
--- /dev/null
+++ b/lib/trie.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Generic functorized trie data structure. *)
+
+module type S =
+sig
+  (** A trie is a generalization of the map data structure where the keys are
+      themselves lists. *)
+
+  type label
+  (** Keys of the trie structure are [label list]. *)
+
+  type data
+  (** Data on nodes of tries are finite sets of [data]. *)
+
+  type t
+  (** The trie data structure. Essentially a finite map with keys [label list]
+      and content [data Set.t]. *)
+
+  val empty : t
+  (** The empty trie. *)
+
+  val get : t -> data
+  (** Get the data at the current node. *)
+
+  val next : t -> label -> t
+  (** [next t lbl] returns the subtrie of [t] pointed by [lbl].
+      @raise Not_found if there is none. *)
+
+  val labels : t -> label list
+  (** Get the list of defined labels at the current node. *)
+
+  val add : label list -> data -> t -> t
+  (** [add t path v] adds [v] at path [path] in [t]. *)
+
+  val remove : label list -> data -> t -> t
+  (** [remove t path v] removes [v] from path [path] in [t]. *)
+
+  val iter : (label list -> data -> unit) -> t -> unit
+  (** Apply a function to all contents. *)
+
+end
+
+module type Grp =
+sig
+  type t
+  val nil : t
+  val is_nil : t -> bool
+  val add : t -> t -> t
+  val sub : t -> t -> t
+end
+
+module Make (Label : Set.OrderedType) (Data : Grp) : S
+  with type label = Label.t and type data = Data.t
+(** Generating functor, for a given type of labels and data. *)
diff --git a/lib/tries.ml b/lib/tries.ml
deleted file mode 100644
index 60b466b7..00000000
--- a/lib/tries.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-
-
-module Make = 
-  functor (X : Set.OrderedType) ->
-    functor (Y : Map.OrderedType) ->
-struct
-  module T_dom = Fset.Make(X) 
-  module T_codom = Fmap.Make(Y) 
-
-  type t = Node of T_dom.t * t T_codom.t
-
-  let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m []
-
-  let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m []
-
-  let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m []
-
-  let empty = Node (T_dom.empty, T_codom.empty)
-
-  let map (Node (_,m)) lbl = T_codom.find lbl m
-
-  let xtract (Node (hereset,_)) = T_dom.elements hereset
-    
-  let dom (Node (_,m)) = codom_dom m
-
-  let in_dom (Node (_,m)) lbl = T_codom.mem lbl m
-
-  let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = [])
-
-let assure_arc m lbl =
-  if T_codom.mem lbl m then 
-    m
-  else 
-    T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m
-
-let cleanse_arcs (Node (hereset,m)) =
-  let l = codom_rng m in 
-  Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m)
-
-let rec at_path f (Node (hereset,m)) = function
-  | [] -> 
-      cleanse_arcs (Node(f hereset,m))
-  | h::t ->
-      let m = assure_arc m h in 
-      cleanse_arcs (Node(hereset,
-                         T_codom.add h (at_path f (T_codom.find h m) t) m))
-
-let add tm (path,v) =
-  at_path (fun hereset -> T_dom.add v hereset) tm path
-    
-let rmv tm (path,v) =
-  at_path (fun hereset -> T_dom.remove v hereset) tm path
-
-let app f tlm = 
-  let rec apprec pfx (Node(hereset,m)) =
-    let path = List.rev pfx in 
-    T_dom.iter (fun v -> f(path,v)) hereset;
-    T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
-  in 
-  apprec [] tlm
-    
-let to_list tlm = 
-  let rec torec pfx (Node(hereset,m)) =
-    let path = List.rev pfx in 
-    List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset))::
-		 (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m)))
-  in 
-  torec [] tlm
-
-end
diff --git a/lib/tries.mli b/lib/tries.mli
deleted file mode 100644
index 8e837677..00000000
--- a/lib/tries.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-
-
-
-
-
-module Make :
-  functor (X : Set.OrderedType) ->
-    functor (Y : Map.OrderedType) ->
-sig
-     
-  type t 
-    
-  val empty : t
-      
-  (** Work on labels, not on paths. *)
-
-  val map : t -> Y.t -> t
-
-  val xtract : t -> X.t list
-    
-  val dom : t -> Y.t list
-
-  val in_dom : t -> Y.t -> bool
-
-  (** Work on paths, not on labels. *)
-
-  val add : t -> Y.t list * X.t -> t
-  
-  val rmv : t -> Y.t list * X.t -> t 
-
-  val app : ((Y.t list * X.t) -> unit) -> t -> unit
-    
-  val to_list : t -> (Y.t list * X.t) list
-end
diff --git a/lib/unicode.ml b/lib/unicode.ml
new file mode 100644
index 00000000..1765e93d
--- /dev/null
+++ b/lib/unicode.ml
@@ -0,0 +1,241 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** Unicode utilities *)
+
+type status = Letter | IdentPart | Symbol
+
+exception Unsupported
+
+(* The following table stores classes of Unicode characters that
+   are used by the lexer. There are 3 different classes so 2 bits are
+   allocated for each character. We only use 16 bits over the 31 bits
+   to simplify the masking process. (This choice seems to be a good
+   trade-off between speed and space after some benchmarks.) *)
+
+(* A 256ko table, initially filled with zeros. *)
+let table = Array.make (1 lsl 17) 0
+
+(* Associate a 2-bit pattern to each status at position [i].
+   Only the 3 lowest bits of [i] are taken into account to
+   define the position of the pattern in the word.
+   Notice that pattern "00" means "undefined". *)
+let mask i = function
+  | Letter    -> 1 lsl ((i land 7) lsl 1) (* 01 *)
+  | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
+  | Symbol    -> 3 lsl ((i land 7) lsl 1) (* 11 *)
+
+(* Helper to reset 2 bits in a word. *)
+let reset_mask i =
+  lnot (3 lsl ((i land 7) lsl 1))
+
+(* Initialize the lookup table from a list of segments, assigning
+   a status to every character of each segment. The order of these
+   assignments is relevant: it is possible to assign status [s] to
+   a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
+   between [c1] and [c2]. *)
+let mk_lookup_table_from_unicode_tables_for status tables =
+  List.iter
+    (List.iter
+       (fun (c1, c2) ->
+          for i = c1 to c2 do
+            table.(i lsr 3) <-
+              (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
+          done))
+    tables
+
+(* Look up into the table and interpret the found pattern. *)
+let lookup x =
+  let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
+    if      v = 1 then Letter
+    else if v = 2 then IdentPart
+    else if v = 3 then Symbol
+    else raise Unsupported
+
+(* [classify] discriminates between 3 different kinds of
+   symbols based on the standard unicode classification (extracted from
+   Camomile). *)
+let classify =
+  let single c = [ (c, c) ] in
+    (* General tables. *)
+    mk_lookup_table_from_unicode_tables_for Symbol
+      [
+        Unicodetable.sm;           (* Symbol, maths.                    *)
+        Unicodetable.sc;           (* Symbol, currency.                 *)
+        Unicodetable.so;           (* Symbol, modifier.                 *)
+        Unicodetable.pd;           (* Punctation, dash.                 *)
+        Unicodetable.pc;           (* Punctation, connector.            *)
+        Unicodetable.pe;           (* Punctation, open.                 *)
+        Unicodetable.ps;           (* Punctation, close.                *)
+        Unicodetable.pi;           (* Punctation, initial quote.        *)
+        Unicodetable.pf;           (* Punctation, final quote.          *)
+        Unicodetable.po;           (* Punctation, other.                *)
+      ];
+    mk_lookup_table_from_unicode_tables_for Letter
+      [
+        Unicodetable.lu;           (* Letter, uppercase.                *)
+        Unicodetable.ll;           (* Letter, lowercase.                *)
+        Unicodetable.lt;           (* Letter, titlecase.                *)
+        Unicodetable.lo;           (* Letter, others.                   *)
+      ];
+    mk_lookup_table_from_unicode_tables_for IdentPart
+      [
+        Unicodetable.nd;           (* Number, decimal digits.           *)
+        Unicodetable.nl;           (* Number, letter.                   *)
+        Unicodetable.no;           (* Number, other.                    *)
+      ];
+
+    (* Workaround. Some characters seems to be missing in
+       Camomile's category tables. We add them manually. *)
+    mk_lookup_table_from_unicode_tables_for Letter
+      [
+        [(0x01D00, 0x01D7F)];      (* Phonetic Extensions.              *)
+        [(0x01D80, 0x01DBF)];      (* Phonetic Extensions Suppl.        *)
+        [(0x01DC0, 0x01DFF)];      (* Combining Diacritical Marks Suppl.*)
+      ];
+
+    (* Exceptions (from a previous version of this function).           *)
+    mk_lookup_table_from_unicode_tables_for Symbol
+      [
+        [(0x000B2, 0x000B3)];      (* Superscript 2-3.                  *)
+        single 0x000B9;            (* Superscript 1.                    *)
+        single 0x02070;            (* Superscript 0.                    *)
+        [(0x02074, 0x02079)];      (* Superscript 4-9.                  *)
+        single 0x0002E;            (* Dot.                              *)
+      ];
+    mk_lookup_table_from_unicode_tables_for Letter
+      [
+        single 0x005F;             (* Underscore.                       *)
+        single 0x00A0;             (* Non breaking space.               *)
+      ];
+    mk_lookup_table_from_unicode_tables_for IdentPart
+      [
+        single 0x0027;             (* Special space.                    *)
+      ];
+    (* Lookup *)
+    lookup
+
+exception End_of_input
+
+let utf8_of_unicode n =
+  if n < 128 then
+    String.make 1 (Char.chr n)
+  else if n < 2048 then
+    let s = String.make 2 (Char.chr (128 + n mod 64)) in
+    begin
+      s.[0] <- Char.chr (192 + n / 64);
+      s
+    end
+  else if n < 65536 then
+    let s = String.make 3 (Char.chr (128 + n mod 64)) in
+    begin
+      s.[1] <- Char.chr (128 + (n / 64) mod 64);
+      s.[0] <- Char.chr (224 + n / 4096);
+      s
+    end
+  else
+    let s = String.make 4 (Char.chr (128 + n mod 64)) in
+    begin
+      s.[2] <- Char.chr (128 + (n / 64) mod 64);
+      s.[1] <- Char.chr (128 + (n / 4096) mod 64);
+      s.[0] <- Char.chr (240 + n / 262144);
+      s
+    end
+
+let next_utf8 s i =
+  let err () = invalid_arg "utf8" in
+  let l = String.length s - i in
+  if l = 0 then raise End_of_input
+  else let a = Char.code s.[i] in if a <= 0x7F then
+    1, a
+  else if a land 0x40 = 0 || l = 1 then err ()
+  else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err ()
+  else if a land 0x20 = 0 then
+    2, (a land 0x1F) lsl 6 + (b land 0x3F)
+  else if l = 2 then err ()
+  else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err ()
+  else if a land 0x10 = 0 then
+    3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F)
+  else if l = 3 then err ()
+  else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err ()
+  else if a land 0x08 = 0 then
+    4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 +
+       (c land 0x3F) lsl 6 + (d land 0x3F)
+  else err ()
+
+(* Check the well-formedness of an identifier *)
+
+let initial_refutation j n s =
+  match classify n with
+  | Letter -> None
+  | _ ->
+      let c = String.sub s 0 j in
+      Some (false,
+            "Invalid character '"^c^"' at beginning of identifier \""^s^"\".")
+
+let trailing_refutation i j n s =
+  match classify n with
+  | Letter | IdentPart -> None
+  | _ ->
+      let c = String.sub s i j in
+      Some (false,
+            "Invalid character '"^c^"' in identifier \""^s^"\".")
+
+let ident_refutation s =
+  if s = ".." then None else try
+    let j, n = next_utf8 s 0 in
+      match initial_refutation j n s with
+        |None ->
+           begin try
+             let rec aux i =
+               let j, n = next_utf8 s i in
+                 match trailing_refutation i j n s with
+                   |None -> aux (i + j)
+                   |x -> x
+             in aux j
+           with End_of_input -> None
+           end
+        |x -> x
+  with
+  | End_of_input -> Some (true,"The empty string is not an identifier.")
+  | Unsupported -> Some (true,s^": unsupported character in utf8 sequence.")
+  | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.")
+
+let lowercase_unicode =
+  let tree = Segmenttree.make Unicodetable.to_lower in
+  fun unicode ->
+    try
+      match Segmenttree.lookup unicode tree with
+        | `Abs c -> c
+        | `Delta d -> unicode + d
+    with Not_found -> unicode
+
+let lowercase_first_char s =
+  assert (s <> "");
+  let j, n = next_utf8 s 0 in
+  utf8_of_unicode (lowercase_unicode n)
+
+(** For extraction, we need to encode unicode character into ascii ones *)
+
+let is_basic_ascii s =
+  let ok = ref true in
+  String.iter (fun c -> if Char.code c >= 128 then ok := false) s;
+  !ok
+
+let ascii_of_ident s =
+  if is_basic_ascii s then s else
+    let i = ref 0 and out = ref "" in
+    begin try while true do
+      let j, n = next_utf8 s !i in
+      out :=
+        if n >= 128
+        then Printf.sprintf "%s__U%04x_" !out n
+        else Printf.sprintf "%s%c" !out s.[!i];
+      i := !i + j
+    done with End_of_input -> () end;
+    !out
diff --git a/lib/unicode.mli b/lib/unicode.mli
new file mode 100644
index 00000000..098f6c91
--- /dev/null
+++ b/lib/unicode.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Unicode utilities *)
+
+type status = Letter | IdentPart | Symbol
+
+exception Unsupported
+
+(** Classify a unicode char into 3 classes, or raise [Unsupported] *)
+val classify : int -> status
+
+(** Check whether a given string be used as a legal identifier.
+    - [None] means yes
+    - [Some (b,s)] means no, with explanation [s] and severity [b] *)
+val ident_refutation : string -> (bool * string) option
+
+(** First char of a string, converted to lowercase *)
+val lowercase_first_char : string -> string
+
+(** For extraction, turn a unicode string into an ascii-only one *)
+val is_basic_ascii : string -> bool
+val ascii_of_ident : string -> string
diff --git a/lib/unionfind.ml b/lib/unionfind.ml
index 300e8b0e..c44aa736 100644
--- a/lib/unionfind.ml
+++ b/lib/unionfind.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -53,7 +53,28 @@ module type PartitionSig = sig
 
 end
 
-module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
+module type SetS =
+sig
+  type t
+  type elt
+  val singleton : elt -> t
+  val union : t -> t -> t
+  val choose : t -> elt
+  val iter : (elt -> unit) -> t -> unit
+end
+
+module type MapS =
+sig
+  type key
+  type +'a t
+  val empty : 'a t
+  val find : key -> 'a t -> 'a
+  val add : key -> 'a -> 'a t -> 'a t
+  val mem : key -> 'a t -> bool
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+
+module Make (S:SetS)(M:MapS with type key = S.elt) = struct
 
   type elt = S.elt
   type set = S.t
@@ -101,7 +122,7 @@ module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
 
   let union_set s p =
     try
-      let x = S.min_elt s in
+      let x = S.choose s in
       S.iter (fun y -> union x y p) s
     with Not_found -> ()
 
diff --git a/lib/unionfind.mli b/lib/unionfind.mli
index 0db9ff08..310d5e2a 100644
--- a/lib/unionfind.mli
+++ b/lib/unionfind.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -51,7 +51,30 @@ module type PartitionSig = sig
 
 end
 
+module type SetS =
+sig
+  type t
+  type elt
+  val singleton : elt -> t
+  val union : t -> t -> t
+  val choose : t -> elt
+  val iter : (elt -> unit) -> t -> unit
+end
+(** Minimal interface for sets, subtype of stdlib's Set. *)
+
+module type MapS =
+sig
+  type key
+  type +'a t
+  val empty : 'a t
+  val find : key -> 'a t -> 'a
+  val add : key -> 'a -> 'a t -> 'a t
+  val mem : key -> 'a t -> bool
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+(** Minimal interface for maps, subtype of stdlib's Map. *)
+
 module Make :
-  functor (S:Set.S) ->
-    functor (M:Map.S with type key = S.elt) ->
+  functor (S:SetS) ->
+    functor (M:MapS with type key = S.elt) ->
       PartitionSig with type elt = S.elt and type set = S.t
diff --git a/lib/util.ml b/lib/util.ml
index 4f14b83a..a8c25f74 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,47 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-open Pp
-open Compat
-
-(* Errors *)
-
-exception Anomaly of string * std_ppcmds  (* System errors *)
-let anomaly string = raise (Anomaly(string, str string))
-let anomalylabstrm string pps = raise (Anomaly(string,pps))
-
-exception UserError of string * std_ppcmds (* User errors *)
-let error string = raise (UserError("_", str string))
-let errorlabstrm l pps = raise (UserError(l,pps))
-
-exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
-let alreadydeclared pps = raise (AlreadyDeclared(pps))
-
-let todo s = prerr_string ("TODO: "^s^"\n")
-
-exception Timeout
-
-type loc = Loc.t
-let dummy_loc = Loc.ghost
-let join_loc = Loc.merge
-let make_loc = make_loc
-let unloc = unloc
-
-(* raising located exceptions *)
-type 'a located = loc * 'a
-let anomaly_loc (loc,s,strm) = Loc.raise loc (Anomaly (s,strm))
-let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
-let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
-
-let located_fold_left f x (_,a) = f x a
-let located_iter2 f (_,a) (_,b) = f a b
-let down_located f (_,a) = f a
-
-(* Like Exc_located, but specifies the outermost file read, the filename
-   associated to the location of the error, and the error itself. *)
-
-exception Error_in_file of string * (bool * string * loc) * exn
-
 (* Mapping under pairs *)
 
 let on_fst f (a,b) = (f a,b)
@@ -65,1195 +24,64 @@ let pi1 (a,_,_) = a
 let pi2 (_,a,_) = a
 let pi3 (_,_,a) = a
 
-(* Projection operator *)
-
-let down_fst f x = f (fst x)
-let down_snd f x = f (snd x)
-
 (* Characters *)
 
-let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z')
+let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
 let is_digit c = (c >= '0' && c <= '9')
 let is_ident_tail c =
-  is_letter c or is_digit c or c = '\'' or c = '_'
+  is_letter c || is_digit c || c = '\'' || c = '_'
 let is_blank = function
   | ' ' | '\r' | '\t' | '\n' -> true
   | _ -> false
 
-(* Strings *)
-
-let explode s =
-  let rec explode_rec n =
-    if n >= String.length s then
-      []
-    else
-      String.make 1 (String.get s n) :: explode_rec (succ n)
-  in
-  explode_rec 0
-
-let implode sl = String.concat "" sl
-
-let strip s =
-  let n = String.length s in
-  let rec lstrip_rec i =
-    if i < n && is_blank s.[i] then
-      lstrip_rec (i+1)
-    else i
-  in
-  let rec rstrip_rec i =
-    if i >= 0 && is_blank s.[i] then
-      rstrip_rec (i-1)
-    else i
-  in
-  let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
-  String.sub s a (b-a+1)
-
-let drop_simple_quotes s =
-  let n = String.length s in
-  if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
-
-(* substring searching... *)
-
-(* gdzie = where, co = what *)
-(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
-let rec is_sub gdzie gl gi co cl ci =
-  (ci>=cl) ||
-  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
-   (is_sub gdzie gl (gi+1) co cl (ci+1)))
-
-let rec raw_str_index i gdzie l c co cl =
-  (* First adapt to ocaml 3.11 new semantics of index_from *)
-  if (i+cl > l) then raise Not_found;
-  (* Then proceed as in ocaml < 3.11 *)
-  let i' = String.index_from gdzie i c in
-    if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else
-      raw_str_index (i'+1) gdzie l c co cl
-
-let string_index_from gdzie i co =
-  if co="" then i else
-    raw_str_index i gdzie (String.length gdzie)
-      (String.unsafe_get co 0) co (String.length co)
-
-let string_string_contains ~where ~what =
-  try
-    let _ = string_index_from where 0 what in true
-  with
-      Not_found -> false
-
-let plural n s = if n<>1 then s^"s" else s
-
-let ordinal n =
-  let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
-  string_of_int n ^ s
-
-(* string parsing *)
-
-let split_string_at c s =
-  let len = String.length s in
-  let rec split n =
-    try
-      let pos = String.index_from s n c in
-      let dir = String.sub s n (pos-n) in
-      dir :: split (succ pos)
-    with
-      | Not_found -> [String.sub s n (len-n)]
-  in
-  if len = 0 then [] else split 0
-
-let parse_loadpath s =
-  let l = split_string_at '/' s in
-  if List.mem "" l then
-    invalid_arg "parse_loadpath: find an empty dir in loadpath";
-  l
-
-module Stringset = Set.Make(struct type t = string let compare = compare end)
-
-module Stringmap = Map.Make(struct type t = string let compare = compare end)
-
-type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
-
-exception UnsupportedUtf8
-
-(* The following table stores classes of Unicode characters that
-   are used by the lexer. There are 3 different classes so 2 bits are
-   allocated for each character. We only use 16 bits over the 31 bits
-   to simplify the masking process. (This choice seems to be a good
-   trade-off between speed and space after some benchmarks.) *)
-
-(* A 256ko table, initially filled with zeros. *)
-let table = Array.create (1 lsl 17) 0
-
-(* Associate a 2-bit pattern to each status at position [i]. 
-   Only the 3 lowest bits of [i] are taken into account to 
-   define the position of the pattern in the word. 
-   Notice that pattern "00" means "undefined". *)
-let mask i = function
-  | UnicodeLetter    -> 1 lsl ((i land 7) lsl 1) (* 01 *)
-  | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
-  | UnicodeSymbol    -> 3 lsl ((i land 7) lsl 1) (* 11 *)
-
-(* Helper to reset 2 bits in a word. *)
-let reset_mask i =
-  lnot (3 lsl ((i land 7) lsl 1))
-
-(* Initialize the lookup table from a list of segments, assigning
-   a status to every character of each segment. The order of these
-   assignments is relevant: it is possible to assign status [s] to
-   a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
-   between [c1] and [c2]. *)
-let mk_lookup_table_from_unicode_tables_for status tables =
-  List.iter
-    (List.iter
-       (fun (c1, c2) ->
-          for i = c1 to c2 do
-            table.(i lsr 3) <-
-              (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
-          done))
-    tables
-
-(* Look up into the table and interpret the found pattern. *)
-let lookup x =
-  let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
-    if      v = 1 then UnicodeLetter
-    else if v = 2 then UnicodeIdentPart
-    else if v = 3 then UnicodeSymbol
-    else raise UnsupportedUtf8
-
-(* [classify_unicode] discriminates between 3 different kinds of
-   symbols based on the standard unicode classification (extracted from
-   Camomile). *)
-let classify_unicode =
-  let single c = [ (c, c) ] in
-    (* General tables. *)
-    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
-      [
-        Unicodetable.sm;           (* Symbol, maths.             *)
-        Unicodetable.sc;           (* Symbol, currency.          *)
-        Unicodetable.so;           (* Symbol, modifier.          *)
-        Unicodetable.pd;           (* Punctation, dash.          *)
-        Unicodetable.pc;           (* Punctation, connector.     *)
-        Unicodetable.pe;           (* Punctation, open.          *)
-        Unicodetable.ps;           (* Punctation, close.         *)
-        Unicodetable.pi;           (* Punctation, initial quote. *)
-        Unicodetable.pf;           (* Punctation, final quote.   *)
-        Unicodetable.po;           (* Punctation, other.         *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeLetter
-      [
-        Unicodetable.lu;           (* Letter, uppercase.         *)
-        Unicodetable.ll;           (* Letter, lowercase.         *)
-        Unicodetable.lt;           (* Letter, titlecase.         *)
-        Unicodetable.lo;           (* Letter, others.            *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
-      [
-        Unicodetable.nd;           (* Number, decimal digits.    *)
-        Unicodetable.nl;           (* Number, letter.            *)
-        Unicodetable.no;           (* Number, other.             *)
-      ];
-    (* Exceptions (from a previous version of this function). *)
-    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
-      [
-        single 0x000B2;            (* Squared.                   *)
-        single 0x0002E;            (* Dot.                       *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeLetter
-      [
-        single 0x005F;             (* Underscore.                *)
-        single 0x00A0;             (* Non breaking space.        *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
-      [
-        single 0x0027;             (* Special space.             *)
-      ];
-    (* Lookup *)
-    lookup
-
-exception End_of_input
-
-let utf8_of_unicode n =
-  if n < 128 then
-    String.make 1 (Char.chr n)
-  else if n < 2048 then
-    let s = String.make 2 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[0] <- Char.chr (192 + n / 64);
-      s
-    end
-  else if n < 65536 then
-    let s = String.make 3 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[1] <- Char.chr (128 + (n / 64) mod 64);
-      s.[0] <- Char.chr (224 + n / 4096);
-      s
-    end
-  else
-    let s = String.make 4 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[2] <- Char.chr (128 + (n / 64) mod 64);
-      s.[1] <- Char.chr (128 + (n / 4096) mod 64);
-      s.[0] <- Char.chr (240 + n / 262144);
-      s
-    end
-
-let next_utf8 s i =
-  let err () = invalid_arg "utf8" in
-  let l = String.length s - i in
-  if l = 0 then raise End_of_input
-  else let a = Char.code s.[i] in if a <= 0x7F then
-    1, a
-  else if a land 0x40 = 0 or l = 1 then err ()
-  else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err ()
-  else if a land 0x20 = 0 then
-    2, (a land 0x1F) lsl 6 + (b land 0x3F)
-  else if l = 2 then err ()
-  else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err ()
-  else if a land 0x10 = 0 then
-    3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F)
-  else if l = 3 then err ()
-  else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err ()
-  else if a land 0x08 = 0 then
-    4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 +
-       (c land 0x3F) lsl 6 + (d land 0x3F)
-  else err ()
-
-(* Check the well-formedness of an identifier *)
+module Empty =
+struct
+  type t
+  let abort (x : t) = assert false
+end
 
-let check_initial handle j n s =
-  match classify_unicode n with
-  | UnicodeLetter -> ()
-  | _ ->
-      let c = String.sub s 0 j in
-      handle ("Invalid character '"^c^"' at beginning of identifier \""^s^"\".")
+(* Strings *)
 
-let check_trailing handle i j n s =
-  match classify_unicode n with
-  | UnicodeLetter | UnicodeIdentPart -> ()
-  | _ ->
-      let c = String.sub s i j in
-      handle ("Invalid character '"^c^"' in identifier \""^s^"\".")
+module String : CString.ExtS = CString
 
-let check_ident_gen handle s =
+let subst_command_placeholder s t =
+  let buff = Buffer.create (String.length s + String.length t) in
   let i = ref 0 in
-  if s <> ".." then try
-    let j, n = next_utf8 s 0 in
-    check_initial handle j n s;
-    i := !i + j;
-    try
-      while true do
-	let j, n = next_utf8 s !i in
-	check_trailing handle !i j n s;
-	i := !i + j
-      done
-    with End_of_input -> ()
-  with
-  | End_of_input -> error "The empty string is not an identifier."
-  | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.")
-  | Invalid_argument _ -> error (s^": invalid utf8 sequence.")
-
-let check_ident_soft = check_ident_gen warning
-let check_ident = check_ident_gen error
-
-let lowercase_unicode =
-  let tree = Segmenttree.make Unicodetable.to_lower in
-  fun unicode ->
-    try
-      match Segmenttree.lookup unicode tree with
-	| `Abs c -> c
-	| `Delta d -> unicode + d
-    with Not_found -> unicode
-
-let lowercase_first_char_utf8 s =
-  assert (s <> "");
-  let j, n = next_utf8 s 0 in
-  utf8_of_unicode (lowercase_unicode n)
-
-(** For extraction, we need to encode unicode character into ascii ones *)
-
-let ascii_of_ident s =
-  let check_ascii s =
-    let ok = ref true in
-    String.iter (fun c -> if Char.code c >= 128 then ok := false) s;
-    !ok
-  in
-  if check_ascii s then s else
-    let i = ref 0 and out = ref "" in
-    begin try while true do
-      let j, n = next_utf8 s !i in
-      out :=
-	if n >= 128
-	then Printf.sprintf "%s__U%04x_" !out n
-	else Printf.sprintf "%s%c" !out s.[!i];
-      i := !i + j
-    done with End_of_input -> () end;
-    !out
+  while (!i < String.length s) do
+    if s.[!i] = '%' && !i+1 < String.length s && s.[!i+1] = 's'
+    then (Buffer.add_string buff t;incr i)
+    else Buffer.add_char buff s.[!i];
+    incr i
+  done;
+  Buffer.contents buff
 
 (* Lists *)
 
-let rec list_compare cmp l1 l2 =
-  match l1,l2 with
-      [], [] -> 0
-    | _::_, [] -> 1
-    | [], _::_ -> -1
-    | x1::l1, x2::l2 ->
-	(match cmp x1 x2 with
-	   | 0 -> list_compare cmp l1 l2
-	   | c -> c)
-
-let rec list_equal cmp l1 l2 =
-  match l1, l2 with
-    | [], [] -> true
-    | x1 :: l1, x2 :: l2 ->
-      cmp x1 x2 && list_equal cmp l1 l2
-    | _ -> false
-
-let list_intersect l1 l2 =
-  List.filter (fun x -> List.mem x l2) l1
-
-let list_union l1 l2 =
-  let rec urec = function
-    | [] -> l2
-    | a::l -> if List.mem a l2 then urec l else a::urec l
-  in
-  urec l1
-
-let list_unionq l1 l2 =
-  let rec urec = function
-    | [] -> l2
-    | a::l -> if List.memq a l2 then urec l else a::urec l
-  in
-  urec l1
-
-let list_subtract l1 l2 =
-  if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1
-
-let list_subtractq l1 l2 =
-  if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1
-
-let list_tabulate f len =
-  let rec tabrec n =
-    if n = len then [] else (f n)::(tabrec (n+1))
-  in
-  tabrec 0
-
-let list_addn n v =
-  let rec aux n l =
-    if n = 0 then l
-    else aux (pred n) (v::l)
-  in
-    if n < 0 then invalid_arg "list_addn"
-    else aux n
-
-let list_make n v = list_addn n v []
-
-let list_assign l n e =
-  let rec assrec stk = function
-    | ((h::t), 0) -> List.rev_append stk (e::t)
-    | ((h::t), n) -> assrec (h::stk) (t, n-1)
-    | ([], _) -> failwith "list_assign"
-  in
-  assrec [] (l,n)
-
-let rec list_smartmap f l = match l with
-    [] -> l
-  | h::tl ->
-      let h' = f h and tl' = list_smartmap f tl in
-	if h'==h && tl'==tl then l
-	else h'::tl'
-
-let list_map_left f = (* ensures the order in case of side-effects *)
-  let rec map_rec = function
-    | [] -> []
-    | x::l -> let v = f x in v :: map_rec l
-  in
-  map_rec
-
-let list_map_i f =
-  let rec map_i_rec i = function
-    | [] -> []
-    | x::l -> let v = f i x in v :: map_i_rec (i+1) l
-  in
-  map_i_rec
-
-let list_map2_i f i l1 l2 =
-  let rec map_i i = function
-    | ([], []) -> []
-    | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
-    | (_, _) -> invalid_arg "map2_i"
-  in
-  map_i i (l1,l2)
-
-let list_map3 f l1 l2 l3 =
-  let rec map = function
-    | ([], [], []) -> []
-    | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
-    | (_, _, _) -> invalid_arg "map3"
-  in
-  map (l1,l2,l3)
-
-let list_map4 f l1 l2 l3 l4 =
-  let rec map = function
-    | ([], [], [], []) -> []
-    | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
-    | (_, _, _, _) -> invalid_arg "map4"
-  in
-  map (l1,l2,l3,l4)
-
-let list_map_to_array f l =
-  Array.of_list (List.map f l)
-
-let rec list_smartfilter f l = match l with
-    [] -> l
-  | h::tl ->
-      let tl' = list_smartfilter f tl in
-	if f h then
-	  if tl' == tl then l
-	  else h :: tl'
-	else tl'
-	  
-let list_index_f f x =
-  let rec index_x n = function
-    | y::l -> if f x y then n else index_x (succ n) l
-    | [] -> raise Not_found
-  in
-  index_x 1
-
-let list_index0_f f x l = list_index_f f x l - 1
-
-let list_index x =
-  let rec index_x n = function
-    | y::l -> if x = y then n else index_x (succ n) l
-    | [] -> raise Not_found
-  in
-  index_x 1
-
-let list_index0 x l = list_index x l - 1
-
-let list_unique_index x =
-  let rec index_x n = function
-    | y::l ->
-	if x = y then
-	  if List.mem x l then raise Not_found
-	  else n
-	else index_x (succ n) l
-    | [] -> raise Not_found
-  in index_x 1
-
-let list_fold_right_i f i l =
-  let rec it_list_f i l a = match l with
-    | [] -> a
-    | b::l -> f (i-1) b (it_list_f (i-1) l a)
-  in
-  it_list_f (List.length l + i) l
-
-let list_fold_left_i f =
-  let rec it_list_f i a = function
-    | [] -> a
-    | b::l -> it_list_f (i+1) (f i a b) l
-  in
-  it_list_f
-
-let rec list_fold_left3 f accu l1 l2 l3 =
-  match (l1, l2, l3) with
-    ([], [], []) -> accu
-  | (a1::l1, a2::l2, a3::l3) -> list_fold_left3 f (f accu a1 a2 a3) l1 l2 l3
-  | (_, _, _) -> invalid_arg "list_fold_left3"
-
-(* [list_fold_right_and_left f [a1;...;an] hd =
-   f (f (... (f (f hd
-                   an
-                   [an-1;...;a1])
-              an-1
-              [an-2;...;a1])
-         ...)
-        a2
-        [a1])
-     a1
-     []] *)
-
-let rec list_fold_right_and_left f l hd =
-  let rec aux tl = function
-    | [] -> hd
-    | a::l -> let hd = aux (a::tl) l in f hd a tl
-   in aux [] l
-
-let list_iter3 f l1 l2 l3 =
-  let rec iter = function
-    | ([], [], []) -> ()
-    | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3)
-    | (_, _, _) -> invalid_arg "map3"
-  in
-  iter (l1,l2,l3)
-
-let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l
-
-let list_for_all_i p =
-  let rec for_all_p i = function
-    | [] -> true
-    | a::l -> p i a && for_all_p (i+1) l
-  in
-  for_all_p
-
-let list_except x l = List.filter (fun y -> not (x = y)) l
-
-let list_remove = list_except (* Alias *)
-
-let rec list_remove_first a = function
-  | b::l when a = b -> l
-  | b::l -> b::list_remove_first a l
-  | [] -> raise Not_found
-
-let rec list_remove_assoc_in_triple x = function
-  | [] -> []
-  | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l
-
-let rec list_assoc_snd_in_triple x = function
-    [] -> raise Not_found
-  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_snd_in_triple x l
-
-let list_add_set x l = if List.mem x l then l else x::l
-
-let list_eq_set l1 l2 =
-  let rec aux l1 = function
-  | [] -> l1 = []
-  | a::l2 -> aux (list_remove_first a l1) l2 in
-  try aux l1 l2 with Not_found -> false
-
-let list_for_all2eq f l1 l2 =
-  try List.for_all2 f l1 l2 with Invalid_argument _ -> false
-
-let list_filter_i p =
-  let rec filter_i_rec i = function
-    | [] -> []
-    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
-  in
-  filter_i_rec 0
-
-let rec list_sep_last = function
-  | [] -> failwith "sep_last"
-  | hd::[] -> (hd,[])
-  | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
-
-let list_try_find_i f =
-  let rec try_find_f n = function
-    | [] -> failwith "try_find_i"
-    | h::t -> try f n h with Failure _ -> try_find_f (n+1) t
-  in
-  try_find_f
-
-let list_try_find f =
-  let rec try_find_f = function
-    | [] -> failwith "try_find"
-    | h::t -> try f h with Failure _ -> try_find_f t
-  in
-  try_find_f
-
-let list_uniquize l =
-  let visited = Hashtbl.create 23 in
-  let rec aux acc = function
-    | h::t -> if Hashtbl.mem visited h then aux acc t else
-	  begin
-	    Hashtbl.add visited h h;
-	    aux (h::acc) t
-	  end
-    | [] -> List.rev acc
-  in aux [] l
-
-let rec list_distinct l =
-  let visited = Hashtbl.create 23 in
-  let rec loop = function
-    | h::t ->
-	if Hashtbl.mem visited h then false
-	else
-	  begin
-	    Hashtbl.add visited h h;
-	    loop t
-	  end
-    | [] -> true
-  in loop l
-
-let rec list_merge_uniq cmp l1 l2 =
-  match l1, l2 with
-  | [], l2 -> l2
-  | l1, [] -> l1
-  | h1 :: t1, h2 :: t2 ->
-      let c = cmp h1 h2 in
-      if c = 0
-      then h1 :: list_merge_uniq cmp t1 t2
-      else if c <= 0
-      then h1 :: list_merge_uniq cmp t1 l2
-      else h2 :: list_merge_uniq cmp l1 t2
-
-let rec list_duplicates = function
-  | [] -> []
-  | x::l ->
-      let l' = list_duplicates l in
-      if List.mem x l then list_add_set x l' else l'
-
-let rec list_filter2 f = function
-  | [], [] as p -> p
-  | d::dp, l::lp ->
-     let (dp',lp' as p) = list_filter2 f (dp,lp) in
-      if f d l then d::dp', l::lp' else p
-  | _ -> invalid_arg "list_filter2"
-
-let rec list_map_filter f = function
-  | [] -> []
-  | x::l ->
-      let l' = list_map_filter f l in
-      match f x with None -> l' | Some y -> y::l'
-
-let list_map_filter_i f =
-  let rec aux i = function
-    | [] -> []
-    | x::l ->
-      let l' = aux (succ i) l in
-	match f i x with None -> l' | Some y -> y::l'
-  in aux 0
-
-let list_filter_along f filter l =
-  snd (list_filter2 (fun b c -> f b) (filter,l))
-
-let list_filter_with filter l =
-  list_filter_along (fun x -> x) filter l
-
-let list_subset l1 l2 =
-  let t2 = Hashtbl.create 151 in
-  List.iter (fun x -> Hashtbl.add t2 x ()) l2;
-  let rec look = function
-    | [] -> true
-    | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
-  in
-  look l1
-
-(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that
-   [l1++l2=l] and [l1] has length [i].
-   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
-
-let list_chop n l =
-  let rec chop_aux i acc = function
-    | tl when i=0 -> (List.rev acc, tl)
-    | h::t -> chop_aux (pred i) (h::acc) t
-    | [] -> failwith "list_chop"
-  in
-  chop_aux n [] l
-
-(* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that
-    [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
-    If there is no such [a], then it returns [(l,[])] instead *)
-let list_split_when p =
-  let rec split_when_loop x y =
-    match y with
-      | []      -> (List.rev x,[])
-      | (a::l)  -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
-  in
-  split_when_loop []
-
-(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of
-   [l1] satisfy [p] and elements of [l2] do not; order is preserved *)
-let list_split_by p =
-  let rec split_by_loop = function
-  | []   -> ([],[])
-  | a::l ->
-      let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2)
-  in
-  split_by_loop
-
-let rec list_split3 = function
-  | [] -> ([], [], [])
-  | (x,y,z)::l ->
-      let (rx, ry, rz) = list_split3 l in (x::rx, y::ry, z::rz)
-
-let rec list_insert_in_class f a = function
-  | [] -> [[a]]
-  | (b::_ as l)::classes when f a b -> (a::l)::classes
-  | l::classes -> l :: list_insert_in_class f a classes
-
-let list_partition_by f l =
-  List.fold_right (list_insert_in_class f) l []
-
-let list_firstn n l =
-  let rec aux acc = function
-    | (0, l) -> List.rev acc
-    | (n, (h::t)) -> aux (h::acc) (pred n, t)
-    | _ -> failwith "firstn"
-  in
-  aux [] (n,l)
-
-let rec list_last = function
-  | [] -> failwith "list_last"
-  | [x] -> x
-  | _ :: l -> list_last l
-
-let list_lastn n l =
-  let len = List.length l in
-  let rec aux m l =
-    if m = n then l else aux (m - 1) (List.tl l)
-  in
-  if len < n then failwith "lastn" else aux len l
-
-let rec list_skipn n l = match n,l with
-  | 0, _ -> l
-  | _, [] -> failwith "list_skipn"
-  | n, _::l -> list_skipn (pred n) l
-
-let rec list_skipn_at_least n l =
-  try list_skipn n l with Failure _ -> []
-
-let list_prefix_of prefl l =
-  let rec prefrec = function
-    | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
-    | ([], _) -> true
-    | (_, _) -> false
-  in
-    prefrec (prefl,l)
-
-let list_drop_prefix p l =
-(* if l=p++t then return t else l *)
-  let rec list_drop_prefix_rec = function
-    | ([], tl) -> Some tl
-    | (_, []) -> None
-    | (h1::tp, h2::tl) ->
-	if h1 = h2 then list_drop_prefix_rec (tp,tl) else None
-  in
-    match list_drop_prefix_rec (p,l) with
-      | Some r -> r
-      | None -> l
-
-let list_map_append f l = List.flatten (List.map f l)
-let list_join_map = list_map_append   (* Alias *)
-
-let list_map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
-
-let list_share_tails l1 l2 =
-  let rec shr_rev acc = function
-    | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
-    | (l1,l2) -> (List.rev l1, List.rev l2, acc)
-  in
-  shr_rev [] (List.rev l1, List.rev l2)
-
-let rec list_fold_map f e = function
-  |  []  -> (e,[])
-  |  h::t ->
-       let e',h' = f e h in
-       let e'',t' = list_fold_map f e' t in
-         e'',h'::t'
-
-(* (* tail-recursive version of the above function *)
-let list_fold_map f e l =
-  let g (e,b') h =
-    let (e',h') = f e h in
-      (e',h'::b')
-  in
-  let (e',lrev) = List.fold_left g (e,[]) l in
-    (e',List.rev lrev)
-*)
-
-(* The same, based on fold_right, with the effect accumulated on the right *)
-let list_fold_map' f l e =
-  List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
-
-let list_map_assoc f = List.map (fun (x,a) -> (x,f a))
-
-let rec list_assoc_f f a = function
-  | (x, e) :: xs -> if f a x then e else list_assoc_f f a xs
-  | [] -> raise Not_found
-
-(* Specification:
-   - =p= is set equality (double inclusion)
-   - f such that \forall l acc, (f l acc) =p= append (f l []) acc
-   - let g = fun x -> f x [] in
-   - union_map f l acc =p= append (flatten (map g l)) acc
- *)
-let list_union_map f l acc =
-  List.fold_left
-    (fun x y -> f y x)
-    acc
-    l
-
-(* A generic cartesian product: for any operator (**),
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
-   and so on if there are more elements in the lists. *)
-
-let rec list_cartesian op l1 l2 =
-  list_map_append (fun x -> List.map (op x) l2) l1
-
-(* [list_cartesians] is an n-ary cartesian product: it iterates
-   [list_cartesian] over a list of lists.  *)
-
-let list_cartesians op init ll =
-  List.fold_right (list_cartesian op) ll [init]
-
-(* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
-
-let list_combinations l = list_cartesians (fun x l -> x::l) [] l
-
-let rec list_combine3 x y z = 
-  match x, y, z with
-  | [], [], [] -> []
-  | (x :: xs), (y :: ys), (z :: zs) ->
-      (x, y, z) :: list_combine3 xs ys zs
-  | _, _, _ -> raise (Invalid_argument "list_combine3")
-  
-(* Keep only those products that do not return None *)
-
-let rec list_cartesian_filter op l1 l2 =
-  list_map_append (fun x -> list_map_filter (op x) l2) l1
+module List : CList.ExtS = CList
 
-(* Keep only those products that do not return None *)
-
-let rec list_cartesians_filter op init ll =
-  List.fold_right (list_cartesian_filter op) ll [init]
-
-(* Drop the last element of a list *)
-
-let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl
-
-(* Factorize lists of pairs according to the left argument *)
-let rec list_factorize_left = function
-  | (a,b)::l ->
-      let al,l' = list_split_by (fun (a',b) -> a=a') l in
-      (a,(b::List.map snd al)) :: list_factorize_left l'
-  | [] ->
-      []
+let (@) = CList.append
 
 (* Arrays *)
 
-let array_compare item_cmp v1 v2 =
-  let c = compare (Array.length v1) (Array.length v2) in
-  if c<>0 then c else
-    let rec cmp = function
-	-1 -> 0
-      | i ->
-	  let c' = item_cmp v1.(i) v2.(i) in
-	  if c'<>0 then c'
-	  else cmp (i-1) in
-    cmp (Array.length v1 - 1)
-
-let array_equal cmp t1 t2 =
-  Array.length t1 = Array.length t2 &&
-  let rec aux i =
-    (i = Array.length t1) || (cmp t1.(i) t2.(i) && aux (i + 1))
-  in aux 0
-
-let array_exists f v =
-  let rec exrec = function
-    | -1 -> false
-    | n -> (f v.(n)) || (exrec (n-1))
-  in
-  exrec ((Array.length v)-1)
-
-let array_for_all f v =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v.(n)) && (allrec (n-1))
-  in
-  allrec ((Array.length v)-1)
-
-let array_for_all2 f v1 v2 =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v1.(n) v2.(n)) && (allrec (n-1))
-  in
-  let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && allrec (pred lv1)
-
-let array_for_all3 f v1 v2 v3 =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1))
-  in
-  let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
-
-let array_for_all4 f v1 v2 v3 v4 =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1))
-  in
-  let lv1 = Array.length v1 in
-  lv1 = Array.length v2 &&
-  lv1 = Array.length v3 &&
-  lv1 = Array.length v4 &&
-    allrec (pred lv1)
-
-let array_for_all_i f i v =
-  let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in
-  allrec i 0
-
-exception Found of int
-
-let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    None
-  with Found i -> Some i
-
-let array_hd v =
-  match Array.length v with
-    | 0 -> failwith "array_hd"
-    | _ -> v.(0)
+module Array : CArray.ExtS = CArray
 
-let array_tl v =
-  match Array.length v with
-    | 0 -> failwith "array_tl"
-    | n -> Array.sub v 1 (pred n)
+(* Sets *)
 
-let array_last v =
-  match Array.length v with
-    | 0 -> failwith "array_last"
-    | n -> v.(pred n)
+module Set = CSet
 
-let array_cons e v = Array.append [|e|] v
+(* Maps *)
 
-let array_rev t =
-  let n=Array.length t in
-    if n <=0 then ()
-    else
-      let tmp=ref t.(0) in
-      for i=0 to pred (n/2) do
-	tmp:=t.((pred n)-i);
-	t.((pred n)-i)<- t.(i);
-	t.(i)<- !tmp
-      done
+module Map = CMap
 
-let array_fold_right_i f v a =
-  let rec fold a n =
-    if n=0 then a
-    else
-      let k = n-1 in
-      fold (f k v.(k) a) k in
-  fold a (Array.length v)
+(* Stacks *)
 
-let array_fold_left_i f v a =
-  let n = Array.length a in
-  let rec fold i v = if i = n then v else fold (succ i) (f i v a.(i)) in
-  fold 0 v
-
-let array_fold_right2 f v1 v2 a =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n=0 then a
-    else
-      let k = n-1 in
-      fold (f v1.(k) v2.(k) a) k in
-  if Array.length v2 <> lv1 then invalid_arg "array_fold_right2";
-  fold a lv1
-
-let array_fold_left2 f a v1 v2 =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n)
-  in
-  if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
-  fold a 0
-
-let array_fold_left2_i f a v1 v2 =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n)
-  in
-  if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
-  fold a 0
-
-let array_fold_left3 f a v1 v2 v3 =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n >= lv1 then a else fold (f a v1.(n) v2.(n) v3.(n)) (succ n)
-  in
-  if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
-    invalid_arg "array_fold_left2";
-  fold a 0
-
-let array_fold_left_from n f a v =
-  let rec fold a n =
-    if n >= Array.length v then a else fold (f a v.(n)) (succ n)
-  in
-  fold a n
-
-let array_fold_right_from n f v a =
-  let rec fold n =
-    if n >= Array.length v then a else f v.(n) (fold (succ n))
-  in
-  fold n
-
-let array_app_tl v l =
-  if Array.length v = 0 then invalid_arg "array_app_tl";
-  array_fold_right_from 1 (fun e l -> e::l) v l
-
-let array_list_of_tl v =
-  if Array.length v = 0 then invalid_arg "array_list_of_tl";
-  array_fold_right_from 1 (fun e l -> e::l) v []
-
-let array_map_to_list f v =
-  List.map f (Array.to_list v)
-
-let array_chop n v =
-  let vlen = Array.length v in
-  if n > vlen then failwith "array_chop";
-  (Array.sub v 0 n, Array.sub v n (vlen-n))
-
-exception Local of int
-
-(* If none of the elements is changed by f we return ar itself.
-   The for loop looks for the first such an element.
-   If found it is temporarily stored in a ref and the new array is produced,
-   but f is not re-applied to elements that are already checked *)
-let array_smartmap f ar =
-  let ar_size = Array.length ar in
-  let aux = ref None in
-  try
-    for i = 0 to ar_size-1 do
-      let a = ar.(i) in
-      let a' = f a in
-	if a != a' then (* pointer (in)equality *) begin
-	  aux := Some a';
-	  raise (Local i)
-	end
-    done;
-    ar
-  with
-      Local i ->
-	let copy j =
-	  if j<i then ar.(j)
-	  else if j=i then
-	    match !aux with Some a' -> a' | None -> failwith "Error"
-	  else f (ar.(j))
-	in
-	  Array.init ar_size copy
-
-let array_map2 f v1 v2 =
-  if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then
-    [| |]
-  else begin
-    let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in
-    for i = 1 to pred (Array.length v1) do
-      res.(i) <- f v1.(i) v2.(i)
-    done;
-    res
-  end
-
-let array_map2_i f v1 v2 =
-  if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then
-    [| |]
-  else begin
-    let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in
-    for i = 1 to pred (Array.length v1) do
-      res.(i) <- f i v1.(i) v2.(i)
-    done;
-    res
-  end
-
-let array_map3 f v1 v2 v3 =
-  if Array.length v1 <> Array.length v2 ||
-     Array.length v1 <> Array.length v3 then invalid_arg "array_map3";
-  if Array.length v1 == 0 then
-    [| |]
-  else begin
-    let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in
-    for i = 1 to pred (Array.length v1) do
-      res.(i) <- f v1.(i) v2.(i) v3.(i)
-    done;
-    res
-  end
-
-let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *)
-  let l = Array.length a in (* (even if so), then we rewrite it *)
-  if l = 0 then [||] else begin
-    let r = Array.create l (f a.(0)) in
-    for i = 1 to l - 1 do
-      r.(i) <- f a.(i)
-    done;
-    r
-  end
-
-let array_map_left_pair f a g b =
-  let l = Array.length a in
-  if l = 0 then [||],[||] else begin
-    let r = Array.create l (f a.(0)) in
-    let s = Array.create l (g b.(0)) in
-    for i = 1 to l - 1 do
-      r.(i) <- f a.(i);
-      s.(i) <- g b.(i)
-    done;
-    r, s
-  end
-
-let array_iter2 f v1 v2 =
-  let n = Array.length v1 in
-  if Array.length v2 <> n then invalid_arg "array_iter2"
-  else for i = 0 to n - 1 do f v1.(i) v2.(i) done
-
-let pure_functional = false
-
-let array_fold_map' f v e =
-if pure_functional then
-  let (l,e) =
-    Array.fold_right
-      (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
-      v ([],e) in
-  (Array.of_list l,e)
-else
-  let e' = ref e in
-  let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
-  (v',!e')
-
-let array_fold_map f e v =
-  let e' = ref e in
-  let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in
-  (!e',v')
-
-let array_fold_map2' f v1 v2 e =
-  let e' = ref e in
-  let v' =
-    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
-  in
-  (v',!e')
-
-let array_distinct v =
-  let visited = Hashtbl.create 23 in
-  try
-    Array.iter
-      (fun x ->
-        if Hashtbl.mem visited x then raise Exit
-        else Hashtbl.add visited x x)
-      v;
-    true
-  with Exit -> false
-
-let array_union_map f a acc =
-  Array.fold_left
-    (fun x y -> f y x)
-    acc
-    a
-
-let array_rev_to_list a =
-  let rec tolist i res =
-    if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
-  tolist 0 []
-
-let array_filter_along f filter v =
-  Array.of_list (list_filter_along f filter (Array.to_list v))
-
-let array_filter_with filter v =
-  Array.of_list (list_filter_with filter (Array.to_list v))
-
-(* Stream *)
-
-let stream_nth n st =
-  try List.nth (Stream.npeek (n+1) st) n
-  with Failure _ -> raise Stream.Failure
-
-let stream_njunk n st =
-  for i = 1 to n do Stream.junk st done
+module Stack = CStack
 
 (* Matrices *)
 
 let matrix_transpose mat =
   List.fold_right (List.map2 (fun p c -> p::c)) mat
-    (if mat = [] then [] else List.map (fun _ -> []) (List.hd mat))
+    (if List.is_empty mat then [] else List.map (fun _ -> []) (List.hd mat))
 
 (* Functions *)
 
@@ -1263,18 +91,28 @@ let compose f g x = f (g x)
 
 let const x _ = x
 
-let iterate f =
-  let rec iterate_f n x =
-    if n <= 0 then x else iterate_f (pred n) (f x)
+let iterate =
+  let rec iterate_f f n x =
+    if n <= 0 then x else iterate_f f (pred n) (f x)
   in
   iterate_f
 
 let repeat n f x =
-  for i = 1 to n do f x done
+  let rec loop i = if i <> 0 then (f x; loop (i - 1)) in loop n
+
+let app_opt f x =
+  match f with
+  | Some f -> f x
+  | None -> x
 
-let iterate_for a b f x =
-  let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
-  iterate a x
+(* Stream *)
+
+let stream_nth n st =
+  try List.nth (Stream.npeek (n+1) st) n
+  with Failure _ -> raise Stream.Failure
+
+let stream_njunk n st =
+  repeat n Stream.junk st
 
 (* Delayed computations *)
 
@@ -1284,245 +122,13 @@ let delayed_force f = f ()
 
 (* Misc *)
 
-type ('a,'b) union = Inl of 'a | Inr of 'b
-
-module Intset = Set.Make(struct type t = int let compare = compare end)
-
-module Intmap = Map.Make(struct type t = int let compare = compare end)
-
-let intmap_in_dom x m =
-  try let _ = Intmap.find x m in true with Not_found -> false
-
-let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m []
-
-let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m []
-
-let interval n m =
-  let rec interval_n (l,m) =
-    if n > m then l else interval_n (m::l,pred m)
-  in
-  interval_n ([],m)
-
-
-let map_succeed f =
-  let rec map_f = function
-    | [] -> []
-    |  h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t
-  in
-  map_f
-
-(* Pretty-printing *)
-
-let pr_spc = spc
-let pr_fnl = fnl
-let pr_int = int
-let pr_str = str
-let pr_comma () = str "," ++ spc ()
-let pr_semicolon () = str ";" ++ spc ()
-let pr_bar () = str "|" ++ spc ()
-let pr_arg pr x = spc () ++ pr x
-let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
-let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x
-
-let nth n = str (ordinal n)
-
-(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
-
-let rec prlist elem l = match l with
-  | []   -> mt ()
-  | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t)
-
-(* unlike all other functions below, [prlist] works lazily.
-   if a strict behavior is needed, use [prlist_strict] instead.
-   evaluation is done from left to right. *)
-
-let rec prlist_strict elem l = match l with
-  | []   -> mt ()
-  | h::t ->
-      let e = elem h in let r = prlist_strict elem t in e++r
-
-(* [prlist_with_sep sep pr [a ; ... ; c]] outputs
-   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
-
-let rec prlist_with_sep sep elem l = match l with
-  | []   -> mt ()
-  | [h]  -> elem h
-  | h::t ->
-      let e = elem h and s = sep() and r = prlist_with_sep sep elem t in
-      e ++ s ++ r
-
-(* Print sequence of objects separated by space (unless an element is empty) *)
-
-let rec pr_sequence elem = function
-  | []   -> mt ()
-  | [h]  -> elem h
-  | h::t ->
-      let e = elem h and r = pr_sequence elem t in
-      if e = mt () then r else e ++ spc () ++ r
-
-(* [pr_enum pr [a ; b ; ... ; c]] outputs
-   [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
-
-let pr_enum pr l =
-  let c,l' = list_sep_last l in
-  prlist_with_sep pr_comma pr l' ++
-  (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c
-
-let pr_vertical_list pr = function
-  | [] -> str "none" ++ fnl ()
-  | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl ()
-
-(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs
-   [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *)
-
-let prvecti_with_sep sep elem v =
-  let rec pr i =
-    if i = 0 then
-      elem 0 v.(0)
-    else
-      let r = pr (i-1) and s = sep () and e = elem i v.(i) in
-      r ++ s ++ e
-  in
-  let n = Array.length v in
-  if n = 0 then mt () else pr (n - 1)
-
-(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *)
-
-let prvecti elem v = prvecti_with_sep mt elem v
-
-(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs
-   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
-
-let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
-
-(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *)
-
-let prvect elem v = prvect_with_sep mt elem v
-
-let pr_located pr (loc,x) =
-  if Flags.do_beautify() && loc<>dummy_loc then
-    let (b,e) = unloc loc in
-    comment b ++ pr x ++ comment e
-  else pr x
-
-let surround p = hov 1 (str"(" ++ p ++ str")")
-
-(*s Memoization *)
-
-let memo1_eq eq f =
-  let m = ref None in
-  fun x ->
-    match !m with
-        Some(x',y') when eq x x' -> y'
-      | _ -> let y = f x in m := Some(x,y); y
-
-let memo1_1 f = memo1_eq (==) f
-let memo1_2 f =
-  let f' =
-    memo1_eq (fun (x,y) (x',y') -> x==x' && y==y') (fun (x,y) -> f x y) in
-  (fun x y -> f'(x,y))
-
-(* Memorizes the last n distinct calls to f. Since there is no hash,
-   Efficient only for small n. *)
-let memon_eq eq n f =
-  let cache = ref [] in (* the cache: a stack *)
-  let m = ref 0 in      (* usage of the cache *)
-  let rec find x = function
-    | (x',y')::l when eq x x' -> y', l (* cell is moved to the top *)
-    | [] -> (* we assume n>0, so creating one memo cell is OK *)
-        incr m; (f x, [])
-    | [_] when !m>=n -> f x,[] (* cache is full: dispose of last cell *)
-    | p::l (* not(eq x (fst p)) *) -> let (y,l') = find x l in (y, p::l')
-  in
-  (fun x ->
-    let (y,l) = find x !cache in
-    cache := (x,y)::l;
-    y)
-
-
-(*s Size of ocaml values. *)
-
-module Size = struct
-
-  (*s Pointers already visited are stored in a hash-table, where
-      comparisons are done using physical equality. *)
-
-  module H = Hashtbl.Make(
-    struct
-      type t = Obj.t
-      let equal = (==)
-      let hash o = Hashtbl.hash (Obj.magic o : int)
-    end)
-
-  let node_table = (H.create 257 : unit H.t)
-
-  let in_table o = try H.find node_table o; true with Not_found -> false
-
-  let add_in_table o = H.add node_table o ()
-
-  let reset_table () = H.clear node_table
-
-  (*s Objects are traversed recursively, as soon as their tags are less than
-      [no_scan_tag]. [count] records the numbers of words already visited. *)
-
-  let size_of_double = Obj.size (Obj.repr 1.0)
-
-  let count = ref 0
-
-  let rec traverse t =
-    if not (in_table t) then begin
-      add_in_table t;
-      if Obj.is_block t then begin
-	let n = Obj.size t in
-	let tag = Obj.tag t in
-	if tag < Obj.no_scan_tag then begin
-	  count := !count + 1 + n;
-	  for i = 0 to n - 1 do
-      	    let f = Obj.field t i in
-	    if Obj.is_block f then traverse f
-	  done
-	end else if tag = Obj.string_tag then
-	  count := !count + 1 + n
-	else if tag = Obj.double_tag then
-	  count := !count + size_of_double
-	else if tag = Obj.double_array_tag then
-	  count := !count + 1 + size_of_double * n
-	else
-	  incr count
-      end
-    end
-
-  (*s Sizes of objects in words and in bytes. The size in bytes is computed
-      system-independently according to [Sys.word_size]. *)
-
-  let size_w o =
-    reset_table ();
-    count := 0;
-    traverse (Obj.repr o);
-    !count
-
-  let size_b o = (size_w o) * (Sys.word_size / 8)
-
-  let size_kb o = (size_w o) / (8192 / Sys.word_size)
-
-end
-
-let size_w = Size.size_w
-let size_b = Size.size_b
-let size_kb = Size.size_kb
-
-(*s Total size of the allocated ocaml heap. *)
-
-let heap_size () =
-  let stat = Gc.stat ()
-  and control = Gc.get () in
-  let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
-  (max_words_total * (Sys.word_size / 8))
+type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
+type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
 
-let heap_size_kb () = (heap_size () + 1023) / 1024
+let map_union f g = function
+  | Inl a -> Inl (f a)
+  | Inr b -> Inr (g b)
 
-(*s interruption *)
+type iexn = Exninfo.iexn
 
-let interrupt = ref false
-let check_for_interrupt () =
-  if !interrupt then begin interrupt := false; raise Sys.Break end
+let iraise = Exninfo.iraise
diff --git a/lib/util.mli b/lib/util.mli
index 530e838a..4fce809c 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -1,73 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp
-open Compat
-
 (** This module contains numerous utility functions on strings, lists,
    arrays, etc. *)
 
-(** {6 ... } *)
-(** Errors. [Anomaly] is used for system errors and [UserError] for the
-   user's ones. *)
-
-exception Anomaly of string * std_ppcmds
-val anomaly : string -> 'a
-val anomalylabstrm : string -> std_ppcmds -> 'a
-
-exception UserError of string * std_ppcmds
-val error : string -> 'a
-val errorlabstrm : string -> std_ppcmds -> 'a
-
-exception AlreadyDeclared of std_ppcmds
-val alreadydeclared : std_ppcmds -> 'a
-
-(** [todo] is for running of an incomplete code its implementation is
-   "do nothing" (or print a message), but this function should not be
-   used in a released code *)
-
-val todo : string -> unit
-
-exception Timeout
-
-type loc = Loc.t
-
-type 'a located = loc * 'a
-
-val unloc : loc -> int * int
-val make_loc : int * int -> loc
-val dummy_loc : loc
-val join_loc : loc -> loc -> loc
-
-val anomaly_loc : loc * string * std_ppcmds -> 'a
-val user_err_loc : loc * string * std_ppcmds -> 'a
-val invalid_arg_loc : loc * string -> 'a
-val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
-val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
-val down_located : ('a -> 'b) -> 'a located -> 'b
-
-(** Like [Exc_located], but specifies the outermost file read, the
-   input buffer associated to the location of the error (or the module name
-   if boolean is true), and the error itself. *)
-
-exception Error_in_file of string * (bool * string * loc) * exn
-
 (** Mapping under pairs *)
 
 val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
 val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
 val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b
 
-(** Going down pairs *)
-
-val down_fst : ('a -> 'b) -> 'a * 'c -> 'b
-val down_snd : ('a -> 'b) -> 'c * 'a -> 'b
-
 (** Mapping under triple *)
 
 val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd
@@ -87,216 +34,42 @@ val is_digit : char -> bool
 val is_ident_tail : char -> bool
 val is_blank : char -> bool
 
+(** {6 Empty type} *)
+
+module Empty :
+sig
+  type t
+  val abort : t -> 'a
+end
+
 (** {6 Strings. } *)
 
-val explode : string -> string list
-val implode : string list -> string
-val strip : string -> string
-val drop_simple_quotes : string -> string
-val string_index_from : string -> int -> string -> int
-val string_string_contains : where:string -> what:string -> bool
-val plural : int -> string -> string
-val ordinal : int -> string
-val split_string_at : char -> string -> string list
+module String : CString.ExtS
 
-val parse_loadpath : string -> string list
+(** Substitute %s in the first chain by the second chain *)
+val subst_command_placeholder : string -> string -> string
 
-module Stringset : Set.S with type elt = string
-module Stringmap : Map.S with type key = string
+(** {6 Lists. } *)
 
-type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
+module List : CList.ExtS
 
-exception UnsupportedUtf8
+val (@) : 'a list -> 'a list -> 'a list
 
-val classify_unicode : int -> utf8_status
-val check_ident : string -> unit
-val check_ident_soft : string -> unit
-val lowercase_first_char_utf8 : string -> string
-val ascii_of_ident : string -> string
+(** {6 Arrays. } *)
 
-(** {6 Lists. } *)
+module Array : CArray.ExtS
 
-val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
-val list_equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
-val list_add_set : 'a -> 'a list -> 'a list
-val list_eq_set : 'a list -> 'a list -> bool
-val list_intersect : 'a list -> 'a list -> 'a list
-val list_union : 'a list -> 'a list -> 'a list
-val list_unionq : 'a list -> 'a list -> 'a list
-val list_subtract : 'a list -> 'a list -> 'a list
-val list_subtractq : 'a list -> 'a list -> 'a list
-
-(** [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *)
-val list_tabulate : (int -> 'a) -> int -> 'a list
-val list_make : int -> 'a -> 'a list
-val list_assign : 'a list -> int -> 'a -> 'a list
-val list_distinct : 'a list -> bool
-val list_duplicates : 'a list -> 'a list
-val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list
-val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list
-val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
-val list_filter_with : bool list -> 'a list -> 'a list
-val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list
-
-(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
-   [ f ai == ai], then [list_smartmap f l==l] *)
-val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
-val list_map_left : ('a -> 'b) -> 'a list -> 'b list
-val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
-val list_map2_i :
-  (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
-val list_map3 :
-  ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
-val list_map4 :
-  ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
-val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array
-val list_filter_i :
-  (int -> 'a -> bool) -> 'a list -> 'a list
-
-(** [list_smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
-   [f ai = true], then [list_smartfilter f l==l] *)
-val list_smartfilter : ('a -> bool) -> 'a list -> 'a list
-
-(** [list_index] returns the 1st index of an element in a list (counting from 1) *)
-val list_index : 'a -> 'a list -> int
-val list_index_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
-
-(** [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
-val list_unique_index : 'a -> 'a list -> int
-
-(** [list_index0] behaves as [list_index] except that it starts counting at 0 *)
-val list_index0 : 'a -> 'a list -> int
-val list_index0_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
-val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit
-val list_iter_i :  (int -> 'a -> unit) -> 'a list -> unit
-val list_fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
-val list_fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
-val list_fold_right_and_left :
-    ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
-val list_fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
-val list_for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
-val list_except : 'a -> 'a list -> 'a list
-val list_remove : 'a -> 'a list -> 'a list
-val list_remove_first : 'a -> 'a list -> 'a list
-val list_remove_assoc_in_triple : 'a -> ('a * 'b * 'c) list -> ('a * 'b * 'c) list
-val list_assoc_snd_in_triple : 'a -> ('a * 'b * 'c) list -> 'b
-val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
-val list_sep_last : 'a list -> 'a * 'a list
-val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b
-val list_try_find : ('a -> 'b) -> 'a list -> 'b
-val list_uniquize : 'a list -> 'a list
-
-(** merges two sorted lists and preserves the uniqueness property: *)
-val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
-val list_subset : 'a list -> 'a list -> bool
-val list_chop : int -> 'a list -> 'a list * 'a list
-(* former [list_split_at] was a duplicate of [list_chop] *)
-val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
-val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list
-val list_firstn : int -> 'a list -> 'a list
-val list_last : 'a list -> 'a
-val list_lastn : int -> 'a list -> 'a list
-val list_skipn : int -> 'a list -> 'a list
-val list_skipn_at_least : int -> 'a list -> 'a list
-val list_addn : int -> 'a -> 'a list -> 'a list
-val list_prefix_of : 'a list -> 'a list -> bool
-
-(** [list_drop_prefix p l] returns [t] if [l=p++t] else return [l] *)
-val list_drop_prefix : 'a list -> 'a list -> 'a list
-val list_drop_last : 'a list -> 'a list
-
-(** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *)
-val list_map_append : ('a -> 'b list) -> 'a list -> 'b list
-val list_join_map : ('a -> 'b list) -> 'a list -> 'b list
-
-(** raises [Invalid_argument] if the two lists don't have the same length *)
-val list_map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
-val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
-
-(** [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
-   where [(e_i,k_i)=f e_{i-1} l_i] *)
-val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
-val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
-val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
-val list_assoc_f : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b
-
-(** A generic cartesian product: for any operator (**),
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
-   and so on if there are more elements in the lists. *)
-val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-
-(** [list_cartesians] is an n-ary cartesian product: it iterates
-   [list_cartesian] over a list of lists.  *)
-val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
-
-(** list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
-val list_combinations : 'a list list -> 'a list list
-val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
-
-(** Keep only those products that do not return None *)
-val list_cartesian_filter :
-  ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
-val list_cartesians_filter :
-  ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
-
-val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
-val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list
+(** {6 Sets. } *)
 
-(** {6 Arrays. } *)
+module Set : module type of CSet
 
-val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
-val array_equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
-val array_exists : ('a -> bool) -> 'a array -> bool
-val array_for_all : ('a -> bool) -> 'a array -> bool
-val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
-val array_for_all3 : ('a -> 'b -> 'c -> bool) ->
-  'a array -> 'b array -> 'c array -> bool
-val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
-  'a array -> 'b array -> 'c array -> 'd array -> bool
-val array_for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
-val array_find_i : (int -> 'a -> bool) -> 'a array -> int option
-val array_hd : 'a array -> 'a
-val array_tl : 'a array -> 'a array
-val array_last : 'a array -> 'a
-val array_cons : 'a -> 'a array -> 'a array
-val array_rev : 'a array -> unit
-val array_fold_right_i :
-  (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
-val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
-val array_fold_right2 :
-  ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
-val array_fold_left2 :
-  ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left3 :
-  ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
-val array_fold_left2_i :
-  (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
-val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
-val array_app_tl : 'a array -> 'a list -> 'a list
-val array_list_of_tl : 'a array -> 'a list
-val array_map_to_list : ('a -> 'b) -> 'a array -> 'b list
-val array_chop : int -> 'a array -> 'a array * 'a array
-val array_smartmap : ('a -> 'a) -> 'a array -> 'a array
-val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map3 :
-  ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
-val array_map_left : ('a -> 'b) -> 'a array -> 'b array
-val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array ->
-  'b array * 'd array
-val array_iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
-val array_fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
-val array_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
-val array_fold_map2' :
-  ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
-val array_distinct : 'a array -> bool
-val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
-val array_rev_to_list : 'a array -> 'a list
-val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array
-val array_filter_with : bool list -> 'a array -> 'a array
+(** {6 Maps. } *)
+
+module Map : module type of CMap
+
+(** {6 Stacks.} *)
+
+module Stack : module type of CStack
 
 (** {6 Streams. } *)
 
@@ -314,7 +87,7 @@ val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
 val const : 'a -> 'b -> 'a
 val iterate : ('a -> 'a) -> int -> 'a -> 'a
 val repeat : int -> ('a -> unit) -> 'a -> unit
-val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a
+val app_opt : ('a -> 'a) option -> 'a -> 'a
 
 (** {6 Delayed computations. } *)
 
@@ -322,90 +95,18 @@ type 'a delayed = unit -> 'a
 
 val delayed_force : 'a delayed -> 'a
 
-(** {6 Misc. } *)
-
-type ('a,'b) union = Inl of 'a | Inr of 'b
-
-module Intset : Set.S with type elt = int
-
-module Intmap : Map.S with type key = int
-
-val intmap_in_dom : int -> 'a Intmap.t -> bool
-val intmap_to_list : 'a Intmap.t -> (int * 'a) list
-val intmap_inv : 'a Intmap.t -> 'a -> int list
-
-val interval : int -> int -> int list
-
-
-(** In [map_succeed f l] an element [a] is removed if [f a] raises 
-   [Failure _] otherwise behaves as [List.map f l] *)
+(** {6 Enriched exceptions} *)
 
-val map_succeed : ('a -> 'b) -> 'a list -> 'b list
+type iexn = Exninfo.iexn
 
-(** {6 Pretty-printing. } *)
+val iraise : iexn -> 'a
 
-val pr_spc : unit -> std_ppcmds
-val pr_fnl : unit -> std_ppcmds
-val pr_int : int -> std_ppcmds
-val pr_str : string -> std_ppcmds
-val pr_comma : unit -> std_ppcmds
-val pr_semicolon : unit -> std_ppcmds
-val pr_bar : unit -> std_ppcmds
-val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
-val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val nth : int -> std_ppcmds
-
-val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-
-(** unlike all other functions below, [prlist] works lazily.
-   if a strict behavior is needed, use [prlist_strict] instead. *)
-val prlist_strict :  ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val prlist_with_sep :
-   (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvect_with_sep :
-   (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvecti_with_sep :
-   (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
-val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds
-val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val surround : std_ppcmds -> std_ppcmds
-
-(** {6 Memoization. } *)
-
-(** General comments on memoization:
-   - cache is created whenever the function is supplied (because of
-      ML's polymorphic value restriction).
-   - cache is never flushed (unless the memoized fun is GC'd)
- 
-   One cell memory: memorizes only the last call *)
-val memo1_1 : ('a -> 'b) -> ('a -> 'b)
-val memo1_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
-
-(** with custom equality (used to deal with various arities) *)
-val memo1_eq : ('a -> 'a -> bool) -> ('a -> 'b) -> ('a -> 'b)
-
-(** Memorizes the last [n] distinct calls. Efficient only for small [n]. *)
-val memon_eq : ('a -> 'a -> bool) -> int -> ('a -> 'b) -> ('a -> 'b)
-
-(** {6 Size of an ocaml value (in words, bytes and kilobytes). } *)
-
-val size_w : 'a -> int
-val size_b : 'a -> int
-val size_kb : 'a -> int
-
-(** {6 Total size of the allocated ocaml heap. } *)
+(** {6 Misc. } *)
 
-val heap_size : unit -> int
-val heap_size_kb : unit -> int
+type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
+(** Union type *)
 
-(** {6 ... } *)
-(** Coq interruption: set the following boolean reference to interrupt Coq
-    (it eventually raises [Break], simulating a Ctrl-C) *)
+val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union
 
-val interrupt : bool ref
-val check_for_interrupt : unit -> unit
+type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
+(** Used for browsable-until structures. *)
diff --git a/lib/xml_datatype.mli b/lib/xml_datatype.mli
new file mode 100644
index 00000000..f61ba032
--- /dev/null
+++ b/lib/xml_datatype.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** ['a gxml] is the type for semi-structured documents. They generalize
+    XML by allowing any kind of attributes. *)
+type 'a gxml =
+  | Element of (string * 'a * 'a gxml list)
+  | PCData of string
+
+(** [xml] is a semi-structured documents where attributes are association
+    lists from string to string. *)
+type xml = (string * string) list gxml
+
+
diff --git a/lib/xml_lexer.mli b/lib/xml_lexer.mli
index a1ca0576..e61cb055 100644
--- a/lib/xml_lexer.mli
+++ b/lib/xml_lexer.mli
@@ -38,7 +38,7 @@ type token =
 type pos = int * int * int * int
 
 val init : Lexing.lexbuf -> unit 
-val close : Lexing.lexbuf -> unit
+val close : unit -> unit
 val token : Lexing.lexbuf -> token
 val pos : Lexing.lexbuf -> pos
-val restore : pos -> unit
\ No newline at end of file
+val restore : pos -> unit
diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll
index 5b06e720..a33be9da 100644
--- a/lib/xml_lexer.mll
+++ b/lib/xml_lexer.mll
@@ -20,24 +20,24 @@
 open Lexing
 
 type error =
-	| EUnterminatedComment
-	| EUnterminatedString
-	| EIdentExpected
-	| ECloseExpected
-	| ENodeExpected
-	| EAttributeNameExpected
-	| EAttributeValueExpected
-	| EUnterminatedEntity
+        | EUnterminatedComment
+        | EUnterminatedString
+        | EIdentExpected
+        | ECloseExpected
+        | ENodeExpected
+        | EAttributeNameExpected
+        | EAttributeValueExpected
+        | EUnterminatedEntity
 
 exception Error of error
 
 type pos = int * int * int * int
 
 type token =
-	| Tag of string * (string * string) list * bool
-	| PCData of string
-	| Endtag of string
-	| Eof
+        | Tag of string * (string * string) list * bool
+        | PCData of string
+        | Endtag of string
+        | Eof
 
 let last_pos = ref 0
 and current_line = ref 0
@@ -48,39 +48,40 @@ let tmp = Buffer.create 200
 let idents = Hashtbl.create 0
 
 let _ = begin
-	Hashtbl.add idents "gt;" ">";
-	Hashtbl.add idents "lt;" "<";
-	Hashtbl.add idents "amp;" "&";
-	Hashtbl.add idents "apos;" "'";
-	Hashtbl.add idents "quot;" "\"";
+        Hashtbl.add idents "nbsp;" " ";
+        Hashtbl.add idents "gt;" ">";
+        Hashtbl.add idents "lt;" "<";
+        Hashtbl.add idents "amp;" "&";
+        Hashtbl.add idents "apos;" "'";
+        Hashtbl.add idents "quot;" "\"";
 end
 
 let init lexbuf =
-	current_line := 1;
-	current_line_start := lexeme_start lexbuf;
-	last_pos := !current_line_start
+        current_line := 1;
+        current_line_start := lexeme_start lexbuf;
+        last_pos := !current_line_start
 
 let close lexbuf =
-	Buffer.reset tmp
+        Buffer.reset tmp
 
 let pos lexbuf =
-	!current_line ,	!current_line_start ,
-	!last_pos ,
-	lexeme_start lexbuf
+        !current_line , !current_line_start ,
+        !last_pos ,
+        lexeme_start lexbuf
 
 let restore (cl,cls,lp,_) =
-	current_line := cl;
-	current_line_start := cls;
-	last_pos := lp
+        current_line := cl;
+        current_line_start := cls;
+        last_pos := lp
 
 let newline lexbuf =
-	incr current_line;
-	last_pos := lexeme_end lexbuf;
-	current_line_start := !last_pos
+        incr current_line;
+        last_pos := lexeme_end lexbuf;
+        current_line_start := !last_pos
 
 let error lexbuf e =
-	last_pos := lexeme_start lexbuf;
-	raise (Error e)
+        last_pos := lexeme_start lexbuf;
+        raise (Error e)
 
 }
 
@@ -92,100 +93,100 @@ let entitychar = ['A'-'Z' 'a'-'z']
 let pcchar = [^ '\r' '\n' '<' '>' '&']
 
 rule token = parse
-	| newline | (newline break) | break
-		{
-			newline lexbuf;
+        | newline | (newline break) | break
+                {
+                        newline lexbuf;
                         PCData "\n"
-		}
-	| "<!--"
-		{
-			last_pos := lexeme_start lexbuf;
-			comment lexbuf;
-			token lexbuf
-		}
-	| "<?"
-		{
-			last_pos := lexeme_start lexbuf;
-			header lexbuf;
-			token lexbuf;
-		}
-	| '<' space* '/' space*
-		{
-			last_pos := lexeme_start lexbuf;
-			let tag = ident_name lexbuf in
-			ignore_spaces lexbuf;
-			close_tag lexbuf;
-			Endtag tag
-		}
-	| '<' space*
-		{
-			last_pos := lexeme_start lexbuf;
-			let tag = ident_name lexbuf in
-			ignore_spaces lexbuf;
-			let attribs, closed = attributes lexbuf in
-			Tag(tag, attribs, closed)
-		}
-	| "&#"
-		{
-			last_pos := lexeme_start lexbuf;
-			Buffer.reset tmp;
-			Buffer.add_string tmp (lexeme lexbuf);
-			PCData (pcdata lexbuf)
-		}
-	| '&'
-		{
-			last_pos := lexeme_start lexbuf;
-			Buffer.reset tmp;
-			Buffer.add_string tmp (entity lexbuf);
-			PCData (pcdata lexbuf)
-		}
-	| pcchar+
-		{
-			last_pos := lexeme_start lexbuf;
-			Buffer.reset tmp;
-			Buffer.add_string tmp (lexeme lexbuf);
-			PCData (pcdata lexbuf)
-		}
-	| eof { Eof }
-	| _
-		{ error lexbuf ENodeExpected }
+                }
+        | "<!--"
+                {
+                        last_pos := lexeme_start lexbuf;
+                        comment lexbuf;
+                        token lexbuf
+                }
+        | "<?"
+                {
+                        last_pos := lexeme_start lexbuf;
+                        header lexbuf;
+                        token lexbuf;
+                }
+        | '<' space* '/' space*
+                {
+                        last_pos := lexeme_start lexbuf;
+                        let tag = ident_name lexbuf in
+                        ignore_spaces lexbuf;
+                        close_tag lexbuf;
+                        Endtag tag
+                }
+        | '<' space*
+                {
+                        last_pos := lexeme_start lexbuf;
+                        let tag = ident_name lexbuf in
+                        ignore_spaces lexbuf;
+                        let attribs, closed = attributes lexbuf in
+                        Tag(tag, attribs, closed)
+                }
+        | "&#"
+                {
+                        last_pos := lexeme_start lexbuf;
+                        Buffer.reset tmp;
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        PCData (pcdata lexbuf)
+                }
+        | '&'
+                {
+                        last_pos := lexeme_start lexbuf;
+                        Buffer.reset tmp;
+                        Buffer.add_string tmp (entity lexbuf);
+                        PCData (pcdata lexbuf)
+                }
+        | pcchar+
+                {
+                        last_pos := lexeme_start lexbuf;
+                        Buffer.reset tmp;
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        PCData (pcdata lexbuf)
+                }
+        | eof { Eof }
+        | _
+                { error lexbuf ENodeExpected }
 
 and ignore_spaces = parse
         | newline | (newline break) | break
-		{
-			newline lexbuf;
-			ignore_spaces lexbuf
-		}
-	| space +
-		{ ignore_spaces lexbuf }
-	| ""
-		{ () }
+                {
+                        newline lexbuf;
+                        ignore_spaces lexbuf
+                }
+        | space +
+                { ignore_spaces lexbuf }
+        | ""
+                { () }
 
 and comment = parse
         | newline | (newline break) | break
-		{
-			newline lexbuf;
-			comment lexbuf
-		}
-	| "-->"
-		{ () }
-	| eof
-		{ raise (Error EUnterminatedComment) }
-	| _
-		{ comment lexbuf }
+                {
+                        newline lexbuf;
+                        comment lexbuf
+                }
+        | "-->"
+                { () }
+        | eof
+                { raise (Error EUnterminatedComment) }
+        | _
+                { comment lexbuf }
 
 and header = parse
         | newline | (newline break) | break
-		{
-			newline lexbuf;
-			header lexbuf
-		}
-	| "?>"
-		{ () }
-	| eof
-		{ error lexbuf ECloseExpected }
-	| _
-		{ header lexbuf }
+                {
+                        newline lexbuf;
+                        header lexbuf
+                }
+        | "?>"
+                { () }
+        | eof
+                { error lexbuf ECloseExpected }
+        | _
+                { header lexbuf }
 
 and pcdata = parse
         | newline | (newline break) | break
@@ -194,112 +195,112 @@ and pcdata = parse
                         newline lexbuf;
                         pcdata lexbuf
                 }
-	| pcchar+
-		{
-			Buffer.add_string tmp (lexeme lexbuf);
-			pcdata lexbuf
-		}
-	| "&#"
-		{
-			Buffer.add_string tmp (lexeme lexbuf);
-			pcdata lexbuf;
-		}
-	| '&'
-		{
-			Buffer.add_string tmp (entity lexbuf);
-			pcdata lexbuf
-		}
-	| ""
-		{ Buffer.contents tmp }
+        | pcchar+
+                {
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        pcdata lexbuf
+                }
+        | "&#"
+                {
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        pcdata lexbuf;
+                }
+        | '&'
+                {
+                        Buffer.add_string tmp (entity lexbuf);
+                        pcdata lexbuf
+                }
+        | ""
+                { Buffer.contents tmp }
 
 and entity = parse
-	| entitychar+ ';'
-		{
-			let ident = lexeme lexbuf in
-			try
-				Hashtbl.find idents (String.lowercase ident)
-			with
-				Not_found -> "&" ^ ident
-		}
-	| _ | eof
-		{ raise (Error EUnterminatedEntity) }
+        | entitychar+ ';'
+                {
+                        let ident = lexeme lexbuf in
+                        try
+                                Hashtbl.find idents (String.lowercase ident)
+                        with
+                                Not_found -> "&" ^ ident
+                }
+        | _ | eof
+                { raise (Error EUnterminatedEntity) }
 
 and ident_name = parse
-	| identchar+
-		{ lexeme lexbuf }
-	| _ | eof
-		{ error lexbuf EIdentExpected }
+        | identchar+
+                { lexeme lexbuf }
+        | _ | eof
+                { error lexbuf EIdentExpected }
 
 and close_tag = parse
-	| '>'
-		{ () }
-	| _ | eof
-		{ error lexbuf ECloseExpected }
+        | '>'
+                { () }
+        | _ | eof
+                { error lexbuf ECloseExpected }
 
 and attributes = parse
-	| '>'
-		{ [], false }
-	| "/>"
-		{ [], true }
-	| "" (* do not read a char ! *)
-		{
-			let key = attribute lexbuf in
-			let data = attribute_data lexbuf in
-			ignore_spaces lexbuf;
-			let others, closed = attributes lexbuf in
-			(key, data) :: others, closed
-		}
+        | '>'
+                { [], false }
+        | "/>"
+                { [], true }
+        | "" (* do not read a char ! *)
+                {
+                        let key = attribute lexbuf in
+                        let data = attribute_data lexbuf in
+                        ignore_spaces lexbuf;
+                        let others, closed = attributes lexbuf in
+                        (key, data) :: others, closed
+                }
 
 and attribute = parse
-	| identchar+
-		{ lexeme lexbuf }
-	| _ | eof
-		{ error lexbuf EAttributeNameExpected }
+        | identchar+
+                { lexeme lexbuf }
+        | _ | eof
+                { error lexbuf EAttributeNameExpected }
 
 and attribute_data = parse
-	| space* '=' space* '"'
-		{
-			Buffer.reset tmp;
-			last_pos := lexeme_end lexbuf;
-			dq_string lexbuf
-		}
-	| space* '=' space* '\''
-		{
-			Buffer.reset tmp;
-			last_pos := lexeme_end lexbuf;
-			q_string lexbuf
-		}
-	| _ | eof
-		{ error lexbuf EAttributeValueExpected }
+        | space* '=' space* '"'
+                {
+                        Buffer.reset tmp;
+                        last_pos := lexeme_end lexbuf;
+                        dq_string lexbuf
+                }
+        | space* '=' space* '\''
+                {
+                        Buffer.reset tmp;
+                        last_pos := lexeme_end lexbuf;
+                        q_string lexbuf
+                }
+        | _ | eof
+                { error lexbuf EAttributeValueExpected }
 
 and dq_string = parse
-	| '"'
-		{ Buffer.contents tmp }
-	| '\\' [ '"' '\\' ]
-		{
-			Buffer.add_char tmp (lexeme_char lexbuf 1);
-			dq_string lexbuf
-		}
-	| eof
-		{ raise (Error EUnterminatedString) }
-	| _
-		{ 
-			Buffer.add_char tmp (lexeme_char lexbuf 0);
-			dq_string lexbuf
-		}
+        | '"'
+                { Buffer.contents tmp }
+        | '\\' [ '"' '\\' ]
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 1);
+                        dq_string lexbuf
+                }
+        | eof
+                { raise (Error EUnterminatedString) }
+        | _
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 0);
+                        dq_string lexbuf
+                }
 
 and q_string = parse
-	| '\''
-		{ Buffer.contents tmp }
-	| '\\' [ '\'' '\\' ]
-		{
-			Buffer.add_char tmp (lexeme_char lexbuf 1);
-			q_string lexbuf
-		}
-	| eof
-		{ raise (Error EUnterminatedString) }
-	| _
-		{ 
-			Buffer.add_char tmp (lexeme_char lexbuf 0);
-			q_string lexbuf
-		}
+        | '\''
+                { Buffer.contents tmp }
+        | '\\' [ '\'' '\\' ]
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 1);
+                        q_string lexbuf
+                }
+        | eof
+                { raise (Error EUnterminatedString) }
+        | _
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 0);
+                        q_string lexbuf
+                }
diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml
index 600796f7..8db3f9e8 100644
--- a/lib/xml_parser.ml
+++ b/lib/xml_parser.ml
@@ -19,30 +19,29 @@
  *)
 
 open Printf
+open Xml_datatype
 
-type xml = 
-        | Element of (string * (string * string) list * xml list)
-        | PCData of string
+type xml = Xml_datatype.xml
 
 type error_pos = {
-        eline : int;
-        eline_start : int;
-        emin : int;
-        emax : int;
+  eline : int;
+  eline_start : int;
+  emin : int;
+  emax : int;
 }
 
 type error_msg =
-        | UnterminatedComment
-        | UnterminatedString
-        | UnterminatedEntity
-        | IdentExpected
-        | CloseExpected
-        | NodeExpected
-        | AttributeNameExpected
-        | AttributeValueExpected
-        | EndOfTagExpected of string
-        | EOFExpected
-	| Empty
+  | UnterminatedComment
+  | UnterminatedString
+  | UnterminatedEntity
+  | IdentExpected
+  | CloseExpected
+  | NodeExpected
+  | AttributeNameExpected
+  | AttributeValueExpected
+  | EndOfTagExpected of string
+  | EOFExpected
+  | Empty
 
 type error = error_msg * error_pos
 
@@ -51,21 +50,16 @@ exception Error of error
 exception File_not_found of string
 
 type t = {
-	mutable check_eof : bool;
-	mutable concat_pcdata : bool;
+  mutable check_eof : bool;
+  mutable concat_pcdata : bool;
+  source : Lexing.lexbuf;
+  stack : Xml_lexer.token Stack.t;
 }
 
-type source = 
-	| SFile of string
-	| SChannel of in_channel
-	| SString of string
-	| SLexbuf of Lexing.lexbuf
-
-type state = {
-	source : Lexing.lexbuf;
-	stack : Xml_lexer.token Stack.t;
-	xparser : t;
-}
+type source =
+  | SChannel of in_channel
+  | SString of string
+  | SLexbuf of Lexing.lexbuf
 
 exception Internal_error of error_msg
 exception NoMoreData
@@ -86,152 +80,153 @@ let is_blank s =
   !i = len
 
 let _raises e f =
-	xml_error := e;
-	file_not_found := f
-
-let make () =
-	{
-		check_eof = true;
-		concat_pcdata = true;
-	}
+  xml_error := e;
+  file_not_found := f
+
+let make source =
+  let source = match source with
+    | SChannel chan -> Lexing.from_channel chan
+    | SString s -> Lexing.from_string s
+    | SLexbuf lexbuf -> lexbuf
+  in
+  let () = Xml_lexer.init source in
+  {
+    check_eof = false;
+    concat_pcdata = true;
+    source = source;
+    stack = Stack.create ();
+  }
 
 let check_eof p v = p.check_eof <- v
-let concat_pcdata p v = p.concat_pcdata <- v
 
 let pop s =
-	try
-		Stack.pop s.stack
-	with
-		Stack.Empty ->
-			Xml_lexer.token s.source
+  try
+    Stack.pop s.stack
+  with
+      Stack.Empty ->
+        Xml_lexer.token s.source
 
 let push t s =
-	Stack.push t s.stack
+  Stack.push t s.stack
 
 let canonicalize l =
   let has_elt = List.exists (function Element _ -> true | _ -> false) l in
   if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l
   else l
 
-let rec read_node s =
-	match pop s with
-	| Xml_lexer.PCData s -> PCData s
-	| Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
-	| Xml_lexer.Tag (tag, attr, false) ->
-          let elements = read_elems tag s in
-          Element (tag, attr, canonicalize elements)
-	| t ->
-		push t s;
-		raise NoMoreData
-and
-	read_elems tag s =
-		let elems = ref [] in
-		(try
-                  while true do
-                    let node = read_node s in
-                    match node, !elems with
-                    | PCData c , (PCData c2) :: q ->
-                      elems := PCData (c2 ^ c) :: q
-                    | _, l ->
-                      elems := node :: l
-                  done
-		with
-			NoMoreData -> ());
-		match pop s with
-		| Xml_lexer.Endtag s when s = tag -> List.rev !elems
-		| t -> raise (Internal_error (EndOfTagExpected tag))
-
-let rec read_xml s =
-  let node = read_node s in
-  match node with
-  | Element _ -> node
-  | PCData c ->
-    if is_blank c then read_xml s
-    else raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
+let rec read_xml do_not_canonicalize s =
+  let rec read_node s =
+    match pop s with
+      | Xml_lexer.PCData s -> PCData s
+      | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+      | Xml_lexer.Tag (tag, attr, false) ->
+        let elements = read_elems tag s in
+        let elements =
+          if do_not_canonicalize then elements else canonicalize elements
+        in
+        Element (tag, attr, elements)
+      | t ->
+        push t s;
+        raise NoMoreData
+
+  and read_elems tag s =
+    let elems = ref [] in
+    (try
+       while true do
+         let node = read_node s in
+         match node, !elems with
+           | PCData c , (PCData c2) :: q ->
+             elems := PCData (c2 ^ c) :: q
+           | _, l ->
+             elems := node :: l
+       done
+     with
+         NoMoreData -> ());
+    match pop s with
+      | Xml_lexer.Endtag s when s = tag -> List.rev !elems
+      | t -> raise (Internal_error (EndOfTagExpected tag))
+  in
+  match read_node s with
+    | (Element _) as node ->
+      node
+    | PCData c ->
+      if is_blank c then
+        read_xml do_not_canonicalize s
+      else
+        raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
 
 let convert = function
-	| Xml_lexer.EUnterminatedComment -> UnterminatedComment
-	| Xml_lexer.EUnterminatedString -> UnterminatedString
-	| Xml_lexer.EIdentExpected -> IdentExpected
-	| Xml_lexer.ECloseExpected -> CloseExpected
-	| Xml_lexer.ENodeExpected -> NodeExpected
-	| Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
-	| Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
-	| Xml_lexer.EUnterminatedEntity -> 	UnterminatedEntity
-
-let error_of_exn stk = function
-  | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty
+  | Xml_lexer.EUnterminatedComment -> UnterminatedComment
+  | Xml_lexer.EUnterminatedString -> UnterminatedString
+  | Xml_lexer.EIdentExpected -> IdentExpected
+  | Xml_lexer.ECloseExpected -> CloseExpected
+  | Xml_lexer.ENodeExpected -> NodeExpected
+  | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+  | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+  | Xml_lexer.EUnterminatedEntity ->      UnterminatedEntity
+
+let error_of_exn xparser = function
+  | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty
   | NoMoreData -> NodeExpected
   | Internal_error e -> e
   | Xml_lexer.Error e -> convert e
-  | e -> raise e
-
-let do_parse xparser source =
-        let stk = Stack.create() in
-	try
-		Xml_lexer.init source;
-		let s = { source = source; xparser = xparser; stack = stk } in
-		let x = read_xml s in
-		if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
-		Xml_lexer.close source;
-		x
-	with e when e <> Sys.Break ->
-	  Xml_lexer.close source;
-	  raise (!xml_error (error_of_exn stk e) source)
-
-let parse p = function
-	| SChannel ch -> do_parse p (Lexing.from_channel ch)
-	| SString str -> do_parse p (Lexing.from_string str)
-	| SLexbuf lex -> do_parse p lex
-	| SFile fname ->
-		let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
-		try
-			let x = do_parse p (Lexing.from_channel ch) in
-			close_in ch;
-			x
-		with
-			reraise ->
-				close_in ch;
-				raise reraise
-
+  | e ->
+    (*let e = Errors.push e in: We do not record backtrace here. *)
+    raise e
+
+let do_parse do_not_canonicalize xparser =
+  try
+    Xml_lexer.init xparser.source;
+    let x = read_xml do_not_canonicalize xparser in
+    if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+    Xml_lexer.close ();
+    x
+  with any ->
+    Xml_lexer.close ();
+    raise (!xml_error (error_of_exn xparser any) xparser.source)
+
+let parse ?(do_not_canonicalize=false) p =
+  do_parse do_not_canonicalize p
 
 let error_msg = function
-        | UnterminatedComment -> "Unterminated comment"
-        | UnterminatedString -> "Unterminated string"
-        | UnterminatedEntity -> "Unterminated entity"
-        | IdentExpected -> "Ident expected"
-        | CloseExpected -> "Element close expected"
-        | NodeExpected -> "Xml node expected"
-        | AttributeNameExpected -> "Attribute name expected"
-        | AttributeValueExpected -> "Attribute value expected"
-        | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
-        | EOFExpected -> "End of file expected"
-	| Empty -> "Empty"
+  | UnterminatedComment -> "Unterminated comment"
+  | UnterminatedString -> "Unterminated string"
+  | UnterminatedEntity -> "Unterminated entity"
+  | IdentExpected -> "Ident expected"
+  | CloseExpected -> "Element close expected"
+  | NodeExpected -> "Xml node expected"
+  | AttributeNameExpected -> "Attribute name expected"
+  | AttributeValueExpected -> "Attribute value expected"
+  | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+  | EOFExpected -> "End of file expected"
+  | Empty -> "Empty"
 
 let error (msg,pos) =
-        if pos.emin = pos.emax then
-                sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
-        else
-                sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
-        
+  if pos.emin = pos.emax then
+    sprintf "%s line %d character %d" (error_msg msg) pos.eline
+      (pos.emin - pos.eline_start)
+  else
+    sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline
+      (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+
 let line e = e.eline
 
-let range e = 
-        e.emin - e.eline_start , e.emax - e.eline_start
+let range e =
+  e.emin - e.eline_start , e.emax - e.eline_start
 
 let abs_range e =
-        e.emin , e.emax
+  e.emin , e.emax
 
 let pos source =
-        let line, lstart, min, max = Xml_lexer.pos source in
-        {
-                eline = line;
-                eline_start = lstart;
-                emin = min;
-                emax = max;
-        }
-
-let () = _raises (fun x p -> 
+  let line, lstart, min, max = Xml_lexer.pos source in
+  {
+    eline = line;
+    eline_start = lstart;
+    emin = min;
+    emax = max;
+  }
+
+let () = _raises (fun x p ->
         (* local cast : Xml.error_msg -> error_msg *)
-        Error (x, pos p))
-        (fun f -> File_not_found f)
+  Error (x, pos p))
+  (fun f -> File_not_found f)
diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli
index cc9bcd33..cefb4af8 100644
--- a/lib/xml_parser.mli
+++ b/lib/xml_parser.mli
@@ -27,9 +27,7 @@
 
 (** An Xml node is either
         [Element (tag-name, attributes, children)] or [PCData text] *)
-type xml = 
-        | Element of (string * (string * string) list * xml list)
-        | PCData of string
+type xml = Xml_datatype.xml
 
 (** Abstract type for an Xml parser. *)
 type t
@@ -59,7 +57,7 @@ type error_msg =
         | AttributeValueExpected
         | EndOfTagExpected of string
         | EOFExpected
-	| Empty
+        | Empty
 
 type error = error_msg * error_pos
 
@@ -71,7 +69,7 @@ exception File_not_found of string
 val error : error -> string
 
 (** Get the Xml error message as a string. *)
-val error_msg : error_msg -> string 
+val error_msg : error_msg -> string
 
 (** Get the line the error occured at. *)
 val line : error_pos -> int
@@ -85,21 +83,24 @@ val abs_range : error_pos -> int * int
 val pos : Lexing.lexbuf -> error_pos
 
 (** Several kind of resources can contain Xml documents. *)
-type source = 
-	| SFile of string
-	| SChannel of in_channel
-	| SString of string
-	| SLexbuf of Lexing.lexbuf
+type source =
+| SChannel of in_channel
+| SString of string
+| SLexbuf of Lexing.lexbuf
 
 (** This function returns a new parser with default options. *)
-val make : unit -> t
+val make : source -> t
 
-(** When a Xml document is parsed, the parser will check that the end of the
+(** When a Xml document is parsed, the parser may check that the end of the
  document is reached, so for example parsing ["<A/><B/>"] will fail instead
- of returning only the A element. You can turn off this check by setting
- [check_eof] to [false] {i (by default, check_eof is true)}. *)
+ of returning only the A element. You can turn on this check by setting
+ [check_eof] to [true] {i (by default, check_eof is false, unlike
+ in the original Xmllight)}. *)
 val check_eof : t -> bool -> unit
 
 (** Once the parser is configurated, you can run the parser on a any kind
- of xml document source to parse its contents into an Xml data structure. *)
-val parse :  t -> source -> xml
+    of xml document source to parse its contents into an Xml data structure.
+
+    When [do_not_canonicalize] is set, the XML document is given as
+    is, without trying to remove blank PCDATA elements. *)
+val parse : ?do_not_canonicalize:bool -> t -> xml
diff --git a/lib/xml_printer.ml b/lib/xml_printer.ml
new file mode 100644
index 00000000..eeddd53c
--- /dev/null
+++ b/lib/xml_printer.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+type xml = Xml_datatype.xml
+
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+type t = target
+
+let make x = x
+
+let buffer_pcdata tmp text =
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  let l = String.length text in
+  for p = 0 to l-1 do
+    match text.[p] with
+      | ' ' -> output "&nbsp;";
+      | '>' -> output "&gt;"
+      | '<' -> output "&lt;"
+      | '&' ->
+        if p < l - 1 && text.[p + 1] = '#' then
+          output' '&'
+        else
+          output "&amp;"
+      | '\'' -> output "&apos;"
+      | '"' -> output "&quot;"
+      | c -> output' c
+  done
+
+let buffer_attr tmp (n,v) =
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  output' ' ';
+  output n;
+  output "=\"";
+  let l = String.length v in
+  for p = 0 to l - 1 do
+    match v.[p] with
+      | '\\' -> output "\\\\"
+      | '"' -> output "\\\""
+      | c -> output' c
+  done;
+  output' '"'
+
+let to_buffer tmp x =
+  let pcdata = ref false in
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  let rec loop = function
+    | Element (tag,alist,[]) ->
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output "/>";
+      pcdata := false;
+    | Element (tag,alist,l) ->
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output' '>';
+      pcdata := false;
+      List.iter loop l;
+      output "</";
+      output tag;
+      output' '>';
+      pcdata := false;
+    | PCData text ->
+      if !pcdata then output' ' ';
+      buffer_pcdata tmp text;
+      pcdata := true;
+  in
+  loop x
+
+let pcdata_to_string s =
+  let b = Buffer.create 13 in
+  buffer_pcdata b s;
+  Buffer.contents b
+
+let to_string x =
+  let b = Buffer.create 200 in
+  to_buffer b x;
+  Buffer.contents b
+
+let to_string_fmt x =
+  let tmp = Buffer.create 200 in
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  let rec loop ?(newl=false) tab = function
+    | Element (tag, alist, []) ->
+      output tab;
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output "/>";
+      if newl then output' '\n';
+    | Element (tag, alist, [PCData text]) ->
+      output tab;
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output ">";
+      buffer_pcdata tmp text;
+      output "</";
+      output tag;
+      output' '>';
+      if newl then output' '\n';
+    | Element (tag, alist, l) ->
+      output tab;
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output ">\n";
+      List.iter (loop ~newl:true (tab^"  ")) l;
+      output tab;
+      output "</";
+      output tag;
+      output' '>';
+      if newl then output' '\n';
+    | PCData text ->
+      buffer_pcdata tmp text;
+      if newl then output' '\n';
+  in
+  loop "" x;
+  Buffer.contents tmp
+
+let print t xml =
+  let tmp, flush = match t with
+    | TChannel oc ->
+      let b = Buffer.create 200 in
+      b, (fun () -> Buffer.output_buffer oc b; flush oc)
+    | TBuffer b ->
+      b, (fun () -> ())
+  in
+  to_buffer tmp xml;
+  flush ()
diff --git a/lib/xml_printer.mli b/lib/xml_printer.mli
new file mode 100644
index 00000000..e21eca28
--- /dev/null
+++ b/lib/xml_printer.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type xml = Xml_datatype.xml
+
+type t
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+val make : target -> t
+
+(** Print the xml data structure to a source into a compact xml string (without
+ any user-readable formating ). *)
+val print : t -> xml -> unit
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string
+
+(** Print PCDATA as a string by escaping XML entities. *)
+val pcdata_to_string : string -> string
diff --git a/lib/xml_utils.ml b/lib/xml_utils.ml
deleted file mode 100644
index 31003586..00000000
--- a/lib/xml_utils.ml
+++ /dev/null
@@ -1,223 +0,0 @@
-(*
- * Xml Light, an small Xml parser/printer with DTD support.
- * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
-
-open Printf
-open Xml_parser
-
-exception Not_element of xml
-exception Not_pcdata of xml
-exception No_attribute of string
-
-let default_parser = Xml_parser.make()
-
-let parse (p:Xml_parser.t) (source:Xml_parser.source) =
-	(* local cast Xml.xml -> xml *)
-	(Obj.magic Xml_parser.parse p source : xml)
-
-let parse_in ch = parse default_parser (Xml_parser.SChannel ch)
-let parse_string str = parse default_parser (Xml_parser.SString str)
-
-let parse_file f = parse default_parser (Xml_parser.SFile f)
-
-let tag = function
-	| Element (tag,_,_) -> tag
-	| x -> raise (Not_element x)
-
-let pcdata = function 
-	| PCData text -> text
-	| x -> raise (Not_pcdata x)
-
-let attribs = function 
-	| Element (_,attr,_) -> attr
-	| x -> raise (Not_element x)
-
-let attrib x att =
-	match x with
-	| Element (_,attr,_) ->
-		(try
-			let att = String.lowercase att in
-			snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
-		with
-			Not_found ->
-				raise (No_attribute att))
-	| x ->
-		raise (Not_element x)
-
-let children = function
-	| Element (_,_,clist) -> clist
-	| x -> raise (Not_element x)
-
-(*let enum = function
-	| Element (_,_,clist) -> List.to_enum clist
-	| x -> raise (Not_element x)
-*)
-
-let iter f = function
-	| Element (_,_,clist) -> List.iter f clist
-	| x -> raise (Not_element x)
-
-let map f = function
-	| Element (_,_,clist) -> List.map f clist
-	| x -> raise (Not_element x)
-
-let fold f v = function
-	| Element (_,_,clist) -> List.fold_left f v clist
-	| x -> raise (Not_element x)
-
-let tmp = Buffer.create 200
-
-let buffer_pcdata text =
-	let l = String.length text in
-	for p = 0 to l-1 do 
-		match text.[p] with
-		| '>' -> Buffer.add_string tmp "&gt;"
-		| '<' -> Buffer.add_string tmp "&lt;"
-		| '&' ->
-			if p < l-1 && text.[p+1] = '#' then
-				Buffer.add_char tmp '&'
-			else
-				Buffer.add_string tmp "&amp;"
-		| '\'' -> Buffer.add_string tmp "&apos;"
-		| '"' -> Buffer.add_string tmp "&quot;"
-		| c -> Buffer.add_char tmp c
-	done
-
-let print_pcdata chan text =
-  let l = String.length text in
-  for p = 0 to l-1 do 
-    match text.[p] with
-    | '>' -> Printf.fprintf chan "&gt;"
-    | '<' -> Printf.fprintf chan "&lt;"
-    | '&' ->
-            if p < l-1 && text.[p+1] = '#' then
-                    Printf.fprintf chan "&"
-            else
-                    Printf.fprintf chan "&amp;"
-    | '\'' -> Printf.fprintf chan "&apos;"
-    | '"' -> Printf.fprintf chan "&quot;"
-    | c -> Printf.fprintf chan "%c" c
-  done
-
-let buffer_attr (n,v) =
-	Buffer.add_char tmp ' ';
-	Buffer.add_string tmp n;
-	Buffer.add_string tmp "=\"";
-	let l = String.length v in
-	for p = 0 to l-1 do
-		match v.[p] with
-		| '\\' -> Buffer.add_string tmp "\\\\"
-		| '"' -> Buffer.add_string tmp "\\\""
-		| c -> Buffer.add_char tmp c
-	done;
-	Buffer.add_char tmp '"'
-
-let rec print_attr chan (n, v) =
-  Printf.fprintf chan " %s=\"" n;
-  let l = String.length v in
-  for p = 0 to l-1 do
-          match v.[p] with
-          | '\\' -> Printf.fprintf chan "\\\\"
-          | '"' -> Printf.fprintf chan  "\\\""
-          | c -> Printf.fprintf chan "%c" c
-  done;
-  Printf.fprintf chan "\""
-
-let print_attrs chan l = List.iter (print_attr chan) l
-
-let rec print_xml chan = function
-| Element (tag, alist, []) ->
-  Printf.fprintf chan "<%s%a/>" tag print_attrs alist;
-| Element (tag, alist, l) ->
-  Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist
-  (fun chan -> List.iter (print_xml chan)) l tag
-| PCData text ->
-  print_pcdata chan text
-
-let to_string x = 
-	let pcdata = ref false in
-	let rec loop = function
-		| Element (tag,alist,[]) ->
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp "/>";
-			pcdata := false;
-		| Element (tag,alist,l) ->
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_char tmp '>';
-			pcdata := false;
-			List.iter loop l;
-			Buffer.add_string tmp "</";
-			Buffer.add_string tmp tag;
-			Buffer.add_char tmp '>';
-			pcdata := false;
-		| PCData text ->
-			if !pcdata then Buffer.add_char tmp ' ';
-			buffer_pcdata text;
-			pcdata := true;
-	in
-	Buffer.reset tmp;
-	loop x;
-	let s = Buffer.contents tmp in
-	Buffer.reset tmp;
-	s
-
-let to_string_fmt x =
-	let rec loop ?(newl=false) tab = function
-		| Element (tag,alist,[]) ->
-			Buffer.add_string tmp tab;
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp "/>";
-			if newl then Buffer.add_char tmp '\n';
-		| Element (tag,alist,[PCData text]) ->
-			Buffer.add_string tmp tab;
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp ">";
-			buffer_pcdata text;
-			Buffer.add_string tmp "</";
-			Buffer.add_string tmp tag;
-			Buffer.add_char tmp '>';
-			if newl then Buffer.add_char tmp '\n';
-		| Element (tag,alist,l) ->
-			Buffer.add_string tmp tab;
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp ">\n";
-			List.iter (loop ~newl:true (tab^"  ")) l;
-			Buffer.add_string tmp tab;
-			Buffer.add_string tmp "</";
-			Buffer.add_string tmp tag;
-			Buffer.add_char tmp '>';
-			if newl then Buffer.add_char tmp '\n';
-		| PCData text ->
-			buffer_pcdata text;
-			if newl then Buffer.add_char tmp '\n';
-	in
-	Buffer.reset tmp;
-	loop "" x;
-	let s = Buffer.contents tmp in
-	Buffer.reset tmp;
-	s
diff --git a/lib/xml_utils.mli b/lib/xml_utils.mli
deleted file mode 100644
index 4a4a1309..00000000
--- a/lib/xml_utils.mli
+++ /dev/null
@@ -1,93 +0,0 @@
-(*
- * Xml Light, an small Xml parser/printer with DTD support.
- * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
-
-(** Xml Light
- 
-  Xml Light is a minimal Xml parser & printer for OCaml.
-  It provide few functions to parse a basic Xml document into
-  an OCaml data structure and to print back the data structures
-  to an Xml document.
-
-  Xml Light has also support for {b DTD} (Document Type Definition).
-
-  {i (c)Copyright 2002-2003 Nicolas Cannasse}
-*)
-
-open Xml_parser
-
-(** {6 Xml Functions} *)
-
-exception Not_element of xml
-exception Not_pcdata of xml
-exception No_attribute of string
-
-(** [tag xdata] returns the tag value of the xml node.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val tag : xml -> string
-
-(** [pcdata xdata] returns the PCData value of the xml node.
- Raise {!Xml.Not_pcdata} if the xml is not a PCData *)
-val pcdata : xml -> string
-
-(** [attribs xdata] returns the attribute list of the xml node.
- First string if the attribute name, second string is attribute value.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val attribs : xml -> (string * string) list 
-
-(** [attrib xdata "href"] returns the value of the ["href"]
- attribute of the xml node (attribute matching is case-insensitive).
- Raise {!Xml.No_attribute} if the attribute does not exists in the node's
- attribute list 
- Raise {!Xml.Not_element} if the xml is not an element *)
-val attrib : xml -> string -> string
-
-(** [children xdata] returns the children list of the xml node
- Raise {!Xml.Not_element} if the xml is not an element *)
-val children : xml -> xml list
-
-(*** [enum xdata] returns the children enumeration of the xml node
- Raise {!Xml.Not_element} if the xml is not an element *)
-(* val enum : xml -> xml Enum.t *)
-
-(** [iter f xdata] calls f on all children of the xml node.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val iter : (xml -> unit) -> xml -> unit
-
-(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)]
- Raise {!Xml.Not_element} if the xml is not an element *)
-val map : (xml -> 'a) -> xml -> 'a list
-
-(** [fold f init xdata] is equivalent to
- [List.fold_left f init (Xml.children xdata)]
- Raise {!Xml.Not_element} if the xml is not an element *)
-val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a
-
-(** {6 Xml Printing} *)
-
-(** Print the xml data structure to a channel into a compact xml string (without
- any user-readable formating ). *)
-val print_xml : out_channel -> xml -> unit
-
-(** Print the xml data structure into a compact xml string (without
- any user-readable formating ). *)
-val to_string : xml -> string
-
-(** Print the xml data structure into an user-readable string with
- tabs and lines break between different nodes. *)
-val to_string_fmt : xml -> string