Imported Upstream version 8.8.2upstream/8.8.2

22 files changed, 1797 insertions, 2700 deletions

diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v
new file mode 100644
index 00000000..12458c10
--- /dev/null
+++ b/plugins/funind/FunInd.v
@@ -0,0 +1,12 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+Require Coq.extraction.Extraction.
+Declare ML Module "recdef_plugin".
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
index e4433247..d94e62b4 100644
--- a/plugins/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -1,13 +1,15 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
+Require Export Coq.funind.FunInd.
 Require Import PeanoNat.
-
 Require Compare_dec.
 Require Wf_nat.
 
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index b0ffc775..d04887a4 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,14 +1,14 @@
 open Printer
 open CErrors
 open Util
-open Term
+open Constr
+open EConstr
 open Vars
 open Namegen
 open Names
 open Pp
 open Tacmach
 open Termops
-open Proof_type
 open Tacticals
 open Tactics
 open Indfun_common
@@ -16,6 +16,8 @@ open Libnames
 open Globnames
 open Context.Rel.Declaration
 
+module RelDecl = Context.Rel.Declaration
+
 (* let msgnl = Pp.msgnl *)
 
 (*
@@ -42,6 +44,10 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g
   *)
 
 
+let pr_leconstr_fp =
+  let sigma, env = Pfedit.get_current_context () in
+  Printer.pr_leconstr_env env sigma
+
 let debug_queue = Stack.create ()
 
 let rec print_debug_queue e = 
@@ -93,6 +99,7 @@ let list_chop ?(msg="") n l =
   with Failure (msg') ->
     failwith (msg ^ msg')
 
+let pop t = Vars.lift (-1) t
 
 let make_refl_eq constructor type_of_t t  =
 (*   let refl_equal_term = Lazy.force refl_equal in *)
@@ -101,7 +108,7 @@ let make_refl_eq constructor type_of_t t  =
 
 type pte_info =
     {
-      proving_tac : (Id.t list ->  Tacmach.tactic);
+      proving_tac : (Id.t list -> Tacmach.tactic);
       is_valid : constr -> bool
     }
 
@@ -129,16 +136,16 @@ let refine c =
 
 let thin l = Proofview.V82.of_tactic (Tactics.clear l)
 
-let eq_constr u v = eq_constr_nounivs u v
+let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v
 
-let is_trivial_eq t =
+let is_trivial_eq sigma t =
   let res =   try
     begin
-      match kind_of_term t with
-	| App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
-	    eq_constr t1 t2
-	| App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ())  ->
-	    eq_constr t1 t2 && eq_constr a1 a2
+      match EConstr.kind sigma t with
+	| App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) ->
+	    eq_constr sigma t1 t2
+	| App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ())  ->
+	    eq_constr sigma t1 t2 && eq_constr sigma a1 a2
 	| _ -> false
     end
   with e when CErrors.noncritical e -> false
@@ -146,30 +153,30 @@ let is_trivial_eq t =
 (*   observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
   res
 
-let rec incompatible_constructor_terms t1 t2 =
-  let c1,arg1 = decompose_app t1
-  and c2,arg2 = decompose_app t2
+let rec incompatible_constructor_terms sigma t1 t2 =
+  let c1,arg1 = decompose_app sigma t1
+  and c2,arg2 = decompose_app sigma t2
   in
-  (not (eq_constr t1 t2)) &&
-    isConstruct c1 && isConstruct c2 &&
+  (not (eq_constr sigma t1 t2)) &&
+    isConstruct sigma c1 && isConstruct sigma c2 &&
     (
-      not (eq_constr c1 c2) ||
-	List.exists2 incompatible_constructor_terms arg1 arg2
+      not (eq_constr sigma c1 c2) ||
+	List.exists2 (incompatible_constructor_terms sigma) arg1 arg2
     )
 
-let is_incompatible_eq t =
+let is_incompatible_eq sigma t =
   let res =
     try
-      match kind_of_term t with
-	| App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
-	    incompatible_constructor_terms t1 t2
-	| App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) ->
-	    (eq_constr u1 u2 &&
-	       incompatible_constructor_terms t1 t2)
+      match EConstr.kind sigma t with
+	| App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) ->
+	    incompatible_constructor_terms sigma t1 t2
+	| App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) ->
+	    (eq_constr sigma u1 u2 &&
+	       incompatible_constructor_terms sigma t1 t2)
 	| _ -> false
     with e when CErrors.noncritical e -> false
   in
-  if res then   observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
+  if res then   observe (str "is_incompatible_eq " ++ pr_leconstr_fp t);
   res
 
 let change_hyp_with_using msg hyp_id t tac : tactic =
@@ -206,40 +213,41 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) =
 
 
 
-let find_rectype env c =
-  let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in
-  match kind_of_term t with
+let find_rectype env sigma c =
+  let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in
+  match EConstr.kind sigma t with
   | Ind ind -> (t, l)
   | Construct _ -> (t,l)
   | _ -> raise Not_found
 
 
-let isAppConstruct ?(env=Global.env ()) t =
+let isAppConstruct ?(env=Global.env ()) sigma t =
   try
-    let t',l = find_rectype (Global.env ()) t in
-    observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist  (t',l)));
+    let t',l = find_rectype env sigma t in
+    observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++
+             Printer.pr_leconstr_env env sigma (applist  (t',l)));
     true
   with Not_found -> false
 
 let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
-  let clos_norm_flags flgs env sigma t =
-    CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags CClosure.betaiotazeta  Environ.empty_env Evd.empty
+  Reductionops.clos_norm_flags CClosure.betaiotazeta  Environ.empty_env Evd.empty
 
 
+exception NoChange
 
-let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type  =
+let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
   let nochange ?t' msg  =
     begin
-      observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t  ++ str "    " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t );
-      failwith "NoChange";
+      observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t  ++ str "    " ++
+               match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t );
+      raise NoChange;
     end
   in
-  let eq_constr = Evarconv.e_conv env (ref sigma) in
-  if not (noccurn 1 end_of_type)
+  let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in
+  if not (noccurn sigma 1 end_of_type)
   then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
-    if not (isApp t) then nochange "not an equality";
-    let f_eq,args = destApp t in
+    if not (isApp sigma t) then nochange "not an equality";
+    let f_eq,args = destApp sigma t in
     let constructor,t1,t2,t1_typ =
       try
 	if (eq_constr f_eq (Lazy.force eq))
@@ -256,42 +264,42 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type  =
 	  else nochange "not an equality"
       with e when CErrors.noncritical e -> nochange "not an equality"
     in
-    if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
+    if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs";
     let rec compute_substitution sub t1 t2 =
 (*       observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *)
-      if isRel t2
+      if isRel sigma t2
       then
-	let t2 = destRel t2  in
+	let t2 = destRel sigma t2  in
 	begin
 	  try
 	    let t1' = Int.Map.find t2 sub in
 	    if not (eq_constr t1 t1') then nochange "twice bound variable";
 	    sub
 	  with Not_found ->
-	    assert (closed0 t1);
+	    assert (closed0 sigma t1);
 	    Int.Map.add t2 t1 sub
 	end
-      else if isAppConstruct t1 && isAppConstruct t2
+      else if isAppConstruct sigma t1 && isAppConstruct sigma t2
       then
 	begin
-	  let c1,args1 =  find_rectype env t1
-	  and c2,args2 = find_rectype env t2
+	  let c1,args1 =  find_rectype env sigma t1
+	  and c2,args2 = find_rectype env sigma t2
 	  in
 	  if not (eq_constr c1 c2) then nochange "cannot solve (diff)";
 	  List.fold_left2 compute_substitution sub args1 args2
 	end
       else
-	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2)  "cannot solve (diff)"
+	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2)  "cannot solve (diff)"
     in
     let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in
     let sub = compute_substitution sub (fst t1) (fst t2) in
-    let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *)
+    let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *)
     let new_end_of_type =
       (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
 	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
       *)
       let sub = Int.Map.bindings sub in
-      List.fold_left (fun end_of_type (i,t)  -> lift 1 (substnl  [t] (i-1) end_of_type))
+      List.fold_left (fun end_of_type (i,t)  -> liftn 1 i (substnl  [t] (i-1) end_of_type))
 	end_of_type_with_pop
 	sub
     in
@@ -307,7 +315,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type  =
 	   try
 	     let witness = Int.Map.find i sub in
 	     if is_local_def decl then anomaly (Pp.str "can not redefine a rel!");
-	     (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun))
+	     (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun))
 	   with Not_found  ->
 	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
 	)
@@ -316,9 +324,9 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type  =
 	context
     in
     let new_type_of_hyp =
-      Reductionops.nf_betaiota Evd.empty new_type_of_hyp in
+      Reductionops.nf_betaiota env sigma new_type_of_hyp in
     let new_ctxt,new_end_of_type =
-      decompose_prod_n_assum ctxt_size new_type_of_hyp
+      decompose_prod_n_assum sigma ctxt_size new_type_of_hyp
     in
     let prove_new_hyp : tactic =
       tclTHEN
@@ -351,21 +359,21 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type  =
     new_ctxt,new_end_of_type,simpl_eq_tac
 
 
-let is_property (ptes_info:ptes_info) t_x full_type_of_hyp =
-  if isApp t_x
+let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp =
+  if isApp sigma t_x
   then
-    let pte,args = destApp t_x in
-    if isVar pte && Array.for_all closed0 args
+    let pte,args = destApp sigma t_x in
+    if isVar sigma pte && Array.for_all (closed0 sigma) args
     then
       try
-	let info = Id.Map.find (destVar pte) ptes_info in
+	let info = Id.Map.find (destVar sigma pte) ptes_info in
 	info.is_valid full_type_of_hyp
       with Not_found -> false
     else false
   else false
 
-let isLetIn t =
-  match kind_of_term t with
+let isLetIn sigma t =
+  match EConstr.kind sigma t with
     | LetIn _ -> true
     | _ -> false
 
@@ -385,15 +393,16 @@ let rewrite_until_var arg_num eq_ids : tactic =
      will break the Guard when trying to save the Lemma.
   *)
   let test_var g =
-    let _,args = destApp (pf_concl g) in
-    not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
+    let sigma = project g in
+    let _,args = destApp sigma (pf_concl g) in
+    not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num))
   in
   let rec do_rewrite eq_ids g  =
     if test_var g
     then tclIDTAC g
     else
       match eq_ids with
-	| [] -> anomaly (Pp.str "Cannot find a way to prove recursive property");
+	| [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.");
 	| eq_id::eq_ids ->
 	    tclTHEN
 	      (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id))))
@@ -405,30 +414,30 @@ let rewrite_until_var arg_num eq_ids : tactic =
 
 let rec_pte_id = Id.of_string "Hrec"
 let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
-  let coq_False = Coqlib.build_coq_False () in
-  let coq_True = Coqlib.build_coq_True () in
-  let coq_I = Coqlib.build_coq_I () in
+  let coq_False = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ()) in
+  let coq_True = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ()) in
+  let coq_I = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in
   let rec scan_type  context type_of_hyp : tactic =
-    if isLetIn type_of_hyp then
+    if isLetIn sigma type_of_hyp then
       let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in
       let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in
       (* length of context didn't change ? *)
       let new_context,new_typ_of_hyp =
-	 decompose_prod_n_assum (List.length context) reduced_type_of_hyp
+	 decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp
       in
         tclTHENLIST
 	[ h_reduce_with_zeta (Locusops.onHyp hyp_id);
 	  scan_type new_context new_typ_of_hyp ]
-    else if isProd type_of_hyp
+    else if isProd sigma type_of_hyp
     then
       begin
-	let (x,t_x,t') = destProd type_of_hyp in
+	let (x,t_x,t') = destProd sigma type_of_hyp in
 	let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in
-	if is_property ptes_infos t_x actual_real_type_of_hyp then
+	if is_property sigma ptes_infos t_x actual_real_type_of_hyp then
 	  begin
-	    let pte,pte_args =  (destApp t_x) in
-	    let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in
-	    let popped_t' = Termops.pop t' in
+	    let pte,pte_args =  (destApp sigma t_x) in
+	    let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in
+	    let popped_t' = pop t' in
 	    let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in
 	    let prove_new_type_of_hyp =
 	      let context_length = List.length context in
@@ -465,20 +474,20 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 		scan_type context popped_t'
 	      ]
 	  end
-	else if eq_constr t_x coq_False then
+	else if eq_constr sigma t_x coq_False then
 	  begin
 (* 	    observe (str "Removing : "++ Ppconstr.pr_id hyp_id++  *)
 (* 		       str " since it has False in its preconds " *)
 (* 		    ); *)
 	    raise TOREMOVE;  (* False -> .. useless *)
 	  end
-	else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... =  C2 ... *)
-	else if eq_constr t_x coq_True  (* Trivial => we remove this precons *)
+	else if is_incompatible_eq sigma t_x then raise TOREMOVE (* t_x := C1 ... =  C2 ... *)
+	else if eq_constr sigma t_x coq_True  (* Trivial => we remove this precons *)
 	then
 (* 	    observe (str "In "++Ppconstr.pr_id hyp_id++  *)
 (* 		       str " removing useless precond True" *)
 (* 		    );  *)
-	  let popped_t' = Termops.pop t' in
+	  let popped_t' = pop t' in
 	  let real_type_of_hyp =
 	    it_mkProd_or_LetIn popped_t' context
 	  in
@@ -504,15 +513,15 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	      ((* observe_tac "prove_trivial" *) prove_trivial);
 	    scan_type context popped_t'
 	  ]
-	else if is_trivial_eq t_x
+	else if is_trivial_eq sigma t_x
 	then (*  t_x :=  t = t   => we remove this precond *)
-	  let popped_t' = Termops.pop t' in
+	  let popped_t' = pop t' in
 	  let real_type_of_hyp =
 	    it_mkProd_or_LetIn popped_t' context
 	  in
-	  let hd,args = destApp t_x in
+	  let hd,args = destApp sigma t_x in
 	  let get_args hd args =
-	    if eq_constr hd (Lazy.force eq)
+	    if eq_constr sigma hd (Lazy.force eq)
 	    then (Lazy.force refl_equal,args.(0),args.(1))
 	    else (jmeq_refl (),args.(0),args.(1))
 	  in
@@ -533,7 +542,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	      tclTHEN
 		tac
 		(scan_type new_context new_t')
-	    with Failure "NoChange" ->
+	    with NoChange ->
 	      (* Last thing todo : push the rel in the context and continue *)
 	      scan_type (LocalAssum (x,t_x) :: context) t'
 	  end
@@ -584,7 +593,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
     tclTHENLIST
       [
 	(* We first introduce the variables *)
-	tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps));
+	tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps)));
 	(* Then the equation itself *)
 	Proofview.V82.of_tactic (intro_using heq_id);
 	onLastHypId (fun heq_id -> tclTHENLIST [
@@ -595,18 +604,18 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 	   let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in
 	   (* compute the new value of the body *)
 	   let new_term_value =
-	     match kind_of_term new_term_value_eq with
+	     match EConstr.kind (project g') new_term_value_eq with
 	       | App(f,[| _;_;args2 |]) -> args2
 	       | _ ->
 		   observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++
-			      pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq
+			      pr_leconstr_env (pf_env g') (project g') new_term_value_eq
 			   );
-		   anomaly (Pp.str "cannot compute new term value")
+		   anomaly (Pp.str "cannot compute new term value.")
 	   in
 	 let fun_body =
 	   mkLambda(Anonymous,
 		    pf_unsafe_type_of g' term,
-		    Termops.replace_term term (mkRel 1) dyn_infos.info
+		    Termops.replace_term (project g') term (mkRel 1) dyn_infos.info
 		   )
 	 in
 	 let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
@@ -683,34 +692,36 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id =
 
 let build_proof
     (interactive_proof:bool)
-    (fnames:constant list)
+    (fnames:Constant.t list)
     ptes_infos
     dyn_infos
     : tactic =
   let rec build_proof_aux do_finalize dyn_infos : tactic =
     fun g ->
+        let env = pf_env g in
+        let sigma = project g in
 (*      observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*)
-	match kind_of_term dyn_infos.info with
+	match EConstr.kind sigma dyn_infos.info with
 	  | Case(ci,ct,t,cb) ->
 	      let do_finalize_t dyn_info' =
 		fun g ->
 		  let t = dyn_info'.info in
 		  let dyn_infos = {dyn_info' with info =
 		      mkCase(ci,ct,t,cb)} in
-		  let g_nb_prod = nb_prod (pf_concl g) in
+		  let g_nb_prod = nb_prod (project g) (pf_concl g) in
 		  let type_of_term = pf_unsafe_type_of g t in
 		  let term_eq =
 		    make_refl_eq (Lazy.force refl_equal) type_of_term t
 		  in
-		  tclTHENSEQ
+		  tclTHENLIST
 		    [
 		      Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)));
 		      thin dyn_infos.rec_hyps;
 		      Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None);
 		      (fun g -> observe_tac "toto" (
-			 tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t);
+			 tclTHENLIST [Proofview.V82.of_tactic (Simple.case t);
 				     (fun g' ->
-					let g'_nb_prod = nb_prod (pf_concl g') in
+					let g'_nb_prod = nb_prod (project g') (pf_concl g') in
 					let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
 			 		observe_tac "treat_new_case"
 					  (treat_new_case
@@ -730,7 +741,7 @@ let build_proof
 	      build_proof do_finalize_t {dyn_infos with info = t} g
 	  | Lambda(n,t,b) ->
 	      begin
-		match kind_of_term( pf_concl g) with
+		match EConstr.kind sigma (pf_concl g) with
 		  | Prod _ ->
 		      tclTHEN
 			(Proofview.V82.of_tactic intro)
@@ -760,9 +771,9 @@ let build_proof
 	  | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
 	      do_finalize dyn_infos g
 	  | App(_,_) ->
-	      let f,args = decompose_app dyn_infos.info in
+	      let f,args = decompose_app sigma dyn_infos.info in
 	      begin
-		match kind_of_term f with
+		match EConstr.kind sigma f with
 		  | App _ -> assert false (* we have collected all the app in decompose_app *)
 		  | Proj _ -> assert false (*FIXME*)
 		  | Var _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ | Sort _ | Prod _ ->
@@ -784,7 +795,7 @@ let build_proof
 		      do_finalize dyn_infos  g
 		  | Lambda _ ->
 		      let new_term =
-                        Reductionops.nf_beta Evd.empty dyn_infos.info in
+                        Reductionops.nf_beta env sigma dyn_infos.info in
 		      build_proof do_finalize {dyn_infos with info = new_term}
 			g
 		  | LetIn _ ->
@@ -815,10 +826,11 @@ let build_proof
 		      build_proof new_finalize {dyn_infos  with info = f } g
 	      end
 	  | Fix _ | CoFix _ ->
-	      error ( "Anonymous local (co)fixpoints are not handled yet")
+	      user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet"))
+
 
-	  | Proj _ -> error "Prod"
-	  | Prod _ -> error "Prod"
+	  | Proj _ -> user_err Pp.(str "Prod")
+	  | Prod _ -> do_finalize dyn_infos g
 	  | LetIn _ ->
 	      let new_infos =
 		{ dyn_infos with
@@ -833,10 +845,10 @@ let build_proof
 		 h_reduce_with_zeta Locusops.onConcl;
 		 build_proof do_finalize new_infos
 		] g
-	  | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !")
+	  | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!")
   and build_proof do_finalize dyn_infos g =
 (*     observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
-    observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g
+    observe_tac_stream (str "build_proof with " ++ pr_leconstr_fp dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g
   and build_proof_args do_finalize dyn_infos (* f_args'  args *) :tactic =
     fun g ->
       let (f_args',args) = dyn_infos.info in
@@ -902,7 +914,7 @@ let prove_rec_hyp_for_struct fix_info =
       (fun  eq_hyps -> tclTHEN
 	(rewrite_until_var (fix_info.idx) eq_hyps)
 	(fun g ->
-	   let _,pte_args = destApp (pf_concl g) in
+	   let _,pte_args = destApp (project g) (pf_concl g) in
 	   let rec_hyp_proof =
 	     mkApp(mkVar fix_info.name,array_get_start pte_args)
 	   in
@@ -923,10 +935,11 @@ let generalize_non_dep hyp g =
   let to_revert,_ =
     let open Context.Named.Declaration in
     Environ.fold_named_context_reverse (fun (clear,keep) decl ->
+      let decl = map_named_decl EConstr.of_constr decl in
       let hyp = get_id decl in
       if Id.List.mem hyp hyps
-        || List.exists (Termops.occur_var_in_decl env hyp) keep
-	|| Termops.occur_var env hyp hyp_typ
+        || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep
+	|| Termops.occur_var env (project g) hyp hyp_typ
 	|| Termops.is_section_variable hyp (* should be dangerous *)
       then (clear,decl::keep)
       else (hyp::clear,keep))
@@ -938,8 +951,8 @@ let generalize_non_dep hyp g =
     ((* observe_tac "thin" *) (thin to_revert))
     g
 
-let id_of_decl decl = Nameops.out_name (get_name decl)
-let var_of_decl decl = mkVar (id_of_decl decl)
+let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id
+let var_of_decl = id_of_decl %> mkVar
 let revert idl =
   tclTHEN
     (Proofview.V82.of_tactic (generalize (List.map mkVar idl)))
@@ -949,11 +962,12 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num
 (*   observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
 (*   observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
 (*   observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
-  let f_def = Global.lookup_constant (fst (destConst f)) in
+  let f_def = Global.lookup_constant (fst (destConst evd f)) in
   let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
-  let f_body = Option.get (Global.body_of_constant_body f_def) in
-  let params,f_body_with_params = decompose_lam_n nb_params f_body in
-  let (_,num),(_,_,bodies) = destFix f_body_with_params in
+  let (f_body, _) = Option.get (Global.body_of_constant_body f_def) in
+  let f_body = EConstr.of_constr f_body in
+  let params,f_body_with_params = decompose_lam_n evd nb_params f_body in
+  let (_,num),(_,_,bodies) = destFix evd f_body_with_params in
   let fnames_with_params =
     let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in
     let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in
@@ -968,20 +982,20 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num
   let (type_ctxt,type_of_f),evd =
     let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f
     in 
-    decompose_prod_n_assum
+    decompose_prod_n_assum evd
       (nb_params + nb_args) t,evd
   in
   let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
   let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in
   (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *)
-  let f_id = Label.to_id (con_label (fst (destConst f))) in
+  let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in
   let prove_replacement =
-    tclTHENSEQ
+    tclTHENLIST
       [
 	tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro);
 	observe_tac "" (fun g ->
 	   let rec_id = pf_nth_hyp_id g 1 in
-	   tclTHENSEQ
+	   tclTHENLIST
 	     [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id);
 	      observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id)));
 	      (Proofview.V82.of_tactic intros_reflexivity)] g
@@ -1008,10 +1022,10 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num
 let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g =
   let equation_lemma =
     try
-      let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in
+      let finfos = find_Function_infos (fst (destConst !evd f)) (*FIXME*) in
       mkConst (Option.get finfos.equation_lemma)
     with (Not_found | Option.IsNone as e) ->
-      let f_id = Label.to_id (con_label (fst (destConst f))) in
+      let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in
       (*i The next call to mk_equation_id is valid since we will construct the lemma
 	Ensures by: obvious
 	i*)
@@ -1020,12 +1034,12 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a
       let _ =
 	match e with
 	  | Option.IsNone ->
-	      let finfos = find_Function_infos (fst (destConst f)) in
+	      let finfos = find_Function_infos (fst (destConst !evd f)) in
 	      update_Function
 		{finfos with
 		   equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
 					      ConstRef c -> c
-					    | _ -> CErrors.anomaly (Pp.str "Not a constant")
+					    | _ -> CErrors.anomaly (Pp.str "Not a constant.")
 					 )
 		}
 	  | _ -> ()
@@ -1036,11 +1050,12 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a
 	  (Global.env ()) !evd
 	  (Constrintern.locate_reference (qualid_of_ident equation_lemma_id))
       in
+      let res = EConstr.of_constr res in
       evd:=evd';                       
       let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in 
       res
   in
-  let nb_intro_to_do = nb_prod (pf_concl g) in
+  let nb_intro_to_do = nb_prod (project g) (pf_concl g) in
     tclTHEN
       (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro))
       (
@@ -1059,7 +1074,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
   (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *)
   (* Pp.msgnl (str "all_funs "); *)
   (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *)
-    let princ_info = compute_elim_sig princ_type in
+    let princ_info = compute_elim_sig (project g) princ_type in
     let fresh_id =
       let avoid = ref (pf_ids_of_hyps g) in
       (fun na ->
@@ -1072,7 +1087,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	 (Name new_id)
       )
     in
-    let fresh_decl = map_name fresh_id in
+    let fresh_decl = RelDecl.map_name fresh_id in
     let princ_info : elim_scheme =
       { princ_info with
 	  params = List.map fresh_decl princ_info.params;
@@ -1083,16 +1098,16 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
     in
     let get_body const =
       match Global.body_of_constant const with
-	| Some body ->
+	| Some (body, _) ->
 	     Tacred.cbv_norm_flags
 	       (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
 	       (Global.env ())
 	       (Evd.empty)
-	       body
-	| None -> error ( "Cannot define a principle over an axiom ")
+	       (EConstr.of_constr body)
+	| None -> user_err Pp.(str "Cannot define a principle over an axiom ")
     in
     let fbody = get_body fnames.(fun_num) in
-    let f_ctxt,f_body = decompose_lam fbody in
+    let f_ctxt,f_body = decompose_lam (project g) fbody in
     let f_ctxt_length = List.length f_ctxt in
     let diff_params = princ_info.nparams - f_ctxt_length in
     let full_params,princ_params,fbody_with_full_params =
@@ -1119,27 +1134,27 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	)
     in
     observe (str "full_params := " ++
-	       prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl)))
+	       prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id)
 	       full_params
 	    );
     observe (str "princ_params := " ++
-	       prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl)))
+	       prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id)
 	       princ_params
 	    );
     observe (str "fbody_with_full_params := " ++
-	       pr_lconstr fbody_with_full_params
+               pr_leconstr_env (Global.env ()) !evd fbody_with_full_params
 	    );
     let all_funs_with_full_params =
       Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs
     in
     let fix_offset = List.length princ_params in
     let ptes_to_fix,infos =
-      match kind_of_term fbody_with_full_params with
+      match EConstr.kind (project g) fbody_with_full_params with
 	| Fix((idxs,i),(names,typess,bodies)) ->
 	    let bodies_with_all_params =
 	      Array.map
 		(fun body ->
-		   Reductionops.nf_betaiota Evd.empty
+                   Reductionops.nf_betaiota (pf_env g) (project g)
 		     (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body,
 			      List.rev_map var_of_decl princ_params))
 		)
@@ -1148,14 +1163,14 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    let info_array =
 	      Array.mapi
 		(fun i types ->
-		   let types = prod_applist types (List.rev_map var_of_decl princ_params) in
+		   let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in
 		   { idx = idxs.(i)  - fix_offset;
-		     name = Nameops.out_name (fresh_id names.(i));
+		     name = Nameops.Name.get_id (fresh_id names.(i));
 		     types = types;
 		     offset = fix_offset;
 		     nb_realargs =
 		       List.length
-			 (fst (decompose_lam bodies.(i))) - fix_offset;
+			 (fst (decompose_lam (project g) bodies.(i))) - fix_offset;
 		     body_with_param = bodies_with_all_params.(i);
 		     num_in_block = i
 		   }
@@ -1165,24 +1180,24 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    let pte_to_fix,rev_info =
 	      List.fold_left_i
 		(fun i (acc_map,acc_info) decl ->
-		   let pte = get_name decl in
+		   let pte = RelDecl.get_name decl in
 		   let infos = info_array.(i) in
-		   let type_args,_ = decompose_prod infos.types in
+		   let type_args,_ = decompose_prod (project g) infos.types in
 		   let nargs = List.length type_args in
 		   let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in
 		   let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in
 		   let app_f = mkApp(f,first_args) in
 		   let pte_args = (Array.to_list first_args)@[app_f] in
-		   let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in
+		   let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in
 		   let body_with_param,num =
 		     let body = get_body fnames.(i) in
 		     let body_with_full_params =
-		       Reductionops.nf_betaiota Evd.empty (
+                       Reductionops.nf_betaiota (pf_env g) (project g) (
 			 applist(body,List.rev_map var_of_decl full_params))
 		     in
-		     match kind_of_term body_with_full_params with
+		     match EConstr.kind (project g) body_with_full_params with
 		       | Fix((_,num),(_,_,bs)) ->
-			       Reductionops.nf_betaiota Evd.empty
+                               Reductionops.nf_betaiota (pf_env g) (project g)
 				 (
 				   (applist
 				      (substl
@@ -1191,7 +1206,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 					 bs.(num),
 				       List.rev_map var_of_decl princ_params))
 				 ),num
-			 | _ -> error "Not a mutual block"
+			 | _ -> user_err Pp.(str "Not a mutual block")
 		   in
 		   let info =
 		     {infos with
@@ -1200,9 +1215,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 			 num_in_block = num
 		     }
 		   in
-(* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++  *)
+(* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++  *)
 (* 			      str " to " ++ Ppconstr.pr_id info.name); *)
-		   (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info)
+		   (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info)
 		   )
 		0
 		(Id.Map.empty,[])
@@ -1215,7 +1230,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
     let mk_fixes : tactic =
       let pre_info,infos = list_chop fun_num infos in
       match pre_info,infos with
-	| [],[] -> tclIDTAC
+	| _,[] -> tclIDTAC
 	| _, this_fix_info::others_infos ->
 	    let other_fix_infos =
 	      List.map
@@ -1231,10 +1246,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    else
 	      Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
 		other_fix_infos 0)
-	| _ -> anomaly (Pp.str "Not a valid information")
     in
     let first_tac : tactic = (* every operations until fix creations *)
-      tclTHENSEQ
+      tclTHENLIST
 	[ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params)));
 	  observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates)));
 	  observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches)));
@@ -1243,16 +1257,16 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
     in
     let intros_after_fixes : tactic =
       fun gl ->
-	let ctxt,pte_app =  (decompose_prod_assum (pf_concl gl)) in
-	let pte,pte_args = (decompose_app pte_app) in
+	let ctxt,pte_app =  (decompose_prod_assum (project gl) (pf_concl gl)) in
+	let pte,pte_args = (decompose_app (project gl) pte_app) in
 	try
 	  let pte =
-            try destVar pte
-            with DestKO -> anomaly (Pp.str "Property is not a variable")
+            try destVar (project gl) pte
+            with DestKO -> anomaly (Pp.str "Property is not a variable.")
           in
 	  let fix_info = Id.Map.find  pte ptes_to_fix in
 	  let nb_args = fix_info.nb_realargs in
-	  tclTHENSEQ
+	  tclTHENLIST
 	    [
 	      (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro));
 	      (fun g -> (* replacement of the function by its body *)
@@ -1266,18 +1280,18 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 		     nb_rec_hyps = -100;
 		     rec_hyps = [];
 		     info =
-		       Reductionops.nf_betaiota Evd.empty
+                       Reductionops.nf_betaiota (pf_env g) (project g)
 			 (applist(fix_body,List.rev_map mkVar args_id));
 		     eq_hyps = []
 		   }
 		 in
-		 tclTHENSEQ
+		 tclTHENLIST
 		   [
 		     observe_tac "do_replace"
 		       (do_replace evd
 			  full_params
 			  (fix_info.idx + List.length princ_params)
-			  (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params))
+			  (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params))
 			  (all_funs.(fix_info.num_in_block))
 			  fix_info.num_in_block
 			  all_funs
@@ -1314,7 +1328,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    ] gl
 	with Not_found ->
 	  let nb_args = min (princ_info.nargs) (List.length ctxt) in
-	  tclTHENSEQ
+	  tclTHENLIST
 	    [
 	      tclDO nb_args (Proofview.V82.of_tactic intro);
 	      (fun g -> (* replacement of the function by its body *)
@@ -1326,7 +1340,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 		     nb_rec_hyps = -100;
 		     rec_hyps = [];
 		     info =
-		       Reductionops.nf_betaiota Evd.empty
+                       Reductionops.nf_betaiota (pf_env g) Evd.empty
 			 (applist(fbody_with_full_params,
 				  (List.rev_map var_of_decl princ_params)@
 				    (List.rev_map mkVar args_id)
@@ -1334,8 +1348,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 		     eq_hyps = []
 		   }
 		 in
-		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
-		 tclTHENSEQ
+		 let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in
+		 tclTHENLIST
 		   [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]);
 		    let do_prove =
 		      build_proof
@@ -1375,7 +1389,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 
 
 (* Proof of principles of general functions *)
-(* let  hrec_id =

+(* let  hrec_id = Recdef.hrec_id *)
 (* and acc_inv_id = Recdef.acc_inv_id *)
 (* and ltof_ref = Recdef.ltof_ref *)
 (* and acc_rel = Recdef.acc_rel *)
@@ -1389,12 +1403,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 
 let prove_with_tcc tcc_lemma_constr eqs : tactic =
   match !tcc_lemma_constr with
-    | None -> anomaly (Pp.str "No tcc proof !!")
-    | Some lemma ->
+  | Undefined -> anomaly (Pp.str "No tcc proof !!")
+  | Value lemma ->
 	fun gls ->
 (* 	  let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *)
 (* 	  let ids = hid::pf_ids_of_hyps gls in  *)
-	  tclTHENSEQ
+	  tclTHENLIST
 	    [
 (* 	      generalize [lemma]; *)
 (* 	      h_intro hid; *)
@@ -1408,7 +1422,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
 	      Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some []))
 	    ]
 	    gls
-
+  | Not_needed -> tclIDTAC
 
 let backtrack_eqs_until_hrec hrec eqs : tactic =
   fun gls ->
@@ -1416,14 +1430,14 @@ let backtrack_eqs_until_hrec hrec eqs : tactic =
     let rewrite =
       tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs )
     in
-    let _,hrec_concl  = decompose_prod (pf_unsafe_type_of gls (mkVar hrec)) in
-    let f_app = Array.last (snd (destApp hrec_concl)) in
-    let f =  (fst (destApp f_app)) in
+    let _,hrec_concl  = decompose_prod (project gls) (pf_unsafe_type_of gls (mkVar hrec)) in
+    let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in
+    let f =  (fst (destApp (project gls) f_app)) in
     let rec backtrack : tactic =
       fun g ->
-	let f_app = Array.last (snd (destApp (pf_concl g))) in
-	match kind_of_term f_app with
-	  | App(f',_) when eq_constr f' f -> tclIDTAC g
+	let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in
+	match EConstr.kind (project g) f_app with
+	  | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g
 	  | _ -> tclTHEN rewrite backtrack g
     in
     backtrack gls
@@ -1449,13 +1463,13 @@ let rec rewrite_eqs_in_eqs eqs =
 
 let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
   fun gls ->
-    (tclTHENSEQ
+    (tclTHENLIST
        [
 	 backtrack_eqs_until_hrec hrec eqs;
 	 (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *)
 	 (tclTHENS  (* We must have exactly ONE subgoal !*)
 	    (Proofview.V82.of_tactic (apply (mkVar hrec)))
-	    [ tclTHENSEQ
+	    [ tclTHENLIST
 		[
 		  (Proofview.V82.of_tactic (keep (tcc_hyps@eqs)));
 		  (Proofview.V82.of_tactic (apply (Lazy.force acc_inv)));
@@ -1474,7 +1488,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 			    tclCOMPLETE(
 				    Eauto.eauto_with_bases
 				      (true,5)
-				      [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}]
+				      [(fun _ sigma -> (sigma, Lazy.force refl_equal))]
 				      [Hints.Hint_db.empty empty_transparent_state false]
 				  )
 			   )
@@ -1487,20 +1501,20 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
       gls
 
 
-let is_valid_hypothesis predicates_name =
+let is_valid_hypothesis sigma predicates_name =
   let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in
   let is_pte typ =
-    if isApp typ
+    if isApp sigma typ
     then
-      let pte,_ = destApp typ in
-      if isVar pte
-      then Id.Set.mem (destVar pte) predicates_name
+      let pte,_ = destApp sigma typ in
+      if isVar sigma pte
+      then Id.Set.mem (destVar sigma pte) predicates_name
       else false
     else false
   in
   let rec is_valid_hypothesis typ =
     is_pte typ ||
-      match kind_of_term typ with
+      match EConstr.kind sigma typ with
 	| Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ'
 	| _ -> false
   in
@@ -1510,7 +1524,7 @@ let prove_principle_for_gen
     (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
     rec_arg_num rec_arg_type relation gl =
   let princ_type = pf_concl gl in
-  let princ_info = compute_elim_sig princ_type in
+  let princ_info = compute_elim_sig (project gl) princ_type in
   let fresh_id =
     let avoid = ref (pf_ids_of_hyps gl) in
     fun na ->
@@ -1556,17 +1570,17 @@ let prove_principle_for_gen
       | _ -> assert false
   in
 (*   observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *)
-  let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in
+  let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in
   let relation = substl subst_constrs relation in
   let input_type = substl subst_constrs rec_arg_type in
-  let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in
+  let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in
   let acc_rec_arg_id =
-    Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))))
+    Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))))
   in
   let revert l =
     tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l))
   in
-  let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
+  let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in
   let prove_rec_arg_acc g =
       ((* observe_tac "prove_rec_arg_acc"  *)
 	 (tclCOMPLETE
@@ -1584,11 +1598,12 @@ let prove_principle_for_gen
       )
       g
   in
-  let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in
+  let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in
   let lemma =
     match !tcc_lemma_ref with
-     | None -> error "No tcc proof !!"
-     | Some lemma -> lemma
+     | Undefined -> user_err Pp.(str "No tcc proof !!")
+     | Value lemma -> EConstr.of_constr lemma
+     | Not_needed -> EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ())
   in
 (*   let rec list_diff del_list check_list = *)
 (*     match del_list with *)
@@ -1606,9 +1621,9 @@ let prove_principle_for_gen
       let hid =
 	next_ident_away_in_goal
 	  (Id.of_string "prov")
-	  hyps
+	  (Id.Set.of_list hyps)
       in
-      tclTHENSEQ
+      tclTHENLIST
 	[
 	  Proofview.V82.of_tactic (generalize [lemma]);
 	  Proofview.V82.of_tactic (Simple.intro hid);
@@ -1627,11 +1642,11 @@ let prove_principle_for_gen
 	  ]
 	  gls
   in
-  tclTHENSEQ
+  tclTHENLIST
     [
       observe_tac "start_tac" start_tac;
       h_intros
-	(List.rev_map (fun decl -> Nameops.out_name (get_name decl))
+	(List.rev_map (get_name %> Nameops.Name.get_id)
 	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
 	);
       (* observe_tac "" *) Proofview.V82.of_tactic (assert_by
@@ -1648,7 +1663,7 @@ let prove_principle_for_gen
       Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref));
       (* observe_tac "finish" *) (fun gl' ->
 	 let body =
-	   let _,args = destApp (pf_concl gl') in
+	   let _,args = destApp (project gl') (pf_concl gl') in
 	   Array.last args
 	 in
 	 let body_info rec_hyps =
@@ -1669,14 +1684,14 @@ let prove_principle_for_gen
 	 in
 	 let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar  acc_rec_arg_id|])) in
 	 let predicates_names =
-	   List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates
+	   List.map (get_name %> Nameops.Name.get_id) princ_info.predicates
 	 in
 	 let pte_info =
 	   { proving_tac =
 	       (fun eqs ->
 (* 		  msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id  !tcc_list); *)
-(* 		  msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *)
-(* 		  msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *)
+(* 		  msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *)
+(* 		  msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *)
 (* 		  msgnl (str "acc_rec_arg_id := "++  Ppconstr.pr_id acc_rec_arg_id); *)
 (* 		  msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id  eqs); *)
 
@@ -1685,13 +1700,13 @@ let prove_principle_for_gen
 		       is_mes acc_inv fix_id
 
 		       (!tcc_list@(List.map
-			   (fun decl -> (Nameops.out_name (get_name decl)))
+			   (get_name %> Nameops.Name.get_id)
 			   (princ_info.args@princ_info.params)
 			)@ ([acc_rec_arg_id])) eqs
 		    )
 
 	       );
-	     is_valid = is_valid_hypothesis predicates_names
+	     is_valid = is_valid_hypothesis (project gl') predicates_names
 	   }
 	 in
 	 let ptes_info : pte_info Id.Map.t =
@@ -1714,7 +1729,7 @@ let prove_principle_for_gen
 	 (* observe_tac "instanciate_hyps_with_args"  *)
 	   (instanciate_hyps_with_args
 	      make_proof
-	      (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches)
+	      (List.map (get_name %> Nameops.Name.get_id) princ_info.branches)
 	      (List.rev args_ids)
 	   )
 	   gl'
diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli
index 34ce6696..64fbfaee 100644
--- a/plugins/funind/functional_principles_proofs.mli
+++ b/plugins/funind/functional_principles_proofs.mli
@@ -1,19 +1,18 @@
 open Names
-open Term
 
 val prove_princ_for_struct :
   Evd.evar_map ref ->
   bool ->
-  int -> constant array -> constr array -> int -> Tacmach.tactic
+  int -> Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic
 
 
 val prove_principle_for_gen :
-  constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *)
-  constr option ref -> (* a pointer to the obligation proofs lemma *)
+  Constant.t * Constant.t * Constant.t -> (* name of the function, the functional and the fixpoint equation *)
+  Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *)
   bool -> (* is that function uses measure *)
   int -> (* the number of recursive argument *)
-  types -> (* the type of the recursive argument *)
-  constr -> (* the wf relation used to prove the function *)
+  EConstr.types -> (* the type of the recursive argument *)
+  EConstr.constr -> (* the wf relation used to prove the function *)
   Tacmach.tactic
 
 
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index 5e72b867..804548ce 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,7 +1,9 @@
 open Printer
 open CErrors
-open Util
 open Term
+open Sorts
+open Util
+open Constr
 open Vars
 open Namegen
 open Names
@@ -11,8 +13,8 @@ open Tactics
 open Context.Rel.Declaration
 open Indfun_common
 open Functional_principles_proofs
-open Misctypes
-open Sigma.Notations
+
+module RelDecl = Context.Rel.Declaration
 
 exception Toberemoved_with_rel of int*constr
 exception Toberemoved
@@ -21,25 +23,28 @@ let observe s =
   if do_observe ()
   then Feedback.msg_debug s
 
+let pop t = Vars.lift (-1) t
+
 (*
    Transform an inductive induction principle into
    a functional one
 *)
 let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
-  let princ_type_info = compute_elim_sig princ_type in
+  let princ_type = EConstr.of_constr princ_type in
+  let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in
   let env = Global.env () in
-  let env_with_params = Environ.push_rel_context princ_type_info.params env in
+  let env_with_params = EConstr.push_rel_context princ_type_info.params env in
   let tbl = Hashtbl.create 792 in
-  let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t)  : Context.Rel.t =
+  let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context)  : EConstr.rel_context =
     match predicates with
     | [] -> []
     | decl :: predicates ->
        (match Context.Rel.Declaration.get_name decl with
 	| Name x ->
-	   let id = Namegen.next_ident_away x avoid in
+	   let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in
 	   Hashtbl.add tbl id x;
-	   set_name (Name id) decl :: change_predicates_names (id::avoid) predicates
-	| Anonymous -> anomaly (Pp.str "Anonymous property binder "))
+	   RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates
+	| Anonymous -> anomaly (Pp.str "Anonymous property binder."))
   in
   let avoid = (Termops.ids_of_context env_with_params ) in
   let princ_type_info =
@@ -51,14 +56,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 (*   observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
   let change_predicate_sort i decl =
     let new_sort = sorts.(i) in
-    let args,_ = decompose_prod (get_type decl) in
+    let args,_ = decompose_prod (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in
     let real_args =
       if princ_type_info.indarg_in_concl
       then List.tl args
       else args
     in
-    Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl),
-                                          compose_prod real_args (mkSort new_sort))
+    Context.Named.Declaration.LocalAssum (Nameops.Name.get_id (Context.Rel.Declaration.get_name decl),
+                                          Term.compose_prod real_args (mkSort new_sort))
   in
   let new_predicates =
     List.map_i
@@ -70,18 +75,19 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let rel_as_kn =
     fst (match princ_type_info.indref with
 	   | Some (Globnames.IndRef ind) -> ind
-	   | _ -> error "Not a valid predicate"
+	   | _ -> user_err Pp.(str "Not a valid predicate")
 	)
   in
   let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in
   let is_pte =
     let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in
     fun t ->
-      match kind_of_term t with
+      match Constr.kind t with
 	| Var id -> Id.Set.mem id set
 	| _ -> false
   in
   let pre_princ =
+    let open EConstr in
     it_mkProd_or_LetIn
       (it_mkProd_or_LetIn
 	 (Option.fold_right
@@ -93,28 +99,31 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
       )
       princ_type_info.branches
   in
+  let pre_princ = EConstr.Unsafe.to_constr pre_princ in
   let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
   let is_dom c =
-    match kind_of_term c with
+    match Constr.kind c with
       | Ind((u,_),_) -> MutInd.equal u rel_as_kn
       | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn
       | _ -> false
   in
   let get_fun_num c =
-    match kind_of_term c with
+    match Constr.kind c with
       | Ind((_,num),_) -> num
       | Construct(((_,num),_),_) -> num
       | _ -> assert false
   in
   let dummy_var = mkVar (Id.of_string "________") in
   let mk_replacement c i args =
-    let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in
-    observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res);
+    let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in
+    observe (str "replacing " ++
+             pr_lconstr_env env Evd.empty c ++ str " by "  ++
+             pr_lconstr_env env Evd.empty res);
     res
   in
   let rec compute_new_princ_type remove env pre_princ : types*(constr list) =
     let (new_princ_type,_) as res =
-      match kind_of_term pre_princ with
+      match Constr.kind pre_princ with
 	| Rel n ->
 	    begin
 	      try match Environ.lookup_rel n env with
@@ -143,13 +152,13 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 		([],[])
 	    in
 	    let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in
-	    applist(new_f, new_args),
-	    list_union_eq eq_constr binders_to_remove_from_f binders_to_remove
+	    applistc new_f new_args,
+	    list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove
 	| LetIn(x,v,t,b) ->
 	    compute_new_princ_type_for_letin remove env x v t b
 	| _ -> pre_princ,[]
     in
-(*     let _ = match kind_of_term pre_princ with *)
+(*     let _ = match Constr.kind pre_princ with *)
 (* 	| Prod _ -> *)
 (* 	    observe(str "compute_new_princ_type for "++ *)
 (* 	      pr_lconstr_env env pre_princ ++ *)
@@ -165,26 +174,26 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	let new_x : Name.t = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (LocalAssum (x,t)) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
-	 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
-	 then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
+	 if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b
+	 then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b
 	 else
 	   (
 	     bind_fun(new_x,new_t,new_b),
 	     list_union_eq
-	       eq_constr
+	       Constr.equal
 	       binders_to_remove_from_t
-	       (List.map Termops.pop binders_to_remove_from_b)
+	       (List.map pop binders_to_remove_from_b)
 	   )
 
        with
 	 | Toberemoved ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+(* 	    observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
-	    new_b, List.map Termops.pop binders_to_remove_from_b
+	    new_b, List.map pop binders_to_remove_from_b
 	| Toberemoved_with_rel (n,c) ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+(* 	    observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
-	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b)
+	    new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b)
     end
   and compute_new_princ_type_for_letin remove env x v t b =
     begin
@@ -194,31 +203,31 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	let new_x : Name.t = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (LocalDef (x,v,t)) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
-	if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
-	then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
+	if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b
+	then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b
 	else
 	  (
 	    mkLetIn(new_x,new_v,new_t,new_b),
 	    list_union_eq
-	      eq_constr
-	      (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v)
-	      (List.map Termops.pop binders_to_remove_from_b)
+	      Constr.equal
+	      (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v)
+	      (List.map pop binders_to_remove_from_b)
 	  )
 
       with
 	| Toberemoved ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+(* 	    observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
-	    new_b, List.map Termops.pop binders_to_remove_from_b
+	    new_b, List.map pop binders_to_remove_from_b
 	| Toberemoved_with_rel (n,c) ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+(* 	    observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *)
 	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
-	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b)
+	    new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b)
     end
   and  compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc)  =
     let new_e,to_remove_from_e = compute_new_princ_type remove env e
     in
-    new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
+    new_e::c_acc,list_union_eq Constr.equal to_remove_from_e to_remove_acc
   in
 (*   observe (str "Computing new principe from " ++ pr_lconstr_env  env_with_params_and_predicates pre_princ); *)
   let pre_res,_ =
@@ -235,20 +244,21 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
                                  | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b))
           	      new_predicates)
     )
-    princ_type_info.params
+    (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params)
 
 
 
 let change_property_sort evd toSort princ princName =
   let open Context.Rel.Declaration in
-  let princ_info = compute_elim_sig princ in
+  let princ = EConstr.of_constr princ in
+  let princ_info = compute_elim_sig evd princ in
   let change_sort_in_predicate decl =
     LocalAssum
     (get_name decl,
-     let args,ty = decompose_prod (get_type decl) in
+     let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in
      let s = destSort ty in
        Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty);
-       compose_prod args (mkSort toSort)
+       Term.compose_prod args (mkSort toSort)
     )
   in
   let evd,princName_as_constr =
@@ -264,11 +274,11 @@ let change_property_sort evd toSort princ princName =
     (it_mkLambda_or_LetIn init
        (List.map change_sort_in_predicate princ_info.predicates)
     )
-    princ_info.params
+    (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.params)
 
 let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook =
   (* First we get the type of the old graph principle *)
-  let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
+  let mutr_nparams = (compute_elim_sig !evd (EConstr.of_constr old_princ_type)).nparams in
   (*   let time1 = System.get_time ()  in *)
   let new_principle_type =
     compute_new_princ_type_from_rel
@@ -279,20 +289,21 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin
   (*    let time2 = System.get_time ()  in *)
   (*    Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
   let new_princ_name =
-    next_ident_away_in_goal (Id.of_string "___________princ_________") []
+    next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty
   in
-  let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd new_principle_type in
+  let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in
   let hook = Lemmas.mk_hook (hook new_principle_type) in
   begin
     Lemmas.start_proof
       new_princ_name
       (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem))
       !evd
-      new_principle_type
+      (EConstr.of_constr new_principle_type)
       hook
   ;
     (*       let _tim1 = System.get_time ()  in *)
-      ignore (Pfedit.by  (Proofview.V82.tactic (proof_tac (Array.map mkConstU funs) mutr_nparams)));
+      let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in
+      ignore (Pfedit.by  (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)));
     (*       let _tim2 =  System.get_time ()  in *)
     (* 	begin *)
     (* 	  let dur1 = System.time_difference tim1 tim2 in *)
@@ -321,8 +332,8 @@ let generate_functional_principle (evd: Evd.evar_map ref)
     match new_princ_name with
       | Some (id) -> id,id
       | None ->
-	  let id_of_f = Label.to_id (con_label (fst f)) in
-	  id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
+	  let id_of_f = Label.to_id (Constant.label (fst f)) in
+	  id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort)
   in
   let names = ref [new_princ_name] in
   let hook =
@@ -331,13 +342,17 @@ let generate_functional_principle (evd: Evd.evar_map ref)
     then
       (*     let id_of_f = Label.to_id (con_label f) in *)
       let register_with_sort fam_sort =
-	let evd' = Evd.from_env (Global.env ()) in
-	let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in
-	let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
-	let evd',value = change_property_sort evd' s new_principle_type new_princ_name in
-	let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in
-	(* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
-	let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in
+        let evd' = Evd.from_env (Global.env ()) in
+        let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in
+        let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
+        let evd',value = change_property_sort evd' s new_principle_type new_princ_name in
+        let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in
+        (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
+        let univs =
+          let poly = Flags.is_universe_polymorphism () in
+          Evd.const_univ_entry ~poly evd'
+        in
+        let ce = Declare.definition_entry ~univs value in
 	ignore(
 	  Declare.declare_constant
 	    name
@@ -362,12 +377,12 @@ let generate_functional_principle (evd: Evd.evar_map ref)
     begin
       begin
 	try
-	  let id = Pfedit.get_current_proof_name () in
+	  let id = Proof_global.get_current_proof_name () in
 	  let s = Id.to_string id in
 	  let n = String.length "___________princ_________" in
 	  if String.length s >= n
 	  then if String.equal (String.sub s 0 n) "___________princ_________"
-	  then Pfedit.delete_current_proof ()
+	  then Proof_global.discard_current ()
 	  else ()
 	  else ()
 	with e when CErrors.noncritical e -> ()
@@ -380,17 +395,17 @@ let generate_functional_principle (evd: Evd.evar_map ref)
 exception Not_Rec
 
 let get_funs_constant mp dp =
-  let get_funs_constant const e : (Names.constant*int) array =
-    match kind_of_term ((strip_lam e)) with
+  let get_funs_constant const e : (Names.Constant.t*int) array =
+    match Constr.kind ((strip_lam e)) with
       | Fix((_,(na,_,_))) ->
 	  Array.mapi
 	    (fun i na ->
 	       match na with
 		 | Name id ->
-		     let const = make_con mp dp (Label.of_id id) in
+		     let const = Constant.make3 mp dp (Label.of_id id) in
 		     const,i
 		 | Anonymous ->
-		     anomaly (Pp.str "Anonymous fix")
+		     anomaly (Pp.str "Anonymous fix.")
 	    )
 	    na
       | _ -> [|const,0|]
@@ -398,15 +413,16 @@ let get_funs_constant mp dp =
   function const ->
     let find_constant_body const =
       match Global.body_of_constant const with
-	| Some body ->
+	| Some (body, _) ->
 	    let body = Tacred.cbv_norm_flags
 	      (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
 	      (Global.env ())
 	      (Evd.from_env (Global.env ()))
-	      body
+	      (EConstr.of_constr body)
 	    in
+	    let body = EConstr.Unsafe.to_constr body in
 	    body
-	| None -> error ( "Cannot define a principle over an axiom ")
+	| None -> user_err Pp.(str ( "Cannot define a principle over an axiom "))
     in
     let f = find_constant_body const in
     let l_const = get_funs_constant const f in
@@ -421,8 +437,8 @@ let get_funs_constant mp dp =
       let first_params = List.hd l_params  in
       List.iter
 	(fun params ->
-	   if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params)
-	   then error "Not a mutal recursive block"
+	   if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && Constr.equal c1 c2) first_params params)
+	   then user_err Pp.(str "Not a mutal recursive block")
 	)
 	l_params
     in
@@ -430,21 +446,21 @@ let get_funs_constant mp dp =
     let _check_bodies =
       try
 	let extract_info is_first body =
-	  match kind_of_term body with
+	  match Constr.kind body with
 	    | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
 	    | _ ->
 		if is_first && Int.equal (List.length l_bodies) 1
 		then raise Not_Rec
-		else error "Not a mutal recursive block"
+		else user_err Pp.(str "Not a mutal recursive block")
 	in
 	let first_infos = extract_info true (List.hd l_bodies) in
 	let check body  = (* Hope this is correct *)
 	  let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) =
             Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 &&
-            Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2
+            Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2
 	  in
 	  if not (eq_infos first_infos (extract_info false body))
-	  then  error "Not a mutal recursive block"
+	  then  user_err Pp.(str "Not a mutal recursive block")
 	in
 	List.iter check l_bodies
       with Not_Rec -> ()
@@ -454,7 +470,7 @@ let get_funs_constant mp dp =
 exception No_graph_found
 exception Found_type of int
 
-let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list =
+let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_constants definition_entry list =
   let env = Global.env () in
   let funs = List.map fst fas in
   let first_fun = List.hd funs in
@@ -486,12 +502,12 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
   in
   let _ = evd := sigma in 
   let l_schemes =
-    List.map (Typing.unsafe_type_of env sigma) schemes
+    List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes
   in
   let i = ref (-1) in
   let sorts =
     List.rev_map (fun (_,x) ->
-		  Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x)
+		  Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd x
 	     )
       fas
   in
@@ -514,12 +530,12 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
        begin
 	 begin
 	   try
-	     let id = Pfedit.get_current_proof_name () in
+	     let id = Proof_global.get_current_proof_name () in
 	     let s = Id.to_string id in
 	     let n = String.length "___________princ_________" in
 	     if String.length s >= n
 	     then if String.equal (String.sub s 0 n) "___________princ_________"
-		  then Pfedit.delete_current_proof ()
+		  then Proof_global.discard_current ()
 		  else ()
 	     else ()
 	   with e when CErrors.noncritical e -> ()
@@ -555,7 +571,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
       List.map (* we can now compute the other principles *)
 	(fun scheme_type ->
 	   incr i;
-	   observe (Printer.pr_lconstr scheme_type);
+           observe (Printer.pr_lconstr_env env sigma scheme_type);
 	   let type_concl = (strip_prod_assum scheme_type) in
 	   let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in
 	   let f = fst (decompose_app applied_f) in
@@ -565,10 +581,10 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
 		let t =  (strip_prod_assum t) in
 		let applied_g = List.hd (List.rev (snd (decompose_app t))) in
 		let g = fst (decompose_app applied_g) in
-		if eq_constr f g
+		if Constr.equal f g
 		then raise (Found_type j);
-		observe (Printer.pr_lconstr f ++ str " <> " ++
-			   Printer.pr_lconstr g)
+                observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++
+                         Printer.pr_lconstr_env env sigma g)
 
 	     )
 	     ta;
@@ -609,19 +625,22 @@ let build_scheme fas =
 	      try
 		Smartlocate.global_with_alias f
 	      with Not_found ->
-                errorlabstrm "FunInd.build_scheme"
+                user_err ~hdr:"FunInd.build_scheme"
                   (str "Cannot find " ++ Libnames.pr_reference f)
 	    in
-	    let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in
+            let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in
             let _ = evd := evd' in 
-	    let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd f in 
-	    (destConst f,sort)
+	    let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in 
+            if isConst f
+            then (destConst f,sort)
+            else user_err Pp.(pr_constr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function")
 	 )
 	 fas
 		   ) in
   let bodies_types =
     make_scheme evd pconstants      
   in
+
   List.iter2
     (fun (princ_id,_,_) def_entry ->
        ignore
@@ -641,12 +660,12 @@ let build_case_scheme fa =
 (*   in  *)
   let funs =
     let (_,f,_) = fa in
-    try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f))
+    try fst (Global.constr_of_global_in_context (Global.env ()) (Smartlocate.global_with_alias f))
     with Not_found ->
-      errorlabstrm "FunInd.build_case_scheme"
+      user_err ~hdr:"FunInd.build_case_scheme"
         (str "Cannot find " ++ Libnames.pr_reference f) in
   let first_fun,u = destConst  funs in
-  let funs_mp,funs_dp,_ = Names.repr_con first_fun in
+  let funs_mp,funs_dp,_ = Constant.repr3 first_fun in
   let first_fun_kn = try fst (find_Function_infos  first_fun).graph_ind with Not_found -> raise No_graph_found in
   let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
   let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in
@@ -659,15 +678,13 @@ let build_case_scheme fa =
 	 let ind = first_fun_kn,funs_indexes in
 	   (ind,Univ.Instance.empty)(*FIXME*),prop_sort
   in
-  let sigma = Sigma.Unsafe.of_evar_map sigma in
-  let Sigma (scheme, sigma, _) = 
+  let (sigma, scheme) = 
       Indrec.build_case_analysis_scheme_default env sigma ind sf
   in
-  let sigma = Sigma.to_evar_map sigma in
-  let scheme_type =  (Typing.unsafe_type_of env sigma ) scheme in
+  let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in
   let sorts =
     (fun (_,_,x) ->
-       Universes.new_sort_in_family (Pretyping.interp_elimination_sort x)
+       Universes.new_sort_in_family x
     )
       fa
   in
diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
index 3fa2644c..33aeafef 100644
--- a/plugins/funind/functional_principles_types.mli
+++ b/plugins/funind/functional_principles_types.mli
@@ -1,14 +1,15 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
 open Names
-open Term
-open Misctypes
+open Constr
 
 val generate_functional_principle :
   Evd.evar_map ref -> 
@@ -17,7 +18,7 @@ val generate_functional_principle :
   (* induction principle on rel *)
   types ->
   (* *)
-  sorts array option ->
+  Sorts.t array option ->
   (* Name of the new principle *)
   (Id.t) option ->
   (* the compute functions to use   *)
@@ -27,18 +28,13 @@ val generate_functional_principle :
   (* The tactic to use to make the proof w.r
      the number of params
   *)
-  (constr array -> int -> Tacmach.tactic) ->
+  (EConstr.constr array -> int -> Tacmach.tactic) ->
   unit
 
-val compute_new_princ_type_from_rel : constr array -> sorts array ->
-  types -> types
-
-
 exception No_graph_found
 
 val make_scheme :   Evd.evar_map ref ->
- (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list
-
-val build_scheme : (Id.t*Libnames.reference*glob_sort) list ->  unit
-val build_case_scheme : (Id.t*Libnames.reference*glob_sort)  ->  unit
+ (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list
 
+val build_scheme : (Id.t*Libnames.reference*Sorts.family) list ->  unit
+val build_case_scheme : (Id.t*Libnames.reference*Sorts.family)  ->  unit
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 42e49031..90af20b4 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -1,47 +1,32 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-open Compat
+open Ltac_plugin
 open Util
-open Term
 open Pp
 open Constrexpr
 open Indfun_common
 open Indfun
 open Genarg
-open Constrarg
+open Stdarg
 open Misctypes
+open Pcoq
 open Pcoq.Prim
 open Pcoq.Constr
-open Pcoq.Tactic
+open Pltac
 
 DECLARE PLUGIN "recdef_plugin"
 
-let pr_binding prc = function
-  | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
-  | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
-
-let pr_bindings prc prlc = function
-  | ImplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-      pr_sequence prc l
-  | ExplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-        pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | NoBindings -> mt ()
-
-let pr_with_bindings prc prlc (c,bl) =
-  prc c ++ hv 0 (pr_bindings prc prlc bl)
-
 let pr_fun_ind_using  prc prlc _ opt_c =
   match opt_c with
     | None -> mt ()
-    | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b)
+    | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b)
 
 (* Duplication of printing functions because "'a with_bindings" is
    (internally) not uniform in 'a: indeed constr_with_bindings at the
@@ -49,16 +34,12 @@ let pr_fun_ind_using  prc prlc _ opt_c =
    "constr with_bindings"; hence, its printer cannot be polymorphic in
    (prc,prlc)... *)
 
-let pr_with_bindings_typed prc prlc (c,bl) =
-  prc c ++
-  hv 0 (pr_bindings prc prlc bl)
-
 let pr_fun_ind_using_typed prc prlc _ opt_c =
   match opt_c with
     | None -> mt ()
     | Some b ->
-      let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in
-      spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b)
+      let (_, b) = b (Global.env ()) Evd.empty in
+      spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b)
 
 
 ARGUMENT EXTEND fun_ind_using
@@ -80,7 +61,6 @@ TACTIC EXTEND newfuninv
      ]
 END
 
-
 let pr_intro_as_pat _prc _ _ pat =
   match pat with
     | Some pat ->
@@ -88,16 +68,17 @@ let pr_intro_as_pat _prc _ _ pat =
         str"<simple_intropattern>"
     | None -> mt ()
 
-let out_disjunctive = function
-  | loc, IntroAction (IntroOrAndPattern l) -> (loc,l)
-  | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected."
+let out_disjunctive = CAst.map (function
+  | IntroAction (IntroOrAndPattern l) -> l
+  | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected."))
 
 ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat
 |   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ]
 | []  ->[ None ]
 END
 
-
+let functional_induction b c x pat =
+  Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))
 
 
 TACTIC EXTEND newfunind
@@ -106,9 +87,9 @@ TACTIC EXTEND newfunind
        let c = match cl with
 	 | [] -> assert false
 	 | [c] -> c
-	 | c::cl -> applist(c,cl)
+	 | c::cl -> EConstr.applist(c,cl)
        in
-       Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ]
+       Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ]
 END
 (***** debug only ***)
 TACTIC EXTEND snewfunind
@@ -117,9 +98,9 @@ TACTIC EXTEND snewfunind
        let c = match cl with
 	 | [] -> assert false
 	 | [c] -> c
-	 | c::cl -> applist(c,cl)
+	 | c::cl -> EConstr.applist(c,cl)
        in
-       Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ]
+       Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ]
 END
 
 
@@ -143,7 +124,7 @@ END
 
 module Gram = Pcoq.Gram
 module Vernac = Pcoq.Vernac_
-module Tactic = Pcoq.Tactic
+module Tactic = Pltac
 
 type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located
 
@@ -157,15 +138,14 @@ GEXTEND Gram
   GLOBAL: function_rec_definition_loc ;
 
   function_rec_definition_loc:
-    [ [ g = Vernac.rec_definition -> !@loc, g ]]
+    [ [ g = Vernac.rec_definition -> Loc.tag ~loc:!@loc g ]]
     ;
 
 END
 
 let () =
   let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in
-  let printer _ _ _ _ = str "<Unavailable printer for rec_definition>" in
-  Pptactic.declare_extra_genarg_pprule wit_function_rec_definition_loc raw_printer printer printer
+  Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer
 
 (* TASSI: n'importe quoi ! *)
 VERNAC COMMAND EXTEND Function
@@ -175,7 +155,7 @@ VERNAC COMMAND EXTEND Function
            | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in
          match
            Vernac_classifier.classify_vernac
-             (Vernacexpr.VernacFixpoint(None, List.map snd recsl))
+             (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl))))
          with
          | Vernacexpr.VtSideff ids, _ when hard ->
              Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater)
@@ -184,13 +164,13 @@ VERNAC COMMAND EXTEND Function
 END
 
 let pr_fun_scheme_arg (princ_name,fun_name,s) =
-  Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++
+  Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++
   Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++
-  Ppconstr.pr_glob_sort s
+  Termops.pr_sort_family s
 
 VERNAC ARGUMENT EXTEND fun_scheme_arg
 PRINTED BY pr_fun_scheme_arg
-| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
+| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> [ (princ_name,fun_name,s) ]
 END
 
 
@@ -227,7 +207,7 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
 		  ;
 		    try Functional_principles_types.build_scheme fas
 		    with Functional_principles_types.No_graph_found ->
-		      CErrors.error ("Cannot generate induction principle(s)")
+		      CErrors.user_err Pp.(str "Cannot generate induction principle(s)")
 		      | e when CErrors.noncritical e ->
 			  let names = List.map (fun (_,na,_) -> na) fas in
 			  warning_error names e
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index 52179ae5..04006453 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -1,7 +1,7 @@
 open Printer
 open Pp
 open Names
-open Term
+open Constr
 open Vars
 open Glob_term
 open Glob_ops
@@ -12,6 +12,9 @@ open Util
 open Glob_termops
 open Misctypes
 
+module RelDecl = Context.Rel.Declaration
+module NamedDecl = Context.Named.Declaration
+
 let observe strm =
   if do_observe ()
   then Feedback.msg_debug strm
@@ -29,6 +32,14 @@ type binder_type =
 
 type glob_context = (binder_type*glob_constr) list
 
+
+let rec solve_trivial_holes pat_as_term e =
+  match DAst.get pat_as_term, DAst.get e with
+  | GHole _,_ -> e
+  | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe ->
+       DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse))
+  | _,_ -> pat_as_term
+                                              
 (*
    compose_glob_context [(bt_1,n_1,t_1);......] rt returns
    b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the
@@ -39,7 +50,7 @@ let compose_glob_context =
     match bt with
       | Lambda n -> mkGLambda(n,t,acc)
       | Prod n -> mkGProd(n,t,acc)
-      | LetIn n -> mkGLetIn(n,t,acc)
+      | LetIn n -> mkGLetIn(n,t,None,acc)
   in
   List.fold_right compose_binder
 
@@ -109,13 +120,13 @@ let combine_args arg args =
 
 
 let ids_of_binder =  function
-  | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
-  | LetIn (Name id)  | Prod (Name id) | Lambda (Name id) -> [id]
+  | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty
+  | LetIn (Name id)  | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id
 
 let rec change_vars_in_binder mapping = function
     [] -> []
   | (bt,t)::l ->
-      let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in
+      let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in
       (bt,change_vars mapping t)::
 	(if Id.Map.is_empty new_mapping
 	 then l
@@ -126,27 +137,27 @@ let rec replace_var_by_term_in_binder x_id term = function
   | [] -> []
   | (bt,t)::l ->
       (bt,replace_var_by_term x_id term t)::
-	if Id.List.mem x_id (ids_of_binder bt)
+	if Id.Set.mem x_id (ids_of_binder bt)
 	then l
 	else replace_var_by_term_in_binder x_id term l
 
-let add_bt_names bt = List.append (ids_of_binder bt)
+let add_bt_names bt = Id.Set.union (ids_of_binder bt)
 
 let apply_args ctxt body args =
   let need_convert_id avoid id =
-    List.exists (is_free_in id) args || Id.List.mem id avoid
+    List.exists (is_free_in id) args || Id.Set.mem id avoid
   in
   let need_convert avoid  bt =
-    List.exists (need_convert_id avoid) (ids_of_binder bt)
+    Id.Set.exists (need_convert_id avoid) (ids_of_binder bt)
   in
-  let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) =
+  let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) =
     match na with
-       | Name id when Id.List.mem id avoid ->
+       | Name id when Id.Set.mem id avoid ->
 	   let new_id = Namegen.next_ident_away id avoid in
-	   Name new_id,Id.Map.add id new_id mapping,new_id::avoid
+	   Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid
        | _ -> na,mapping,avoid
   in
-  let next_bt_away bt (avoid:Id.t list) =
+  let next_bt_away bt (avoid:Id.Set.t) =
     match bt with
       | LetIn na ->
 	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
@@ -171,15 +182,15 @@ let apply_args ctxt body args =
 	  let new_avoid,new_ctxt',new_body,new_id =
 	    if need_convert_id avoid id
 	    then
-	      let new_avoid =  id::avoid in
+	      let new_avoid =  Id.Set.add id avoid in
 	      let new_id = Namegen.next_ident_away id new_avoid in
-	      let new_avoid' = new_id :: new_avoid in
+	      let new_avoid' = Id.Set.add new_id new_avoid in
 	      let mapping = Id.Map.add id new_id Id.Map.empty in
 	      let new_ctxt' = change_vars_in_binder mapping ctxt' in
 	      let new_body = change_vars mapping body in
 	      new_avoid',new_ctxt',new_body,new_id
 	    else
-	      id::avoid,ctxt',body,id
+	      Id.Set.add id avoid,ctxt',body,id
 	  in
 	  let new_body = replace_var_by_term new_id arg new_body in
 	  let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in
@@ -203,7 +214,7 @@ let apply_args ctxt body args =
 	  in
 	  (new_bt,t)::new_ctxt',new_body
   in
-  do_apply []  ctxt body args
+  do_apply Id.Set.empty ctxt body args
 
 
 let combine_app f args =
@@ -223,7 +234,12 @@ let combine_lam n t b =
 		      compose_glob_context b.context b.value )
   }
 
-
+let combine_prod2 n t b =
+  {
+    context = [];
+    value = mkGProd(n, compose_glob_context t.context t.value,
+		      compose_glob_context b.context b.value )
+  }
 
 let combine_prod n t b =
   { context = t.context@((Prod n,t.value)::b.context); value = b.value}
@@ -245,10 +261,10 @@ let mk_result ctxt value avoid =
 **************************************************)
 
 let coq_True_ref =
-  lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "True")
+  lazy  (Coqlib.coq_reference "" ["Init";"Logic"] "True")
 
 let coq_False_ref =
-  lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "False")
+  lazy  (Coqlib.coq_reference "" ["Init";"Logic"] "False")
 
 (*
   [make_discr_match_el \[e1,...en\]] builds match e1,...,en with
@@ -271,10 +287,10 @@ let make_discr_match_el  =
 *)
 let make_discr_match_brl i =
   List.map_i
-    (fun j (_,idl,patl,_) ->
+    (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@
        if Int.equal j i
-       then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref))
-       else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref))
+       then (idl,patl, mkGRef (Lazy.force coq_True_ref))
+       else (idl,patl, mkGRef (Lazy.force coq_False_ref))
     )
     0
 (*
@@ -333,27 +349,28 @@ let raw_push_named (na,raw_value,raw_typ) env =
   match na with
     | Anonymous -> env
     | Name id ->
-	let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in
-	let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in
-        let open Context.Named.Declaration in
-	Environ.push_named (of_tuple (id,value,typ)) env
+        let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in
+        (match raw_value with
+        | None ->
+           EConstr.push_named (NamedDecl.LocalAssum (id,typ)) env
+        | Some value ->
+           EConstr.push_named (NamedDecl.LocalDef (id, value, typ)) env)
 
 
 let add_pat_variables pat typ env : Environ.env =
   let rec add_pat_variables env pat typ  : Environ.env =
-    let open Context.Rel.Declaration in
     observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env));
 
-    match pat with
-      | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env
-      | PatCstr(_,c,patl,na) ->
+    match DAst.get pat with
+      | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env
+      | PatCstr(c,patl,na) ->
 	  let Inductiveops.IndType(indf,indargs) =
-	    try Inductiveops.find_rectype env (Evd.from_env env) typ
+	    try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ)
 	    with Not_found -> assert false
 	  in
 	  let constructors = Inductiveops.get_constructors env indf in
 	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in
-	  let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in
+	  let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in
 	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
   in
   let new_env = add_pat_variables  env pat typ in
@@ -361,21 +378,30 @@ let add_pat_variables pat typ env : Environ.env =
     fst (
       Context.Rel.fold_outside
 	(fun decl (env,ctxt) ->
-         let _,v,t = Context.Rel.Declaration.to_tuple decl in
-	 match Context.Rel.Declaration.get_name decl with
-	   | Anonymous -> assert false
-	   | Name id ->
-	       let new_t =  substl ctxt t in
-	       let new_v = Option.map (substl ctxt) v in
-	       observe (str "for variable " ++ Ppconstr.pr_id id ++  fnl () ++
-			  str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++
-			  str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++
-			  Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
-			  Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
-		       );
-               let open Context.Named.Declaration in
-	       (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt)
-      )
+           let open Context.Rel.Declaration in
+           let sigma, _ = Pfedit.get_current_context () in
+           match decl with
+	   | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false
+	   | LocalAssum (Name id, t) ->
+             let new_t =  substl ctxt t in
+             observe (str "for variable " ++ Ppconstr.pr_id id ++  fnl () ++
+                      str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++
+                      str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl ()
+                     );
+             let open Context.Named.Declaration in
+             (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt)
+           | LocalDef (Name id, v, t) ->
+             let new_t =  substl ctxt t in
+             let new_v = substl ctxt v in
+             observe (str "for variable " ++ Ppconstr.pr_id id ++  fnl () ++
+                      str "old type := "  ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++
+                      str "new type := "  ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++
+                      str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++
+                      str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl ()
+                     );
+             let open Context.Named.Declaration in
+             (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt)
+        )
 	(Environ.rel_context new_env)
 	~init:(env,[])
     )
@@ -386,31 +412,30 @@ let add_pat_variables pat typ env : Environ.env =
 
 
 
-let rec pattern_to_term_and_type env typ  = function
-  | PatVar(loc,Anonymous) -> assert false
-  | PatVar(loc,Name id) ->
+let rec pattern_to_term_and_type env typ  = DAst.with_val (function
+  | PatVar Anonymous -> assert false
+  | PatVar (Name id) ->
 	mkGVar id
-  | PatCstr(loc,constr,patternl,_) ->
+  | PatCstr(constr,patternl,_) ->
       let cst_narg =
 	Inductiveops.constructor_nallargs_env
 	  (Global.env ())
 	  constr
       in
       let Inductiveops.IndType(indf,indargs) =
-	try Inductiveops.find_rectype env (Evd.from_env env) typ
+	try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ)
 	with Not_found -> assert false
       in
       let constructors = Inductiveops.get_constructors env indf in
       let constructor  = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in
-      let open Context.Rel.Declaration in
-      let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in
+      let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in
       let _,cstl = Inductiveops.dest_ind_family indf in
       let csta = Array.of_list cstl in
       let implicit_args =
 	Array.to_list
 	  (Array.init
 	     (cst_narg - List.length patternl)
-	     (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i))
+	     (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i)))
 	  )
       in
       let patl_as_term =
@@ -419,6 +444,7 @@ let rec pattern_to_term_and_type env typ  = function
       mkGApp(mkGRef(ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
+  )
 
 (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return)
    of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the
@@ -452,13 +478,14 @@ let rec pattern_to_term_and_type env typ  = function
 *)
 
 
-let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
-  observe (str " Entering : " ++ Printer.pr_glob_constr rt);
-  match rt with
-    | GRef _ | GVar _ | GEvar _ | GPatVar _     | GSort _  | GHole _  ->
+let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return =
+  observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt);
+  let open CAst in
+  match DAst.get rt with
+    | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _  | GHole _ ->
 	(* do nothing (except changing type of course) *)
 	mk_result [] rt avoid
-    | GApp(_,_,_) ->
+    | GApp(_,_) ->
 	let f,args = glob_decompose_app rt in
 	let args_res : (glob_constr list) build_entry_return =
 	  List.fold_right (* create the arguments lists of constructors and combine them *)
@@ -470,20 +497,20 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	    (mk_result [] [] avoid)
 	in
 	begin
-	  match f with
+	  match DAst.get f with
 	    | GLambda _  -> 
 		let rec aux t l = 
 		  match l with 
 		    | [] -> t
-		    | u::l -> 
-			match t with 
-			  | GLambda(loc,na,_,nat,b) -> 
-			      GLetIn(Loc.ghost,na,u,aux b l)
+		    | u::l -> DAst.make @@
+			match DAst.get t with 
+			  | GLambda(na,_,nat,b) -> 
+			      GLetIn(na,u,None,aux b l)
 			  | _ -> 
-			      GApp(Loc.ghost,t,l)
+			      GApp(t,l)
 		in
 		build_entry_lc env funnames avoid (aux f args)
-	    | GVar(_,id) when Id.Set.mem id funnames ->
+	    | GVar id when Id.Set.mem id funnames ->
 		(* if we have [f t1 ... tn] with [f]$\in$[fnames]
 		   then we create a fresh variable [res],
 		   add [res] and its "value" (i.e. [res v1 ... vn]) to each
@@ -492,8 +519,8 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		   The "value" of this branch is then simply [res]
 		*)
 		let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in
-		let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in
-		let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in
+                let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in
+		let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in
 		let res = fresh_id args_res.to_avoid "_res" in
 		let new_avoid = res::args_res.to_avoid in
 		let res_rt = mkGVar res in
@@ -524,7 +551,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		      args_res.result
 		}
 	    | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *)
-       	    | GLetIn(_,n,t,b) ->
+	    | GLetIn(n,v,t,b) ->
 		(* if we have [(let x := v in b) t1 ... tn] ,
 		   we discard our work and compute the list of constructor for
 		   [let x = v in (b t1 ... tn)] up to alpha conversion
@@ -533,12 +560,12 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		  match n with
 		    | Name id when List.exists (is_free_in id) args ->
 			(* need to alpha-convert the name *)
-			let new_id = Namegen.next_ident_away id avoid in
+			let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in
 			let new_avoid = id:: avoid in
 			let new_b =
 			  replace_var_by_term
 			    id
-			    (GVar(Loc.ghost,id))
+			    (DAst.make @@ GVar id)
 			    b
 			in
 			(Name new_id,new_b,new_avoid)
@@ -548,7 +575,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		  env
 		  funnames
 		  avoid
-		  (mkGLetIn(new_n,t,mkGApp(new_b,args)))
+		  (mkGLetIn(new_n,v,t,mkGApp(new_b,args)))
 	    | GCases _  | GIf _ | GLetTuple _ ->
 		(* we have [(match e1, ...., en with ..... end) t1 tn]
 		   we first compute the result from the case and
@@ -556,18 +583,18 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		*)
 		let f_res = build_entry_lc env funnames args_res.to_avoid f in
 		combine_results combine_app f_res  args_res
-	    | GCast(_,b,_) ->
+	    | GCast(b,_) ->
 		(* for an applied cast we just trash the cast part
 		   and restart the work.
 
 		   WARNING: We need to restart since [b] itself should be an application term
 		*)
 		build_entry_lc env funnames avoid (mkGApp(b,args))
-	    | GRec _ -> error "Not handled GRec"
-	    | GProd _ -> error "Cannot apply a type"
+	    | GRec _ -> user_err Pp.(str "Not handled GRec")
+	    | GProd _ -> user_err Pp.(str "Cannot apply a type")
 	end (* end of the application treatement *)
 
-    | GLambda(_,n,_,t,b) ->
+    | GLambda(n,_,t,b) ->
 	(* we first compute the list of constructor
 	   corresponding to the body of the function,
 	   then the one corresponding to the type
@@ -582,7 +609,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	let new_env = raw_push_named (new_n,None,t) env in
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_lam new_n) t_res b_res
-    | GProd(_,n,_,t,b) ->
+    | GProd(n,_,t,b) ->
 	(* we first compute the list of constructor
 	   corresponding to the body of the function,
 	   then the one corresponding to the type
@@ -591,45 +618,47 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	let t_res = build_entry_lc env funnames avoid t in
 	let new_env = raw_push_named (n,None,t) env in
 	let b_res = build_entry_lc new_env funnames avoid b in
-	combine_results (combine_prod n) t_res b_res
-    | GLetIn(_,n,v,b) ->
+        if List.length t_res.result = 1 && List.length b_res.result = 1
+        then combine_results (combine_prod2 n) t_res b_res
+        else combine_results (combine_prod n) t_res b_res
+    | GLetIn(n,v,typ,b) ->
 	(* we first compute the list of constructor
 	   corresponding to the body of the function,
 	   then the one corresponding to the value [t]
 	   and combine the two result
 	*)
+        let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in
 	let v_res = build_entry_lc env funnames avoid v in
 	let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in
-	let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in
+        let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in
 	let new_env =
-          let open Context.Named.Declaration in
 	  match n with
 	      Anonymous -> env
-	    | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env
+            | Name id -> EConstr.push_named (NamedDecl.LocalDef (id,v_as_constr,v_type)) env
 	in
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_letin n) v_res b_res
-    | GCases(_,_,_,el,brl) ->
+    | GCases(_,_,el,brl) ->
 	(* we create the discrimination function
 	   and treat the case itself
 	*)
 	let make_discr = make_discr_match brl in
 	build_entry_lc_from_case env funnames make_discr el brl avoid
-    | GIf(_,b,(na,e_option),lhs,rhs) ->
+    | GIf(b,(na,e_option),lhs,rhs) ->
 	let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in
-	let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in
+        let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in
 	let (ind,_) =
 	  try Inductiveops.find_inductive env (Evd.from_env env) b_typ
 	  with Not_found ->
-	    errorlabstrm "" (str "Cannot find the inductive associated to " ++
-			       Printer.pr_glob_constr b ++ str " in " ++
-			       Printer.pr_glob_constr rt ++ str ". try again with a cast")
+	    user_err  (str "Cannot find the inductive associated to " ++
+                               Printer.pr_glob_constr_env env b ++ str " in " ++
+                               Printer.pr_glob_constr_env env rt ++ str ". try again with a cast")
 	in
 	let case_pats = build_constructors_of_type (fst ind) [] in
 	assert (Int.equal (Array.length case_pats) 2);
 	let brl =
 	  List.map_i
-	    (fun i x -> (Loc.ghost,[],[case_pats.(i)],x))
+            (fun i x -> CAst.make ([],[case_pats.(i)],x))
 	    0
 	    [lhs;rhs]
 	in
@@ -638,7 +667,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	in
 	(* 		Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *)
 	build_entry_lc env funnames avoid match_expr
-    | GLetTuple(_,nal,_,b,e) ->
+    | GLetTuple(nal,_,b,e) ->
 	begin
 	  let nal_as_glob_constr =
 	    List.map
@@ -649,25 +678,23 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	      nal
 	  in
 	  let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in
-	  let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in
+          let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in
 	  let (ind,_) =
 	    try Inductiveops.find_inductive env (Evd.from_env env) b_typ
 	    with Not_found ->
-	      errorlabstrm "" (str "Cannot find the inductive associated to " ++
-				 Printer.pr_glob_constr b ++ str " in " ++
-				 Printer.pr_glob_constr rt ++ str ". try again with a cast")
+	      user_err  (str "Cannot find the inductive associated to " ++
+                                 Printer.pr_glob_constr_env env b ++ str " in " ++
+                                 Printer.pr_glob_constr_env env rt ++ str ". try again with a cast")
 	  in
 	  let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in
 	  assert (Int.equal (Array.length case_pats) 1);
-	  let br =
-	    (Loc.ghost,[],[case_pats.(0)],e)
-	  in
+          let br = CAst.make ([],[case_pats.(0)],e) in
 	  let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in
 	  build_entry_lc env funnames avoid match_expr
 
 	end
-    | GRec _ -> error "Not handled GRec"
-    | GCast(_,b,_) ->
+    | GRec _ -> user_err Pp.(str "Not handled GRec")
+    | GCast(b,_) ->
 	build_entry_lc env funnames  avoid b
 and build_entry_lc_from_case env funname make_discr
     (el:tomatch_tuples)
@@ -696,7 +723,7 @@ and build_entry_lc_from_case env funname make_discr
 	let types =
 	  List.map (fun (case_arg,_) ->
 		      let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in
-		      Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr
+                      EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr)
 		   ) el
 	in
 	(****** The next works only if the match is not dependent ****)
@@ -727,7 +754,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
     | [] -> (* computed_branches  *) {result = [];to_avoid = avoid}
     | br::brl' ->
 	(* alpha conversion to prevent name clashes *)
-	let _,idl,patl,return = alpha_br avoid br in
+        let {CAst.v=(idl,patl,return)} = alpha_br avoid br in
 	let new_avoid  = idl@avoid in 	(* for now we can no more use idl as an identifier *)
 	(* building a list of precondition stating that we are not in this branch
 	   (will be used in the following recursive calls)
@@ -743,10 +770,10 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 		   List.fold_right
 		     (fun id acc ->
 			let typ_of_id =
-			  Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id)
+			  Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id)
 			in
 			let raw_typ_of_id =
-			  Detyping.detype false []
+			  Detyping.detype Detyping.Now false Id.Set.empty
 			    env_with_pat_ids (Evd.from_env env) typ_of_id
 			in
 			mkGProd (Name id,raw_typ_of_id,acc))
@@ -791,15 +818,22 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	      List.map3
 	      (fun pat e typ_as_constr ->
 		 let this_pat_ids = ids_of_pat pat in
-		 let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in
+		 let typ_as_constr = EConstr.of_constr typ_as_constr in
+		 let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in
 		 let pat_as_term = pattern_to_term pat in
+                 (* removing trivial holes *) 
+                 let pat_as_term = solve_trivial_holes pat_as_term e in 
+                  (* observe (str "those_pattern_preconds" ++ spc () ++ *)
+                  (*            str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *)
+                  (*            str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *)
+                  (*            str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *)
 		 List.fold_right
 		   (fun id  acc ->
 		      if Id.Set.mem id this_pat_ids
 		      then (Prod (Name id),
-		      let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in
+		      let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in
 		      let raw_typ_of_id =
-			Detyping.detype false [] new_env (Evd.from_env env) typ_of_id
+			Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id
 		      in
 		      raw_typ_of_id
 			   )::acc
@@ -841,37 +875,45 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	{ brl'_res with result = this_branch_res@brl'_res.result }
 
 
-let is_res id =
-  try
+let is_res r = match DAst.get r with
+| GVar id ->
+  begin try
     String.equal (String.sub (Id.to_string id) 0 4) "_res"
-  with Invalid_argument _ -> false
+  with Invalid_argument _ -> false end
+| _ -> false
 
+let is_gr c gr = match DAst.get c with
+| GRef (r, _) -> Globnames.eq_gr r gr
+| _ -> false
 
+let is_gvar c = match DAst.get c with
+| GVar id -> true
+| _ -> false
 
 let same_raw_term rt1 rt2 = 
-  match rt1,rt2 with 
-    | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2
+  match DAst.get rt1, DAst.get rt2 with 
+    | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2
     | GHole _, GHole _ -> true
     | _ -> false
 let decompose_raw_eq lhs rhs = 
-  let rec decompose_raw_eq lhs rhs acc = 
-    observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs);
-    let (rhd,lrhs) = glob_decompose_app rhs in 
-    let (lhd,llhs) = glob_decompose_app lhs in 
-    observe (str "lhd := " ++ pr_glob_constr lhd);
-    observe (str "rhd := " ++ pr_glob_constr rhd);
+  let _, env = Pfedit.get_current_context () in
+  let rec decompose_raw_eq lhs rhs acc =
+    observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs);
+    let (rhd,lrhs) = glob_decompose_app rhs in
+    let (lhd,llhs) = glob_decompose_app lhs in
+    observe (str "lhd := " ++ pr_glob_constr_env env lhd);
+    observe (str "rhd := " ++ pr_glob_constr_env env rhd);
     observe (str "llhs := " ++ int (List.length llhs));
     observe (str "lrhs := " ++ int (List.length lrhs));
-    let sllhs = List.length llhs in 
-    let slrhs = List.length lrhs in 
-    if same_raw_term lhd rhd && Int.equal sllhs slrhs 
+    let sllhs = List.length llhs in
+    let slrhs = List.length lrhs in
+    if same_raw_term lhd rhd && Int.equal sllhs slrhs
     then
       (* let _ = assert false in  *)
       List.fold_right2 decompose_raw_eq	llhs lrhs acc
     else (lhs,rhs)::acc
   in
   decompose_raw_eq lhs rhs []
-     
 
 exception Continue
 (*
@@ -880,28 +922,30 @@ exception Continue
    eliminates some meaningless equalities, applies some rewrites......
 *)
 let rec rebuild_cons env nb_args relname args crossed_types depth rt =
-  observe (str "rebuilding : " ++ pr_glob_constr rt);
+  observe (str "rebuilding : " ++ pr_glob_constr_env env rt);
   let open Context.Rel.Declaration in
-  match rt with
-    | GProd(_,n,k,t,b) ->
+  let open CAst in
+  match DAst.get rt with
+    | GProd(n,k,t,b) ->
 	let not_free_in_t id = not (is_free_in id t) in
 	let new_crossed_types = t::crossed_types in
 	begin
-	  match t with
-	    | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id ->
+	  match DAst.get t with
+	    | GApp(res_rt ,args') when is_res res_rt ->
 		begin
-		  match args' with
-		    | (GVar(_,this_relname))::args' ->
+                  let arg = List.hd args' in
+		  match DAst.get arg with
+		    | GVar this_relname ->
 			(*i The next call to mk_rel_id is
 			  valid since we are constructing the graph
 			  Ensures by: obvious
 			  i*)
 
 			let new_t =
-			  mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt])
+			  mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt])
 			in
 			let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in
-			let new_env = Environ.push_rel (LocalAssum (n,t')) env in
+                        let new_env = EConstr.push_rel (LocalAssum (n,t')) env in
 			let new_b,id_to_exclude =
 			  rebuild_cons new_env
 			    nb_args relname
@@ -913,12 +957,16 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    | _ -> (* the first args is the name of the function! *)
 			assert false
 		end
-	    | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt])
-		when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref)  && n == Anonymous
+	    | GApp(eq_as_ref,[ty; id ;rt])
+		when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref)  && n == Anonymous
 		  ->
+                let loc1 = rt.CAst.loc in
+                let loc2 = eq_as_ref.CAst.loc in
+                let loc3 = id.CAst.loc in
+                let id = match DAst.get id with GVar id -> id | _ -> assert false in
 		begin
 		  try
-		    observe (str "computing new type for eq : " ++ pr_glob_constr rt);
+                    observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt);
 		    let t' =
 		      try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*)
                       with e when CErrors.noncritical e -> raise Continue
@@ -932,7 +980,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    let subst_b =
 		      if is_in_b then b else  replace_var_by_term id rt b
 		    in
-		    let new_env = Environ.push_rel (LocalAssum (n,t')) env in
+                    let new_env = EConstr.push_rel (LocalAssum (n,t')) env in
 		    let new_b,id_to_exclude =
 		      rebuild_cons
 			new_env
@@ -942,51 +990,50 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    in
 		    mkGProd(n,t,new_b),id_to_exclude
 		  with Continue ->
-		    let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in
+		    let jmeq = Globnames.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in
 		    let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in
-		    let ind,args' = Inductive.find_inductive env ty' in
+                    let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in
 		    let mib,_ = Global.lookup_inductive (fst ind) in
 		    let nparam = mib.Declarations.mind_nparams in
 		    let params,arg' =
 		      ((Util.List.chop nparam args'))
 		    in
-		    let rt_typ =
-		       GApp(Loc.ghost,
-			    GRef (Loc.ghost,Globnames.IndRef (fst ind),None),
+		    let rt_typ = DAst.make @@
+		       GApp(DAst.make @@ GRef (Globnames.IndRef (fst ind),None),
 			    (List.map
-			      (fun p -> Detyping.detype false []
+			      (fun p -> Detyping.detype Detyping.Now false Id.Set.empty
 				 env (Evd.from_env env)
-				 p) params)@(Array.to_list
+				 (EConstr.of_constr p)) params)@(Array.to_list
 				      (Array.make
 					 (List.length args' - nparam)
 					 (mkGHole ()))))
 		    in
 		    let eq' =
-		      GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt])
+		      DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt])
 		    in
-		    observe (str "computing new type for jmeq : " ++ pr_glob_constr eq');
+                    observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq');
 		    let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in
 		    observe (str " computing new type for jmeq : done") ;
+                    let sigma = Evd.(from_env env) in
 		    let new_args =
-		      match kind_of_term eq'_as_constr with
+                      match EConstr.kind sigma eq'_as_constr with
 			| App(_,[|_;_;ty;_|]) ->
-			    let ty = Array.to_list (snd (destApp ty)) in
+                            let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in
 			    let ty' = snd (Util.List.chop nparam ty) in
 			    List.fold_left2
 			      (fun acc var_as_constr arg ->
 				 if isRel var_as_constr
 				 then
-                                   let open Context.Rel.Declaration in
-				   let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in
+				   let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in
 				   match na with
 				     | Anonymous -> acc
 				     | Name id' ->
-					 (id',Detyping.detype false []
+					 (id',Detyping.detype Detyping.Now false Id.Set.empty
 					    env
                                             (Evd.from_env env)
 					    arg)::acc
 				 else if isVar var_as_constr
-				 then (destVar var_as_constr,Detyping.detype false []
+				 then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty
 					 env
                                          (Evd.from_env env)
 					 arg)::acc
@@ -1015,7 +1062,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    in
 		    let new_env =
 		      let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in
-		      Environ.push_rel (LocalAssum (n,t')) env
+                      EConstr.push_rel (LocalAssum (n,t')) env
 		    in
 		    let new_b,id_to_exclude =
 		      rebuild_cons
@@ -1031,8 +1078,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		     mkGProd(n,t,new_b),id_to_exclude
 		     else new_b, Id.Set.add id id_to_exclude
 		  *)
-	    | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2])
-		when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous
+	    | GApp(eq_as_ref,[ty;rt1;rt2])
+		when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous
 		  ->
 	      begin
 		try 
@@ -1043,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		      List.fold_left 
 			(fun acc (lhs,rhs) -> 
 			  mkGProd(Anonymous,
-				  mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc)
+				  mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc)
 			)
 			b
 			l
@@ -1051,9 +1098,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    rebuild_cons env nb_args relname args crossed_types depth new_rt
 		  else raise Continue
 	      with Continue -> 
-		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
+                observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt);
 		let t',ctx = Pretyping.understand env (Evd.from_env env) t in
-		let new_env = Environ.push_rel (LocalAssum (n,t')) env in
+                let new_env = EConstr.push_rel (LocalAssum (n,t')) env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
@@ -1067,9 +1114,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
 	      end
 	    | _ ->
-		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
+                observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt);
 		let t',ctx = Pretyping.understand env (Evd.from_env env) t in
-		let new_env = Environ.push_rel (LocalAssum (n,t')) env in
+                let new_env = EConstr.push_rel (LocalAssum (n,t')) env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
@@ -1082,15 +1129,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			(Id.Set.filter not_free_in_t id_to_exclude)
 		  | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
 	end
-    | GLambda(_,n,k,t,b) ->
+    | GLambda(n,k,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_crossed_types = t :: crossed_types in
-	  observe (str "computing new type for lambda : " ++ pr_glob_constr rt);
+          observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt);
 	  let t',ctx = Pretyping.understand env (Evd.from_env env) t in
 	  match n with
 	    | Name id ->
-		let new_env = Environ.push_rel (LocalAssum (n,t')) env in
+                let new_env = EConstr.push_rel (LocalAssum (n,t')) env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
 		    nb_args relname
@@ -1101,18 +1148,21 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		then
 		  new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)
 		else
-		  GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
-	    | _ -> anomaly (Pp.str "Should not have an anonymous function here")
+		  DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
+	    | _ -> anomaly (Pp.str "Should not have an anonymous function here.")
 		(* We have renamed all the anonymous functions during alpha_renaming phase *)
 
 	end
-    | GLetIn(_,n,t,b) ->
+    | GLetIn(n,v,t,b) ->
 	begin
+          let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let evd = (Evd.from_env env) in
 	  let t',ctx = Pretyping.understand env evd t in
 	  let evd = Evd.from_ctx ctx in
-	  let type_t' = Typing.unsafe_type_of env evd t' in
+          let type_t' = Typing.unsafe_type_of env evd t' in
+          let t' = EConstr.Unsafe.to_constr t' in
+	  let type_t' = EConstr.Unsafe.to_constr type_t' in
 	  let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in
 	  let new_b,id_to_exclude =
 	    rebuild_cons new_env
@@ -1122,10 +1172,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	  match n with
 	    | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args  ->
 		new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)
-	    | _ -> GLetIn(Loc.ghost,n,t,new_b),
+	    | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *)
 		Id.Set.filter not_free_in_t id_to_exclude
 	end
-    | GLetTuple(_,nal,(na,rto),t,b) ->
+    | GLetTuple(nal,(na,rto),t,b) ->
 	assert (Option.is_empty rto);
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
@@ -1137,7 +1187,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      depth t
 	  in
 	  let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in
-	  let new_env = Environ.push_rel (LocalAssum (na,t')) env in
+          let new_env = EConstr.push_rel (LocalAssum (na,t')) env in
 	  let new_b,id_to_exclude =
 	    rebuild_cons new_env
 	      nb_args relname
@@ -1148,7 +1198,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 (* 	    | Name id when Id.Set.mem id id_to_exclude ->  *)
 (* 		new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *)
 (* 	    | _ -> *)
-	  GLetTuple(Loc.ghost,nal,(na,None),t,new_b),
+	  DAst.make @@ GLetTuple(nal,(na,None),t,new_b),
 		Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude')
 
 	end
@@ -1174,31 +1224,39 @@ let rebuild_cons env nb_args relname args crossed_types rt =
 
    TODO: Find a valid way to deal with implicit arguments here!
 *)
-let rec compute_cst_params relnames params = function
+let rec compute_cst_params relnames params gt = DAst.with_val (function
   | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params
-  | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames ->
-      compute_cst_params_from_app [] (params,rtl)
-  | GApp(_,f,args) ->
+  | GApp(f,args) ->
+    begin match DAst.get f with
+    | GVar relname' when Id.Set.mem relname' relnames ->
+      compute_cst_params_from_app [] (params,args)
+    | _ ->
       List.fold_left (compute_cst_params relnames) params (f::args)
-  | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) ->
+    end
+  | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) ->
       let t_params = compute_cst_params relnames params t in
       compute_cst_params relnames t_params b
+  | GLetIn(_,v,t,b) ->
+      let v_params = compute_cst_params relnames params v in
+      let t_params = Option.fold_left (compute_cst_params relnames) v_params t in
+      compute_cst_params relnames t_params b
   | GCases _ ->
       params  (* If there is still cases at this point they can only be
 		 discrimination ones *)
   | GSort _ -> params
   | GHole _ -> params
   | GIf _ | GRec _ | GCast _ ->
-      raise (UserError("compute_cst_params", str "Not handled case"))
+      raise (UserError(Some "compute_cst_params", str "Not handled case"))
+  ) gt
 and compute_cst_params_from_app acc (params,rtl) =
+  let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in
   match params,rtl with
     | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
-    | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl'
-	when Id.compare id id' == 0 && not is_defined ->
+    | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c ->
 	compute_cst_params_from_app (param::acc) (params',rtl')
     | _  -> List.rev acc
 
-let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts =
+let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts =
   let rels_params =
     Array.mapi
       (fun i args ->
@@ -1213,11 +1271,11 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool)
   let _ =
     try
       List.iteri
-	(fun i ((n,nt,is_defined) as param) ->
+	(fun i ((n,nt,typ) as param) ->
 	   if Array.for_all
 	     (fun l ->
-		let (n',nt',is_defined') = List.nth l i in
-		Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined')
+		let (n',nt',typ') = List.nth l i in
+		Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ')
 	     rels_params
 	   then
 	     l := param::!l
@@ -1229,18 +1287,18 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool)
   List.rev !l
 
 let rec rebuild_return_type rt =
-  match rt with
-    | Constrexpr.CProdN(loc,n,t') ->
-	Constrexpr.CProdN(loc,n,rebuild_return_type t')
-    | Constrexpr.CLetIn(loc,na,t,t') ->
-	Constrexpr.CLetIn(loc,na,t,rebuild_return_type t')
-    | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous],
-				       Constrexpr.Default Decl_kinds.Explicit,rt],
-			    Constrexpr.CSort(Loc.ghost,GType []))
-
+  let loc = rt.CAst.loc in
+  match rt.CAst.v with
+    | Constrexpr.CProdN(n,t') ->
+        CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t')
+    | Constrexpr.CLetIn(na,v,t,t') ->
+	CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t')
+    | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous],
+                                       Constrexpr.Default Decl_kinds.Explicit, rt)],
+			    CAst.make @@ Constrexpr.CSort(GType []))
 
 let do_build_inductive
-      evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * bool) list list)
+      evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list)
       returned_types
       (rtl:glob_constr list) =
   let _time1 = System.get_time () in
@@ -1262,36 +1320,41 @@ let do_build_inductive
   let open Context.Named.Declaration in
   let evd,env =
     Array.fold_right2
-      (fun id c (evd,env) ->
-       let evd,t = Typing.type_of env evd (mkConstU c) in
+      (fun id (c, u) (evd,env) ->
+       let u = EConstr.EInstance.make u in
+       let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in
+       let t = EConstr.Unsafe.to_constr t in
        evd,
        Environ.push_named (LocalAssum (id,t))
-			   (* try *)
-			   (*   Typing.e_type_of env evd (mkConstU c) *)
-			   (* with Not_found -> *)
-			   (*   raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) *)
 			 env
       )
       funnames
       (Array.of_list funconstants)
       (evd,Global.env ())
   in
-  let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in
+  (* we solve and replace the implicits *)
+  let rta =
+    Array.mapi (fun i rt ->
+        let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in
+        resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt
+      ) rta
+  in
+  let resa = Array.map (build_entry_lc env funnames_as_set []) rta in
   let env_with_graphs =
     let rel_arity i funargs =  (* Rebuilding arities (with parameters) *)
-      let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list  =
+      let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list  =
 	funargs
       in
       List.fold_right
-	(fun (n,t,is_defined) acc ->
-	   if is_defined
-	   then
-	     Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
+	(fun (n,t,typ) acc ->
+          match typ with
+          | Some typ ->
+             CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
+                              Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ),
 			      acc)
-	   else
-	     Constrexpr.CProdN
-	       (Loc.ghost,
-		[[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t],
+	  | None ->
+	     CAst.make @@ Constrexpr.CProdN
+               ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)],
 		acc
 	       )
 	)
@@ -1304,8 +1367,9 @@ let do_build_inductive
     *)
     let rel_arities = Array.mapi rel_arity funsargs in
     Util.Array.fold_left2 (fun env rel_name rel_ar ->
-			     Environ.push_named (LocalAssum (rel_name,
-						             fst (with_full_print (Constrintern.interp_constr env evd) rel_ar))) env) env relnames rel_arities
+        let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in
+        let rex = EConstr.Unsafe.to_constr rex in
+        Environ.push_named (LocalAssum (rel_name,rex)) env) env relnames rel_arities
   in
   (* and of the real constructors*)
   let constr i res =
@@ -1346,19 +1410,19 @@ let do_build_inductive
     rel_constructors
   in
   let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-    let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list  =
+    let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list  =
       (snd (List.chop nrel_params funargs))
     in
     List.fold_right
-      (fun (n,t,is_defined) acc ->
-	 if is_defined
-	 then
-	   Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
+      (fun (n,t,typ) acc ->
+         match typ with
+         | Some typ ->
+           CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
+                              Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ),
 			    acc)
-	 else
-	   Constrexpr.CProdN
-	   (Loc.ghost,
-	   [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t],
+	 | None ->
+           CAst.make @@ Constrexpr.CProdN
+           ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)],
 	    acc
 	   )
       )
@@ -1382,20 +1446,21 @@ let do_build_inductive
   in
   let rel_params =
     List.map
-      (fun (n,t,is_defined) ->
-	 if is_defined
-	 then
-	   Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t)
-	 else
-	 Constrexpr.LocalRawAssum
-	   ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t)
+      (fun (n,t,typ) ->
+         match typ with
+         | Some typ ->
+           Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t,
+                                  Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ))
+	 | None ->
+	 Constrexpr.CLocalAssum
+           ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t)
       )
       rels_params
   in
   let ext_rels_constructors =
     Array.map (List.map
       (fun (id,t) ->
-	 false,((Loc.ghost,id),
+         false,((CAst.make id),
 		with_full_print
 		  (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t))
 	       )
@@ -1403,7 +1468,7 @@ let do_build_inductive
       (rel_constructors)
   in
   let rel_ind i ext_rel_constructors =
-    (((Loc.ghost,relnames.(i)), None),
+    (((CAst.make @@ relnames.(i)), None),
     rel_params,
     Some rel_arities.(i),
     ext_rel_constructors),[]
@@ -1432,7 +1497,9 @@ let do_build_inductive
 (*   in *)
   let _time2 = System.get_time () in
   try
-    with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false)) Decl_kinds.Finite
+    with_full_print
+      (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false))
+      Declarations.Finite
   with
     | UserError(s,msg) as e ->
 	let _time3 = System.get_time () in
@@ -1443,7 +1510,7 @@ let do_build_inductive
 	in
 	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
+            Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds)))
 	    ++ fnl () ++
 	    msg
 	in
@@ -1458,7 +1525,7 @@ let do_build_inductive
 	in
 	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
+            Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds)))
 	    ++ fnl () ++
 	    CErrors.print reraise
 	in
diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli
index 5bb1376e..ff0e98d0 100644
--- a/plugins/funind/glob_term_to_relation.mli
+++ b/plugins/funind/glob_term_to_relation.mli
@@ -11,8 +11,8 @@ val build_inductive :
   Id.t list -> (* The list of function name *) 
  *)
   Evd.evar_map ->
-  Term.pconstant list -> 
-  (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
+  Constr.pconstant list -> 
+  (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *)
   Constrexpr.constr_expr list -> (* The list of function returned type *)
   Glob_term.glob_constr list -> (* the list of body *)
   unit
diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml
index 01e5ef7f..769fcc1c 100644
--- a/plugins/funind/glob_termops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -10,83 +10,26 @@ open Misctypes
    Some basic functions to rebuild glob_constr
    In each of them the location is Loc.ghost
 *)
-let mkGRef ref = GRef(Loc.ghost,ref,None)
-let mkGVar id = GVar(Loc.ghost,id)
-let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl)
-let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b)
-let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b)
-let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b)
-let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl)
-let mkGSort s = GSort(Loc.ghost,s)
-let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None)
-let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t)
+let mkGRef ref          = DAst.make @@ GRef(ref,None)
+let mkGVar id           = DAst.make @@ GVar(id)
+let mkGApp(rt,rtl)      = DAst.make @@ GApp(rt,rtl)
+let mkGLambda(n,t,b)    = DAst.make @@ GLambda(n,Explicit,t,b)
+let mkGProd(n,t,b)      = DAst.make @@ GProd(n,Explicit,t,b)
+let mkGLetIn(n,b,t,c)   = DAst.make @@ GLetIn(n,b,t,c)
+let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl)
+let mkGHole ()          = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None)
 
 (*
   Some basic functions to decompose glob_constrs
   These are analogous to the ones constrs
 *)
-let glob_decompose_prod =
-  let rec glob_decompose_prod args = function
-  | GProd(_,n,k,t,b) ->
-      glob_decompose_prod ((n,t)::args) b
-  | rt -> args,rt
-  in
-  glob_decompose_prod []
-
-let glob_decompose_prod_or_letin =
-  let rec glob_decompose_prod args = function
-  | GProd(_,n,k,t,b) ->
-      glob_decompose_prod ((n,None,Some t)::args) b
-  | GLetIn(_,n,t,b) ->
-      glob_decompose_prod ((n,Some t,None)::args) b
-  | rt -> args,rt
-  in
-  glob_decompose_prod []
-
-let glob_compose_prod =
-  List.fold_left (fun b (n,t) -> mkGProd(n,t,b))
-
-let glob_compose_prod_or_letin =
-  List.fold_left (
-      fun concl decl ->
-	match decl with
-	  | (n,None,Some t) -> mkGProd(n,t,concl)
-	  | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl)
-	  | _ -> assert false)
-
-let glob_decompose_prod_n n =
-  let rec glob_decompose_prod i args c =
-    if i<=0 then args,c
-    else
-      match c with
-	| GProd(_,n,_,t,b) ->
-	    glob_decompose_prod (i-1) ((n,t)::args) b
-	| rt -> args,rt
-  in
-  glob_decompose_prod n []
-
-
-let glob_decompose_prod_or_letin_n n =
-  let rec glob_decompose_prod i args c =
-    if i<=0 then args,c
-    else
-      match c with
-	| GProd(_,n,_,t,b) ->
-	    glob_decompose_prod (i-1) ((n,None,Some t)::args) b
-	| GLetIn(_,n,t,b) ->
-	    glob_decompose_prod (i-1) ((n,Some t,None)::args) b
-	| rt -> args,rt
-  in
-  glob_decompose_prod n []
-
-
 let glob_decompose_app =
   let rec decompose_rapp acc rt =
 (*     msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *)
-    match rt with
-    | GApp(_,rt,rtl) ->
+    match DAst.get rt with
+    | GApp(rt,rtl) ->
 	decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
-    | rt -> rt,List.rev acc
+    | _ -> rt,List.rev acc
   in
   decompose_rapp []
 
@@ -101,18 +44,6 @@ let glob_make_eq ?(typ= mkGHole ()) t1 t2  =
 let glob_make_neq t1 t2 =
   mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2])
 
-(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
-let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
-
-(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
-   to [P1 \/ ( .... \/ Pn)]
-*)
-let rec glob_make_or_list = function
-  | [] -> invalid_arg "mk_or"
-  | [e] -> e
-  | e::l -> glob_make_or e (glob_make_or_list l)
-
-
 let remove_name_from_mapping mapping na =
   match na with
     | Anonymous -> mapping
@@ -120,96 +51,93 @@ let remove_name_from_mapping mapping na =
 
 let change_vars =
   let rec change_vars mapping rt =
-    match rt with
-      | GRef _ -> rt
-      | GVar(loc,id) ->
+    DAst.map_with_loc (fun ?loc -> function
+      | GRef _ as x -> x
+      | GVar id ->
 	  let new_id =
 	    try
 	      Id.Map.find id mapping
 	    with Not_found -> id
 	  in
-	  GVar(loc,new_id)
-      | GEvar _ -> rt
-      | GPatVar _ -> rt
-      | GApp(loc,rt',rtl) ->
-	  GApp(loc,
-	       change_vars mapping rt',
+	  GVar(new_id)
+      | GEvar _ as x   -> x
+      | GPatVar _ as x -> x
+      | GApp(rt',rtl) ->
+	  GApp(change_vars mapping rt',
 	       List.map (change_vars mapping) rtl
 	      )
-      | GLambda(loc,name,k,t,b) ->
-	  GLambda(loc,
-		  name,
+      | GLambda(name,k,t,b) ->
+	  GLambda(name,
 		  k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | GProd(loc,name,k,t,b) ->
-	  GProd(loc,
-		  name,
+      | GProd(name,k,t,b) ->
+	  GProd(  name,
 	          k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | GLetIn(loc,name,def,b) ->
-	  GLetIn(loc,
-		 name,
+      | GLetIn(name,def,typ,b) ->
+	  GLetIn(name,
 		 change_vars mapping def,
+		 Option.map (change_vars mapping) typ,
 		 change_vars (remove_name_from_mapping mapping name) b
 		)
-      | GLetTuple(loc,nal,(na,rto),b,e) ->
+      | GLetTuple(nal,(na,rto),b,e) ->
 	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
-	  GLetTuple(loc,
-		    nal,
+	  GLetTuple(nal,
 		    (na, Option.map (change_vars mapping) rto),
 		    change_vars mapping b,
 		    change_vars new_mapping e
 		   )
-      | GCases(loc,sty,infos,el,brl) ->
-	  GCases(loc,sty,
+      | GCases(sty,infos,el,brl) ->
+	  GCases(sty,
 		 infos,
 		 List.map (fun (e,x) -> (change_vars mapping e,x)) el,
 		 List.map (change_vars_br mapping) brl
 		)
-      | GIf(loc,b,(na,e_option),lhs,rhs) ->
-	  GIf(loc,
-	      change_vars mapping b,
+      | GIf(b,(na,e_option),lhs,rhs) ->
+	  GIf(change_vars mapping b,
 	      (na,Option.map (change_vars mapping) e_option),
 	      change_vars mapping lhs,
 	      change_vars mapping rhs
 	     )
-      | GRec _ -> error "Local (co)fixes are not supported"
-      | GSort _ -> rt
-      | GHole _ -> rt
-      | GCast(loc,b,c) ->
-	  GCast(loc,change_vars mapping b,
+      | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported")
+      | GSort _ as x -> x
+      | GHole _ as x -> x
+      | GCast(b,c) ->
+	  GCast(change_vars mapping b,
 		Miscops.map_cast_type (change_vars mapping) c)
-  and change_vars_br mapping ((loc,idl,patl,res) as br) =
+      ) rt
+  and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) =
     let new_mapping = List.fold_right Id.Map.remove idl mapping in
     if Id.Map.is_empty new_mapping
     then br
-    else (loc,idl,patl,change_vars new_mapping res)
+    else CAst.make ?loc (idl,patl,change_vars new_mapping res)
   in
   change_vars
 
 
 
 let rec alpha_pat excluded pat =
-  match pat with
-    | PatVar(loc,Anonymous) ->
+  let loc = pat.CAst.loc in
+  match DAst.get pat with
+    | PatVar Anonymous ->
 	let new_id = Indfun_common.fresh_id excluded "_x" in
-	PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty
-    | PatVar(loc,Name id) ->
+	(DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty
+    | PatVar(Name id) ->
 	if Id.List.mem id excluded
 	then
-	  let new_id = Namegen.next_ident_away id excluded in
-	  PatVar(loc,Name new_id),(new_id::excluded),
+	  let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
+	  (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),
 	(Id.Map.add id new_id Id.Map.empty)
-	else pat,excluded,Id.Map.empty
-    | PatCstr(loc,constr,patl,na) ->
+	else pat, excluded,Id.Map.empty
+    | PatCstr(constr,patl,na) ->
 	let new_na,new_excluded,map =
 	  match na with
 	    | Name id when Id.List.mem id excluded ->
-		let new_id = Namegen.next_ident_away id excluded in
+		let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
 		Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty
 	    | _ -> na,excluded,Id.Map.empty
 	in
@@ -222,7 +150,7 @@ let rec alpha_pat excluded pat =
 	    ([],new_excluded,map)
 	    patl
 	in
-	PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map
+        (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map
 
 let alpha_patl excluded patl  =
   let patl,new_excluded,map =
@@ -241,11 +169,11 @@ let alpha_patl excluded patl  =
 
 let raw_get_pattern_id pat acc =
   let rec get_pattern_id pat =
-    match pat with
-      | PatVar(loc,Anonymous) -> assert false
-      | PatVar(loc,Name id) ->
+    match DAst.get pat with
+      | PatVar(Anonymous) -> assert false
+      | PatVar(Name id) ->
 	  [id]
-      | PatCstr(loc,constr,patternl,_) ->
+      | PatCstr(constr,patternl,_) ->
 	  List.fold_right
 	  (fun pat idl ->
 	     let idl' = get_pattern_id pat in
@@ -259,28 +187,30 @@ let raw_get_pattern_id pat acc =
 let get_pattern_id pat = raw_get_pattern_id pat []
 
 let rec alpha_rt excluded rt =
-  let new_rt =
-    match rt with
-      | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt
-      | GLambda(loc,Anonymous,k,t,b) ->
-	  let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in
+  let loc = rt.CAst.loc in
+  let new_rt = DAst.make ?loc @@
+    match DAst.get rt with
+      | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt
+      | GLambda(Anonymous,k,t,b) ->
+	  let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in
 	  let new_excluded = new_id :: excluded in
 	  let new_t = alpha_rt new_excluded t in
 	  let new_b = alpha_rt new_excluded b in
-	  GLambda(loc,Name new_id,k,new_t,new_b)
-      | GProd(loc,Anonymous,k,t,b) ->
+	  GLambda(Name new_id,k,new_t,new_b)
+      | GProd(Anonymous,k,t,b) ->
 	let new_t = alpha_rt excluded t in
 	let new_b = alpha_rt excluded b in
-	GProd(loc,Anonymous,k,new_t,new_b)
-    | GLetIn(loc,Anonymous,t,b) ->
-	let new_t = alpha_rt excluded t in
+	GProd(Anonymous,k,new_t,new_b)
+    | GLetIn(Anonymous,b,t,c) ->
 	let new_b = alpha_rt excluded b in
-	GLetIn(loc,Anonymous,new_t,new_b)
-    | GLambda(loc,Name id,k,t,b) ->
-	let new_id = Namegen.next_ident_away id excluded in
+	let new_t = Option.map (alpha_rt excluded) t in
+	let new_c = alpha_rt excluded c in
+	GLetIn(Anonymous,new_b,new_t,new_c)
+    | GLambda(Name id,k,t,b) ->
+	let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
 	let t,b =
 	  if Id.equal new_id id
-	  then t,b
+	  then t, b
 	  else
 	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
@@ -288,9 +218,9 @@ let rec alpha_rt excluded rt =
 	let new_excluded = new_id::excluded in
 	let new_t = alpha_rt new_excluded t in
 	let new_b = alpha_rt new_excluded b in
-	GLambda(loc,Name new_id,k,new_t,new_b)
-    | GProd(loc,Name id,k,t,b) ->
-	let new_id = Namegen.next_ident_away id excluded in
+	GLambda(Name new_id,k,new_t,new_b)
+    | GProd(Name id,k,t,b) ->
+	let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
 	let new_excluded = new_id::excluded in
 	let t,b =
 	  if Id.equal new_id id
@@ -301,30 +231,27 @@ let rec alpha_rt excluded rt =
 	in
 	let new_t = alpha_rt new_excluded t in
 	let new_b = alpha_rt new_excluded b in
-	GProd(loc,Name new_id,k,new_t,new_b)
-    | GLetIn(loc,Name id,t,b) ->
-	let new_id = Namegen.next_ident_away id excluded in
-	let t,b =
-	  if Id.equal new_id id
-	  then t,b
-	  else
-	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
-	    (t,replace b)
+	GProd(Name new_id,k,new_t,new_b)
+    | GLetIn(Name id,b,t,c) ->
+	let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
+	let c =
+	  if Id.equal new_id id then c
+	  else change_vars (Id.Map.add id new_id Id.Map.empty) c
 	in
 	let new_excluded = new_id::excluded in
-	let new_t = alpha_rt new_excluded t in
 	let new_b = alpha_rt new_excluded b in
-	GLetIn(loc,Name new_id,new_t,new_b)
-
+	let new_t = Option.map (alpha_rt new_excluded) t in
+	let new_c = alpha_rt new_excluded c in
+	GLetIn(Name new_id,new_b,new_t,new_c)
 
-    | GLetTuple(loc,nal,(na,rto),t,b) ->
+    | GLetTuple(nal,(na,rto),t,b) ->
 	let rev_new_nal,new_excluded,mapping =
 	  List.fold_left
 	    (fun (nal,excluded,mapping) na ->
 	       match na with
 		 | Anonymous -> (na::nal,excluded,mapping)
 		 | Name id ->
-		     let new_id = Namegen.next_ident_away id excluded in
+		     let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
 		     if Id.equal new_id id
 		     then
 		       na::nal,id::excluded,mapping
@@ -344,85 +271,92 @@ let rec alpha_rt excluded rt =
 	let new_t = alpha_rt new_excluded new_t in
 	let new_b = alpha_rt new_excluded new_b in
 	let new_rto = Option.map (alpha_rt new_excluded) new_rto  in
-	GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
-    | GCases(loc,sty,infos,el,brl) ->
+	GLetTuple(new_nal,(na,new_rto),new_t,new_b)
+    | GCases(sty,infos,el,brl) ->
 	let new_el =
 	  List.map (function (rt,i) -> alpha_rt excluded rt, i) el
 	in
-	GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
-    | GIf(loc,b,(na,e_o),lhs,rhs) ->
-	GIf(loc,alpha_rt excluded b,
+	GCases(sty,infos,new_el,List.map (alpha_br excluded) brl)
+    | GIf(b,(na,e_o),lhs,rhs) ->
+	GIf(alpha_rt excluded b,
 	    (na,Option.map (alpha_rt excluded) e_o),
 	    alpha_rt excluded lhs,
 	    alpha_rt excluded rhs
 	   )
-    | GRec _ -> error "Not handled GRec"
-    | GSort _ -> rt
-    | GHole _ -> rt
-    | GCast (loc,b,c) ->
-	GCast(loc,alpha_rt excluded b,
+    | GRec _ -> user_err Pp.(str "Not handled GRec")
+    | GSort _
+    | GHole _ as rt -> rt
+    | GCast (b,c) ->
+	GCast(alpha_rt excluded b,
 	      Miscops.map_cast_type (alpha_rt excluded) c)
-    | GApp(loc,f,args) ->
-	GApp(loc,
-	     alpha_rt excluded f,
+    | GApp(f,args) ->
+	GApp(alpha_rt excluded f,
 	     List.map (alpha_rt excluded) args
 	    )
   in
   new_rt
 
-and alpha_br excluded (loc,ids,patl,res) =
+and alpha_br excluded {CAst.loc;v=(ids,patl,res)} =
   let new_patl,new_excluded,mapping = alpha_patl excluded patl in
   let new_ids = List.fold_right raw_get_pattern_id new_patl [] in
   let new_excluded = new_ids@excluded in
   let renamed_res = change_vars mapping res in
   let new_res = alpha_rt new_excluded renamed_res in
-  (loc,new_ids,new_patl,new_res)
+  CAst.make ?loc (new_ids,new_patl,new_res)
 
 (*
    [is_free_in id rt] checks if [id] is a free variable in [rt]
 *)
 let is_free_in id =
-  let rec is_free_in = function
+  let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function
     | GRef _ ->  false
-    | GVar(_,id') -> Id.compare id' id == 0
+    | GVar id' -> Id.compare id' id == 0
     | GEvar _ -> false
     | GPatVar _ -> false
-    | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
-    | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) ->
+    | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl)
+    | GLambda(n,_,t,b) | GProd(n,_,t,b) ->
 	let check_in_b =
 	  match n with
 	    | Name id' -> not (Id.equal id' id)
 	    | _ -> true
 	in
 	is_free_in t || (check_in_b && is_free_in b)
-    | GCases(_,_,_,el,brl) ->
+    | GLetIn(n,b,t,c) ->
+	let check_in_c =
+	  match n with
+	    | Name id' -> not (Id.equal id' id)
+	    | _ -> true
+	in
+	is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c)
+    | GCases(_,_,el,brl) ->
 	(List.exists (fun (e,_) -> is_free_in e) el) ||
 	  List.exists is_free_in_br brl
-    | GLetTuple(_,nal,_,b,t) ->
+    | GLetTuple(nal,_,b,t) ->
 	let check_in_nal =
 	  not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal)
 	in
 	is_free_in t  || (check_in_nal && is_free_in b)
 
-    | GIf(_,cond,_,br1,br2) ->
+    | GIf(cond,_,br1,br2) ->
 	is_free_in cond || is_free_in br1 || is_free_in br2
-    | GRec _ -> raise (UserError("",str "Not handled GRec"))
+    | GRec _  -> user_err Pp.(str "Not handled GRec")
     | GSort _ -> false
     | GHole _ -> false
-    | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t
-    | GCast (_,b,CastCoerce) -> is_free_in b
-  and is_free_in_br (_,ids,_,rt) =
+    | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t
+    | GCast (b,CastCoerce) -> is_free_in b
+    ) x
+  and is_free_in_br {CAst.v=(ids,_,rt)} =
     (not (Id.List.mem id ids)) && is_free_in rt
   in
   is_free_in
 
 
 
-let rec pattern_to_term  = function
-  | PatVar(loc,Anonymous) -> assert false
-  | PatVar(loc,Name id) ->
+let rec pattern_to_term pt = DAst.with_val (function
+  | PatVar Anonymous -> assert false
+  | PatVar(Name id) ->
 	mkGVar id
-  | PatCstr(loc,constr,patternl,_) ->
+  | PatCstr(constr,patternl,_) ->
       let cst_narg =
 	Inductiveops.constructor_nallargs_env
 	  (Global.env ())
@@ -441,77 +375,73 @@ let rec pattern_to_term  = function
       mkGApp(mkGRef(Globnames.ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
-
+  ) pt
 
 
 let replace_var_by_term x_id term =
-  let rec replace_var_by_pattern rt =
-    match rt with
-      | GRef _ -> rt
-      | GVar(_,id) when Id.compare id x_id == 0 -> term
-      | GVar _ -> rt
-      | GEvar _ -> rt
-      | GPatVar _ -> rt
-      | GApp(loc,rt',rtl) ->
-	  GApp(loc,
-	       replace_var_by_pattern rt',
+  let rec replace_var_by_pattern x = DAst.map (function
+      | GVar id when Id.compare id x_id == 0 -> DAst.get term
+      | GRef _
+      | GVar _
+      | GEvar _
+      | GPatVar _ as rt -> rt
+      | GApp(rt',rtl) ->
+	  GApp(replace_var_by_pattern rt',
 	       List.map replace_var_by_pattern rtl
 	      )
-      | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt
-      | GLambda(loc,name,k,t,b) ->
-	  GLambda(loc,
-		  name,
+      | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt
+      | GLambda(name,k,t,b) ->
+	  GLambda(name,
 		  k,
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt
-      | GProd(loc,name,k,t,b) ->
-	  GProd(loc,
-		  name,
+      | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt
+      | GProd(name,k,t,b) ->
+	  GProd(  name,
 	          k,
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt
-      | GLetIn(loc,name,def,b) ->
-	  GLetIn(loc,
-		 name,
+      | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt
+      | GLetIn(name,def,typ,b) ->
+	  GLetIn(name,
 		 replace_var_by_pattern def,
+		 Option.map (replace_var_by_pattern) typ,
 		 replace_var_by_pattern b
 		)
-      | GLetTuple(_,nal,_,_,_)
+      | GLetTuple(nal,_,_,_) as rt
 	  when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal  ->
 	  rt
-      | GLetTuple(loc,nal,(na,rto),def,b) ->
-	  GLetTuple(loc,
-		    nal,
+      | GLetTuple(nal,(na,rto),def,b) ->
+	  GLetTuple(nal,
 		    (na,Option.map replace_var_by_pattern rto),
 		    replace_var_by_pattern def,
 		    replace_var_by_pattern b
 		   )
-      | GCases(loc,sty,infos,el,brl) ->
-	  GCases(loc,sty,
+      | GCases(sty,infos,el,brl) ->
+	  GCases(sty,
 		 infos,
 		 List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el,
 		 List.map replace_var_by_pattern_br brl
 		)
-      | GIf(loc,b,(na,e_option),lhs,rhs) ->
-	  GIf(loc, replace_var_by_pattern b,
+      | GIf(b,(na,e_option),lhs,rhs) ->
+	  GIf(replace_var_by_pattern b,
 	      (na,Option.map replace_var_by_pattern e_option),
 	      replace_var_by_pattern lhs,
 	      replace_var_by_pattern rhs
 	     )
-      | GRec _ -> raise (UserError("",str "Not handled GRec"))
-      | GSort _ -> rt
-      | GHole _ -> rt
-      | GCast(loc,b,c) ->
-	  GCast(loc,replace_var_by_pattern b,
+      | GRec _ -> raise (UserError(None,str "Not handled GRec"))
+      | GSort _
+      | GHole _ as rt -> rt
+      | GCast(b,c) ->
+	  GCast(replace_var_by_pattern b,
 		Miscops.map_cast_type replace_var_by_pattern c)
-  and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
+    ) x
+  and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) =
     if List.exists (fun id -> Id.compare id x_id == 0) idl
     then br
-    else (loc,idl,patl,replace_var_by_pattern res)
+    else CAst.make ?loc (idl,patl,replace_var_by_pattern res)
   in
   replace_var_by_pattern
 
@@ -523,16 +453,16 @@ exception NotUnifiable
 
 let rec are_unifiable_aux  = function
   | [] -> ()
-  | eq::eqs ->
-      match eq with
-	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
-	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+  | (l, r) ::eqs ->
+      match DAst.get l, DAst.get r with
+	 | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs
+	 | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) ->
 	     if not (eq_constructor constructor2 constructor1)
 	     then raise NotUnifiable
 	     else
 	       let eqs' =
 		 try (List.combine cpl1 cpl2) @ eqs
-		 with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux")
+		 with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.")
 	       in
 	       are_unifiable_aux eqs'
 
@@ -545,16 +475,16 @@ let are_unifiable pat1 pat2 =
 
 let rec eq_cases_pattern_aux  = function
   | [] -> ()
-  | eq::eqs ->
-      match eq with
-	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
-	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+  | (l, r) ::eqs ->
+      match DAst.get l, DAst.get r with
+	 | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs
+	 | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) ->
 	     if not (eq_constructor constructor2 constructor1)
 	     then raise NotUnifiable
 	     else
 	       let eqs' =
 		 try (List.combine cpl1 cpl2) @ eqs
-		 with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux")
+		 with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.")
 	       in
 	       eq_cases_pattern_aux eqs'
 	 | _ -> raise NotUnifiable
@@ -568,143 +498,116 @@ let eq_cases_pattern pat1 pat2 =
 
 
 let ids_of_pat =
-  let rec ids_of_pat ids = function
-    | PatVar(_,Anonymous) -> ids
-    | PatVar(_,Name id) -> Id.Set.add id ids
-    | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
+  let rec ids_of_pat ids = DAst.with_val (function
+    | PatVar Anonymous -> ids
+    | PatVar(Name id) -> Id.Set.add id ids
+    | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl
+    )
   in
   ids_of_pat Id.Set.empty
 
-let id_of_name = function
-  | Names.Anonymous -> Id.of_string "x"
-  | Names.Name x -> x
-
-(* TODO: finish Rec caes *)
-let ids_of_glob_constr c =
-  let rec ids_of_glob_constr acc c =
-    let idof = id_of_name in
-    match c with
-      | GVar (_,id) -> id::acc
-      | GApp (loc,g,args) ->
-          ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc
-      | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
-      | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
-      | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
-      | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
-      | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc
-      | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc
-      | GLetTuple (_,nal,(na,po),b,c) ->
-          List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
-      | GCases (loc,sty,rtntypopt,tml,brchl) ->
-	  List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl)
-      | GRec _ -> failwith "Fix inside a constructor branch"
-      | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> []
-  in
-  (* build the set *)
-  List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c)
-
-
-
-
-
-let zeta_normalize =
-  let rec zeta_normalize_term rt =
-    match rt with
-      | GRef _ -> rt
-      | GVar _ -> rt
-      | GEvar _ -> rt
-      | GPatVar _ -> rt
-      | GApp(loc,rt',rtl) ->
-	  GApp(loc,
-	       zeta_normalize_term rt',
-	       List.map zeta_normalize_term rtl
-	      )
-      | GLambda(loc,name,k,t,b) ->
-	  GLambda(loc,
-		  name,
-		  k,
-		  zeta_normalize_term t,
-		  zeta_normalize_term b
-		 )
-      | GProd(loc,name,k,t,b) ->
-	  GProd(loc,
-		name,
-	        k,
-		zeta_normalize_term t,
-		zeta_normalize_term b
-		 )
-      | GLetIn(_,Name id,def,b) ->
-	  zeta_normalize_term (replace_var_by_term id def b)
-      | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
-      | GLetTuple(loc,nal,(na,rto),def,b) ->
-	  GLetTuple(loc,
-		    nal,
-		    (na,Option.map zeta_normalize_term rto),
-		    zeta_normalize_term def,
-		    zeta_normalize_term b
-		   )
-      | GCases(loc,sty,infos,el,brl) ->
-	  GCases(loc,sty,
-		 infos,
-		 List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
-		 List.map zeta_normalize_br brl
-		)
-      | GIf(loc,b,(na,e_option),lhs,rhs) ->
-	  GIf(loc, zeta_normalize_term b,
-	      (na,Option.map zeta_normalize_term e_option),
-	      zeta_normalize_term lhs,
-	      zeta_normalize_term rhs
-	     )
-      | GRec _ -> raise (UserError("",str "Not handled GRec"))
-      | GSort _ -> rt
-      | GHole _ -> rt
-      | GCast(loc,b,c) ->
-	  GCast(loc,zeta_normalize_term b,
-                Miscops.map_cast_type zeta_normalize_term c)
-  and zeta_normalize_br (loc,idl,patl,res) =
-    (loc,idl,patl,zeta_normalize_term res)
-  in
-  zeta_normalize_term
-
-
-
-
 let expand_as =
 
-  let rec add_as map pat =
-    match pat with
+  let rec add_as map rt =
+    match DAst.get rt with
       | PatVar _ -> map
-      | PatCstr(_,_,patl,Name id) ->
-	  Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl)
-      | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
+      | PatCstr(_,patl,Name id) ->
+	  Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl)
+      | PatCstr(_,patl,_) -> List.fold_left add_as map patl
   in
-  let rec expand_as map rt =
-    match rt with
-      | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt
-      | GVar(_,id) ->
+  let rec expand_as map = DAst.map (function
+      | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt
+      | GVar id as rt ->
 	  begin
 	    try
-	      Id.Map.find id map
+	      DAst.get (Id.Map.find id map)
 	    with Not_found -> rt
 	  end
-      | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args)
-      | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b)
-      | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b)
-      | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b)
-      | GLetTuple(loc,nal,(na,po),v,b) ->
-	  GLetTuple(loc,nal,(na,Option.map (expand_as map) po),
+      | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args)
+      | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b)
+      | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b)
+      | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b)
+      | GLetTuple(nal,(na,po),v,b) ->
+	  GLetTuple(nal,(na,Option.map (expand_as map) po),
 		    expand_as map v, expand_as map b)
-      | GIf(loc,e,(na,po),br1,br2) ->
-	  GIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
+      | GIf(e,(na,po),br1,br2) ->
+	  GIf(expand_as map e,(na,Option.map (expand_as map) po),
 	      expand_as map br1, expand_as map br2)
-      | GRec _ ->  error "Not handled GRec"
-      | GCast(loc,b,c) ->
-	  GCast(loc,expand_as map b,
+      | GRec _ ->  user_err Pp.(str "Not handled GRec")
+      | GCast(b,c) ->
+	  GCast(expand_as map b,
 		Miscops.map_cast_type (expand_as map) c)
-      | GCases(loc,sty,po,el,brl) ->
-	  GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+      | GCases(sty,po,el,brl) ->
+	  GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
 		List.map (expand_as_br map) brl)
-  and expand_as_br map (loc,idl,cpl,rt) =
-    (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
+    )
+  and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} =
+    CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
   in
   expand_as Id.Map.empty
+
+(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution 
+ *)
+
+exception Found of Evd.evar_info
+let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt =
+  let open Evd in
+  let open Evar_kinds in 
+  (* we first (pseudo) understand [rt] and get back the computed evar_map *)
+  (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. 
+If someone knows how to prevent solved existantial removal in  understand, please do not hesitate to change the computation of [ctx] here *) 
+  let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in
+  let ctx, f = Evarutil.nf_evars_and_universes ctx in
+
+  (* then we map [rt] to replace the implicit holes by their values *)
+  let rec change rt =
+    match DAst.get rt with
+    | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *)
+       (
+         try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *)
+           Evd.fold (* to simulate an iter *)
+             (fun _ evi _ ->
+               match evi.evar_source with
+               | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) ->
+                  if Globnames.eq_gr grk gr_evi && pk=p_evi && bk=b_evi  && rt.CAst.loc = loc_evi
+                  then raise (Found evi)
+               | _ -> ()
+             )
+             ctx
+             ();
+           (* the hole was not solved : we do nothing *)
+           rt
+         with Found evi -> (* we found the evar corresponding to this hole *)
+           match evi.evar_body with
+           | Evar_defined c ->
+           (* we just have to lift the solution in glob_term *)
+              Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c))
+           | Evar_empty -> rt (* the hole was not solved : we do nothing *)
+       )
+    | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *)
+       (
+         let res = 
+           try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *)
+             Evd.fold (* to simulate an iter *)
+               (fun _ evi _ ->
+                 match evi.evar_source with
+                 | (loc_evi,BinderType na') ->
+                    if Name.equal na na' && rt.CAst.loc = loc_evi  then raise (Found evi)
+                 | _ -> ()
+               )
+               ctx
+               ();
+             (* the hole was not solved : we do nothing *)
+             rt
+           with Found evi -> (* we found the evar corresponding to this hole *)
+                match evi.evar_body with
+                | Evar_defined c ->
+                   (* we just have to lift the solution in glob_term *)
+                   Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c))
+                | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *)
+         in 
+         res
+       )
+    | _ -> Glob_ops.map_glob_constr change rt 
+  in
+  change rt
diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli
index 179e8fe8..7088ae59 100644
--- a/plugins/funind/glob_termops.mli
+++ b/plugins/funind/glob_termops.mli
@@ -1,6 +1,5 @@
 open Names
 open Glob_term
-open Misctypes
 
 (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
 val get_pattern_id : cases_pattern -> Id.t list
@@ -19,24 +18,13 @@ val mkGVar : Id.t -> glob_constr
 val mkGApp  : glob_constr*(glob_constr list) -> glob_constr
 val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr
 val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr
-val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr
+val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr
 val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr
-val mkGSort : glob_sort -> glob_constr
 val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *)
-val mkGCast : glob_constr* glob_constr -> glob_constr
 (*
   Some basic functions to decompose glob_constrs
   These are analogous to the ones constrs
 *)
-val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr
-val glob_decompose_prod_or_letin :
-  glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr
-val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr
-val glob_decompose_prod_or_letin_n : int -> glob_constr ->
-  (Name.t*glob_constr option*glob_constr option) list * glob_constr
-val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list  ->  glob_constr
-val glob_compose_prod_or_letin: glob_constr ->
-  (Name.t*glob_constr option*glob_constr option) list  ->  glob_constr
 val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list)
 
 
@@ -44,14 +32,6 @@ val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list)
 val  glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr
 (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *)
 val  glob_make_neq : glob_constr -> glob_constr -> glob_constr
-(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
-val  glob_make_or : glob_constr -> glob_constr -> glob_constr
-
-(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
-   to [P1 \/ ( .... \/ Pn)]
-*)
-val  glob_make_or_list : glob_constr list -> glob_constr
-
 
 (* alpha_conversion functions *)
 
@@ -82,11 +62,8 @@ val alpha_rt : Id.t list -> glob_constr -> glob_constr
 
 (* same as alpha_rt but for case branches *)
 val alpha_br : Id.t list ->
-    Loc.t * Id.t list * Glob_term.cases_pattern list *
-    Glob_term.glob_constr ->
-    Loc.t * Id.t list * Glob_term.cases_pattern list *
-    Glob_term.glob_constr
-
+  Glob_term.cases_clause ->
+  Glob_term.cases_clause
 
 (* Reduction function *)
 val replace_var_by_term  :
@@ -112,13 +89,10 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
 *)
 val   ids_of_pat : cases_pattern -> Id.Set.t
 
-(* TODO: finish this function (Fix not treated) *)
-val ids_of_glob_constr: glob_constr -> Id.Set.t
-
-(*
-   removing let_in construction in a glob_constr
-*)
-val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr
-
-
 val expand_as : glob_constr -> glob_constr
+
+(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution 
+ *)
+val resolve_and_replace_implicits :
+      ?flags:Pretyping.inference_flags -> 
+      ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 18817f50..57863ee6 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -1,8 +1,9 @@
-open Context.Rel.Declaration
 open CErrors
+open Sorts
 open Util
 open Names
-open Term
+open Constr
+open EConstr
 open Pp
 open Indfun_common
 open Libnames
@@ -11,39 +12,42 @@ open Glob_term
 open Declarations
 open Misctypes
 open Decl_kinds
-open Sigma.Notations
 
-let is_rec_info scheme_info =
+module RelDecl = Context.Rel.Declaration
+
+let is_rec_info sigma scheme_info =
   let test_branche min acc decl =
     acc || (
       let new_branche =
-	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in
-      let free_rels_in_br = Termops.free_rels new_branche in
+	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in
+      let free_rels_in_br = Termops.free_rels sigma new_branche in
       let max = min + scheme_info.Tactics.npredicates in
       Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br
     )
   in
   List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
 
-let choose_dest_or_ind scheme_info =
-  Tactics.induction_destruct (is_rec_info scheme_info) false
+let choose_dest_or_ind scheme_info args =
+  Proofview.tclBIND Proofview.tclEVARMAP (fun sigma ->
+  Tactics.induction_destruct (is_rec_info sigma scheme_info) false args)
 
 let functional_induction with_clean c princl pat =
   let res =
-    let f,args = decompose_app c in
     fun g ->
+    let sigma = Tacmach.project g in
+    let f,args = decompose_app sigma c in
     let princ,bindings, princ_type,g' =
       match princl with
       | None -> (* No principle is given let's find the good one *)
 	 begin
-	   match kind_of_term f with
+	   match EConstr.kind sigma f with
 	   | Const (c',u) ->
 	      let princ_option =
 		let finfo = (* we first try to find out a graph on f *)
 		  try find_Function_infos c'
 		  with Not_found ->
-		    errorlabstrm "" (str "Cannot find induction information on "++
-				       Printer.pr_lconstr (mkConst c') )
+		    user_err  (str "Cannot find induction information on "++
+                                       Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') )
 		in
 		match Tacticals.elimination_sort_of_goal g with
 		| InProp -> finfo.prop_lemma
@@ -61,7 +65,7 @@ let functional_induction with_clean c princl pat =
 			  (or f_rec, f_rect) i*)
 		  let princ_name =
 		    Indrec.make_elimination_ident
-		      (Label.to_id (con_label c'))
+		      (Label.to_id (Constant.label c'))
 		      (Tacticals.elimination_sort_of_goal g)
 		  in
 		  try
@@ -70,30 +74,41 @@ let functional_induction with_clean c princl pat =
 		    (b,a)
 		    (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *)
 		  with Not_found -> (* This one is neither defined ! *)
-		    errorlabstrm "" (str "Cannot find induction principle for "
-				     ++Printer.pr_lconstr (mkConst c') )
+		    user_err  (str "Cannot find induction principle for "
+                                     ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') )
 	      in
-	      (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g')
-	   | _ -> raise (UserError("",str "functional induction must be used with a function" ))
+	      let princ = EConstr.of_constr princ in
+	      (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g')
+	   | _ -> raise (UserError(None,str "functional induction must be used with a function" ))
 	 end
       | Some ((princ,binding)) ->
 	 princ,binding,Tacmach.pf_unsafe_type_of g princ,g
     in
-    let princ_infos = Tactics.compute_elim_sig princ_type in
+    let sigma = Tacmach.project g' in
+    let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in
     let args_as_induction_constr =
       let c_list =
 	if princ_infos.Tactics.farg_in_concl
 	then [c] else []
       in
+      if List.length args + List.length c_list = 0
+      then user_err Pp.(str "Cannot recognize a valid functional scheme" );
       let encoded_pat_as_patlist =
-        List.make (List.length args + List.length c_list - 1) None @ [pat] in
-      List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None))
-        (args@c_list) encoded_pat_as_patlist
+        List.make (List.length args + List.length c_list - 1) None @ [pat]
+      in
+      List.map2
+        (fun c pat ->
+          ((None,
+            Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))),
+           (None,pat),
+           None))
+        (args@c_list)
+        encoded_pat_as_patlist
     in
     let princ' = Some (princ,bindings) in
     let princ_vars =
       List.fold_right
-	(fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc)
+	(fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc)
 	args
 	Id.Set.empty
     in
@@ -128,15 +143,14 @@ let functional_induction with_clean c princl pat =
 
 let rec abstract_glob_constr c = function
   | [] -> c
-  | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl)
-  | Constrexpr.LocalRawAssum (idl,k,t)::bl ->
+  | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl)
+  | Constrexpr.CLocalAssum (idl,k,t)::bl ->
       List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl
         (abstract_glob_constr c bl)
-  | Constrexpr.LocalPattern _::bl -> assert false
+  | Constrexpr.CLocalPattern _::bl -> assert false
 
 let interp_casted_constr_with_implicits env sigma impls c  =
-  Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls
-    ~allow_patvar:false c
+  Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c
 
 (*
    Construct a fixpoint as a Glob_term
@@ -149,14 +163,14 @@ let build_newrecursive
   let sigma = Evd.from_env env0 in
   let (rec_sign,rec_impls) =
     List.fold_left
-      (fun (env,impls) (((_,recname),_),bl,arityc,_) ->
-        let arityc = Constrexpr_ops.prod_constr_expr arityc bl in
+      (fun (env,impls) (({CAst.v=recname},_),bl,arityc,_) ->
+        let arityc = Constrexpr_ops.mkCProdN bl arityc in
         let arity,ctx = Constrintern.interp_type env0 sigma arityc in
-	let evdref = ref (Evd.from_env env0) in
-	let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in
-	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in
+        let evd = Evd.from_env env0 in
+        let evd, (_, (_, impls')) = Constrintern.interp_context_evars env evd bl in
+        let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in
         let open Context.Named.Declaration in
-        (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls))
+        (EConstr.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls))
       (env0,Constrintern.empty_internalization_env) lnameargsardef in
   let recdef =
     (* Declare local notations *)
@@ -175,37 +189,41 @@ let build_newrecursive l =
        match body_opt with 
 	 | Some body -> 
 	     (fixna,bll,ar,body)
-	 | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given")
+	 | None -> user_err ~hdr:"Function" (str "Body of Function must be given")
     ) l
   in
   build_newrecursive l'
 
+let error msg = user_err Pp.(str msg)
+
 (* Checks whether or not the mutual bloc is recursive *)
 let is_rec names =
   let names = List.fold_right Id.Set.add names Id.Set.empty in
   let check_id id names =  Id.Set.mem id names in
-  let rec lookup names = function
-    | GVar(_,id) -> check_id id names
+  let rec lookup names gt = match DAst.get gt with
+    | GVar(id) -> check_id id names
     | GRef _ | GEvar _ | GPatVar _ | GSort _ |  GHole _ -> false
-    | GCast(_,b,_) -> lookup names b
+    | GCast(b,_) -> lookup names b
     | GRec _ -> error "GRec not handled"
-    | GIf(_,b,_,lhs,rhs) ->
+    | GIf(b,_,lhs,rhs) ->
 	(lookup names b) || (lookup names lhs) || (lookup names rhs)
-    | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b)  ->
-	lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b
-    | GLetTuple(_,nal,_,t,b) -> lookup names t ||
+    | GProd(na,_,t,b) | GLambda(na,_,t,b) ->
+	lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b
+    | GLetIn(na,b,t,c) ->
+	lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c
+    | GLetTuple(nal,_,t,b) -> lookup names t ||
 	lookup
 	  (List.fold_left
-	     (fun acc na -> Nameops.name_fold Id.Set.remove na acc)
+	     (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc)
 	     names
 	     nal
 	  )
 	  b
-    | GApp(_,f,args) -> List.exists (lookup names) (f::args)
-    | GCases(_,_,_,el,brl) ->
+    | GApp(f,args) -> List.exists (lookup names) (f::args)
+    | GCases(_,_,el,brl) ->
 	List.exists (fun (e,_) -> lookup names e) el ||
 	  List.exists (lookup_br names) brl
-  and lookup_br names (_,idl,_,rt) =
+  and lookup_br names {CAst.v=(idl,_,rt)} =
     let new_names = List.fold_right Id.Set.remove idl names in
     lookup new_names rt
   in
@@ -214,9 +232,9 @@ let is_rec names =
 let rec local_binders_length = function
   (* Assume that no `{ ... } contexts occur *)
   | [] -> 0
-  | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl
-  | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
-  | Constrexpr.LocalPattern _::bl -> assert false
+  | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl
+  | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+  | Constrexpr.CLocalPattern _::bl -> assert false
 
 let prepare_body ((name,_,args,types,_),_) rt =
   let n = local_binders_length args in
@@ -242,7 +260,9 @@ let derive_inversion fix_names =
 	 let evd,c =
 	   Evd.fresh_global
 	     (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in 
-	 evd, destConst c::l
+        let c = EConstr.of_constr c in
+        let (cst, u) = destConst evd c in
+	 evd, (cst, EInstance.kind evd u) :: l
 	)
 	fix_names
 	(evd',[])
@@ -262,14 +282,14 @@ let derive_inversion fix_names =
 	       (Global.env ()) evd
 	       (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id)))
 	   in 
-	   evd,(fst (destInd id))::l
+	   let id = EConstr.of_constr id in
+	   evd,(fst (destInd evd id))::l
 	  )
 	  fix_names
 	  (evd',[])
       in
       Invfun.derive_correctness
 	Functional_principles_types.make_scheme
-	functional_induction
 	fix_names_as_constant
 	lind;
       with e when CErrors.noncritical e ->
@@ -321,7 +341,7 @@ let error_error names e =
   in
   match e with
     | Building_graph e ->
-	errorlabstrm ""
+	user_err 
 	  (str "Cannot define graph(s) for " ++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
 	     e_explain e)
@@ -329,9 +349,9 @@ let error_error names e =
 
 let generate_principle (evd:Evd.evar_map ref) pconstants on_error
     is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs  interactive_proof
-    (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
+    (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int ->
       Tacmach.tactic) : unit =
-  let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in
+  let names = List.map (function (({CAst.v=name},_),_,_,_,_),_ -> name) fix_rec_l in
   let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
   let funs_args = List.map fst fun_bodies in
   let funs_types =  List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in
@@ -344,7 +364,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error
 	(*i The next call to mk_rel_id is valid since we have just construct the graph
 	   Ensures by : do_built
 	i*)
-	let f_R_mut = Ident (Loc.ghost,mk_rel_id (List.nth names 0)) in
+        let f_R_mut = CAst.make @@ Ident (mk_rel_id (List.nth names 0)) in
 	let ind_kn =
 	  fst (locate_with_msg
 		 (pr_reference f_R_mut++str ": Not an inductive type!")
@@ -352,7 +372,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error
 		 f_R_mut)
 	in
 	let fname_kn (((fname,_),_,_,_,_),_) =
-	  let f_ref = Ident fname in
+          let f_ref = CAst.map (fun n -> Ident n) fname in
 	  locate_with_msg
 	    (pr_reference f_ref++str ": Not an inductive type!")
 	    locate_constant
@@ -367,7 +387,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error
 	     let evd = ref (Evd.from_env env) in
 	     let evd',uprinc = Evd.fresh_global env !evd princ in
              let _ = evd := evd' in 
-	     let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in
+	     let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in
+	     let princ_type = EConstr.Unsafe.to_constr princ_type in
     	     Functional_principles_types.generate_functional_principle
 	       evd
 		 interactive_proof
@@ -390,33 +411,40 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error
 
 let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) =
   match fixpoint_exprl with
-    | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec ->
-      let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
-      Command.do_definition
+    | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec ->
+      let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in 
+      ComDefinition.do_definition
+        ~program_mode:false
 	fname
 	(Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl
 	bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ()));
        let evd,rev_pconstants =
 	 List.fold_left
-	   (fun (evd,l) ((((_,fname),_),_,_,_,_),_) ->
+           (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) ->
 	    let evd,c =
 	      Evd.fresh_global
 		(Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in
-	    evd,((destConst c)::l)
+            let c = EConstr.of_constr c in
+            let (cst, u) = destConst evd c in
+            let u = EInstance.kind evd u in
+            evd,((cst, u) :: l)
 	   )
 	   (Evd.from_env (Global.env ()),[])
 	   fixpoint_exprl
        in
        evd,List.rev rev_pconstants
     | _ ->
-       Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl;
+       ComFixpoint.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl;
        let evd,rev_pconstants =
 	 List.fold_left
-	   (fun (evd,l) ((((_,fname),_),_,_,_,_),_) ->
+           (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) ->
 	    let evd,c =
 	      Evd.fresh_global
 		(Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in
-	    evd,((destConst c)::l)
+            let c = EConstr.of_constr c in
+            let (cst, u) = destConst evd c in
+            let u = EInstance.kind evd u in
+            evd,((cst, u) :: l)
 	   )
 	   (Evd.from_env (Global.env ()),[])
 	   fixpoint_exprl
@@ -426,7 +454,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp
 
 let generate_correction_proof_wf f_ref tcc_lemma_ref
     is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
-    (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic =
+    (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic =
   Functional_principles_proofs.prove_principle_for_gen
     (f_ref,functional_ref,eq_ref)
     tcc_lemma_ref is_mes  rec_arg_num rec_arg_type relation
@@ -435,11 +463,11 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref
 let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
     pre_hook
     =
-  let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in
+  let type_of_f = Constrexpr_ops.mkCProdN args ret_type in
   let rec_arg_num =
     let names =
       List.map
-	snd
+        CAst.(with_val (fun x -> x))
 	(Constrexpr_ops.names_of_local_assums args)
     in
     match wf_arg with
@@ -451,22 +479,21 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
   in
   let unbounded_eq =
     let f_app_args =
-      Constrexpr.CAppExpl
-	(Loc.ghost,
-	 (None,(Ident (Loc.ghost,fname)),None) ,
+      CAst.make @@ Constrexpr.CAppExpl(
+         (None,CAst.make @@ Ident fname,None) ,
 	 (List.map
 	    (function
-	       | _,Anonymous -> assert false
-	       | _,Name e -> (Constrexpr_ops.mkIdentC e)
+               | {CAst.v=Anonymous} -> assert false
+               | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e)
 	    )
 	    (Constrexpr_ops.names_of_local_assums args)
 	 )
 	)
     in
-    Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))),
+    CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (CAst.make @@ Qualid (qualid_of_string "Logic.eq"))),
 		    [(f_app_args,None);(body,None)])
   in
-  let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in
+  let eq = Constrexpr_ops.mkCProdN args unbounded_eq in
   let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type
       nb_args relation =
     try
@@ -495,7 +522,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
       | None ->
 	  begin
 	    match args with
-	      | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
+              | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x
 	      | _ -> error "Recursive argument must be specified"
 	  end
       | Some wf_args ->
@@ -503,15 +530,15 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
 	    match
 	      List.find
 		(function
-		   | Constrexpr.LocalRawAssum(l,k,t) ->
+		   | Constrexpr.CLocalAssum(l,k,t) ->
 		       List.exists
-			 (function (_,Name id) -> Id.equal id wf_args | _ -> false)
+                         (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false)
 			 l
 		   | _ -> false
 		)
 		args
 	    with
-	      | Constrexpr.LocalRawAssum(_,k,t)  ->	    t,wf_args
+	      | Constrexpr.CLocalAssum(_,k,t)  ->	    t,wf_args
 	      | _ -> assert false
 	  with Not_found -> assert false
   in
@@ -520,13 +547,13 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
       | None ->
 	  let ltof =
 	    let make_dir l = DirPath.make (List.rev_map Id.of_string l) in
-	    Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path
+            CAst.make @@ Libnames.Qualid (Libnames.qualid_of_path
 			       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")))
 	  in
 	  let fun_from_mes =
 	    let applied_mes =
 	      Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg])    in
-	    Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes)
+            Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes)
 	  in
 	  let wf_rel_from_mes =
 	    Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC  ltof,[wf_arg_type;fun_from_mes])
@@ -537,7 +564,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
 	    let a = Names.Id.of_string "___a" in 
 	    let b = Names.Id.of_string "___b" in 
 	    Constrexpr_ops.mkLambdaC(
-	      [Loc.ghost,Name a;Loc.ghost,Name b],
+              [CAst.make @@ Name a; CAst.make @@ Name b],
 	      Constrexpr.Default Explicit,
 	      wf_arg_type,
 	      Constrexpr_ops.mkAppC(wf_rel_expr,
@@ -557,60 +584,54 @@ let map_option f = function
   | Some v -> Some (f v)
 
 open Constrexpr
-open Topconstr
 
-let make_assoc assoc l1 l2 =
-  let fold assoc a b = match a, b with
-  | (_, Name na), (_, Name id) -> Id.Map.add na id assoc
-  | _, _ -> assoc
-  in
-  List.fold_left2 fold assoc l1 l2
-
-let rec rebuild_bl (aux,assoc) bl typ = 
-	match bl,typ with 
-	  | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc)
-	  | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ ->
-	     rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ
-	  | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') ->
-	    rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc)
+let rec rebuild_bl aux bl typ =
+	match bl,typ with
+	  | [], _ -> List.rev aux,typ
+	  | (CLocalAssum(nal,bk,_))::bl',typ ->
+	     rebuild_nal aux bk bl' nal  typ
+	  | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } ->
+	    rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux)
 	      bl' typ'
 	  | _ -> assert false
-      and rebuild_nal (aux,assoc) bk bl' nal lnal typ = 
+and rebuild_nal aux bk bl' nal typ =
 	match nal,typ with 
-	  | [], _ -> rebuild_bl (aux,assoc) bl' typ
-	  | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ
-	  | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> 
-	    let lnal' = List.length nal' in 
-	    if lnal' >= lnal 
-	    then 
-	      let old_nal',new_nal' = List.chop lnal nal' in
-	      let nassoc = make_assoc assoc old_nal' nal in
-	      let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in
-	      rebuild_bl ((assum :: aux), nassoc) bl' 
-		(if List.is_empty new_nal' && List.is_empty rest
-		 then typ'
-		 else if List.is_empty new_nal'
-		 then CProdN(Loc.ghost,rest,typ')
-		 else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ'))
-	    else 
-	      let captured_nal,non_captured_nal = List.chop lnal' nal in
-	      let nassoc = make_assoc assoc nal' captured_nal in
-	      let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in
-	      rebuild_nal ((assum :: aux), nassoc)
-		bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ'))
-	  | _ -> assert false
-
-let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ
+	  | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ
+	  | [], _ -> rebuild_bl aux bl' typ
+          | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } ->
+             if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v)
+	     then
+	       let assum = CLocalAssum([na],bk,nal't) in
+               let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in
+	       rebuild_nal
+		 (assum::aux)
+		 bk
+		 bl'
+		 nal
+		 (CAst.make @@ CProdN(new_rest,typ'))
+	     else
+	       let assum = CLocalAssum([na'],bk,nal't) in
+               let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in
+	       rebuild_nal
+		 (assum::aux)
+		 bk
+		 bl'
+		 (na::nal)
+		 (CAst.make @@ CProdN(new_rest,typ'))
+	  | _ ->
+	     assert false
+
+let rebuild_bl aux bl typ = rebuild_bl aux bl typ
 
 let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = 
-  let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in
-  let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in
+  let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in
+  let ((_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in
   let constr_expr_typel = 
-    with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in
+    with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in
   let fixpoint_exprl_with_new_bl = 
     List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> 
      
-      let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in 
+      let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in 
       (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
     )
       fixpoint_exprl constr_expr_typel 
@@ -624,13 +645,13 @@ let do_generate_principle pconstants on_error register_built interactive_proof
   let _is_struct =
     match fixpoint_exprl with
       | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] ->
- 	  let (((((_,name),pl),_,args,types,body)),_)  as fixpoint_expr =
+          let (((({CAst.v=name},pl),_,args,types,body)),_)  as fixpoint_expr =
 	    match recompute_binder_list [fixpoint_expr] with 
 	      | [e] -> e
 	      | _ -> assert false
 	  in 
 	  let fixpoint_exprl = [fixpoint_expr] in 
-	  let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
+	  let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in 
 	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
 	  let using_lemmas = [] in 
 	  let pre_hook pconstants =
@@ -645,10 +666,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof
 	      true
 	  in
 	  if register_built
-	  then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook;
+          then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook;
 	  false
       |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] ->
- 	  let (((((_,name),_),_,args,types,body)),_)  as fixpoint_expr =
+          let (((({CAst.v=name},_),_,args,types,body)),_)  as fixpoint_expr =
 	    match recompute_binder_list [fixpoint_expr] with 
 	      | [e] -> e
 	      | _ -> assert false
@@ -656,7 +677,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof
 	  let fixpoint_exprl = [fixpoint_expr] in 
 	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
 	  let using_lemmas = [] in
-	  let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
+	  let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in 
 	  let pre_hook pconstants =
 	    generate_principle
 	      (ref (Evd.from_env (Global.env ())))
@@ -669,7 +690,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof
 	      true
 	  in
 	  if register_built
-	  then register_mes name rec_impls wf_mes wf_rel_opt (map_option snd wf_x) using_lemmas args types body pre_hook;
+          then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook;
 	  true
       | _ ->
 	  List.iter (function ((_na,(_,ord),_args,_body,_type),_not) ->
@@ -682,7 +703,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof
 	    fixpoint_exprl;
 	let fixpoint_exprl = recompute_binder_list fixpoint_exprl in 
 	let fix_names =
-	  List.map (function ((((_,name),_),_,_,_,_),_) -> name) fixpoint_exprl
+          List.map (function ((({CAst.v=name},_),_,_,_,_),_) -> name) fixpoint_exprl
 	in
 	(* ok all the expressions are structural *)
   	let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
@@ -708,67 +729,69 @@ let do_generate_principle pconstants on_error register_built interactive_proof
   in
   ()
 
-let rec add_args id new_args b =
-  match b with
-  | CRef (r,_) ->
-      begin      match r with
-	| Libnames.Ident(loc,fname) when Id.equal fname id ->
-	    CAppExpl(Loc.ghost,(None,r,None),new_args)
+let rec add_args id new_args = CAst.map (function
+  | CRef (r,_) as b ->
+      begin match r with
+        | {CAst.v=Libnames.Ident fname} when Id.equal fname id ->
+	    CAppExpl((None,r,None),new_args)
 	| _ -> b
       end
-  | CFix  _  | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo")
-  | CProdN(loc,nal,b1) ->
-      CProdN(loc,
-	     List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
+  | CFix  _  | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.")
+  | CProdN(nal,b1) ->
+        CProdN(List.map (function  CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2)
+                                 | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t)
+                                 | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal,
 	     add_args id new_args  b1)
-  | CLambdaN(loc,nal,b1) ->
-      CLambdaN(loc,
-	       List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args  b2)) nal,
+  | CLambdaN(nal,b1) ->
+      CLambdaN(List.map (function  CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2)
+                                 | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t)
+                                 | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal,
 	       add_args id new_args  b1)
-  | CLetIn(loc,na,b1,b2) ->
-      CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
-  | CAppExpl(loc,(pf,r,us),exprl) ->
+  | CLetIn(na,b1,t,b2) ->
+      CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2)
+  | CAppExpl((pf,r,us),exprl) ->
       begin
 	match r with
-	| Libnames.Ident(loc,fname) when Id.equal fname id ->
-	    CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl))
-	| _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl)
+        | {CAst.v=Libnames.Ident fname} when Id.equal fname id ->
+	    CAppExpl((pf,r,us),new_args@(List.map (add_args id new_args) exprl))
+	| _ -> CAppExpl((pf,r,us),List.map (add_args id new_args) exprl)
       end
-  | CApp(loc,(pf,b),bl) ->
-      CApp(loc,(pf,add_args id new_args b),
+  | CApp((pf,b),bl) ->
+      CApp((pf,add_args id new_args b),
 	   List.map (fun (e,o) -> add_args id new_args e,o) bl)
-  | CCases(loc,sty,b_option,cel,cal) ->
-      CCases(loc,sty,Option.map (add_args id new_args) b_option,
+  | CCases(sty,b_option,cel,cal) ->
+      CCases(sty,Option.map (add_args id new_args) b_option,
 	     List.map (fun (b,na,b_option) ->
 			 add_args id new_args b,
 			 na, b_option) cel,
-	     List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
+             List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal
 	    )
-  | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
-      CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option),
+  | CLetTuple(nal,(na,b_option),b1,b2) ->
+      CLetTuple(nal,(na,Option.map (add_args id new_args) b_option),
 		add_args id new_args b1,
 		add_args id new_args b2
 	       )
 
-  | CIf(loc,b1,(na,b_option),b2,b3) ->
-      CIf(loc,add_args id new_args b1,
+  | CIf(b1,(na,b_option),b2,b3) ->
+      CIf(add_args id new_args b1,
 	  (na,Option.map (add_args id new_args) b_option),
 	  add_args id new_args b2,
 	  add_args id new_args b3
 	 )
-  | CHole _ -> b
-  | CPatVar _ -> b
-  | CEvar _ -> b
-  | CSort _ -> b
-  | CCast(loc,b1,b2)  ->
-      CCast(loc,add_args id new_args b1,
+  | CHole _
+  | CPatVar _
+  | CEvar _
+  | CPrim _
+  | CSort _ as b -> b
+  | CCast(b1,b2)  ->
+      CCast(add_args id new_args b1,
 	    Miscops.map_cast_type (add_args id new_args) b2)
-  | CRecord (loc, pars) ->
-      CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars)
-  | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation")
-  | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization")
-  | CPrim _ -> b
-  | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters")
+  | CRecord pars ->
+      CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars)
+  | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.")
+  | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization.")
+  | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.")
+  )
 exception Stop of  Constrexpr.constr_expr
 
 
@@ -779,8 +802,8 @@ let rec chop_n_arrow n t =
   if n <= 0
   then t (* If we have already removed all the arrows then return the type *)
   else (* If not we check the form of [t] *)
-    match t with
-      | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
+    match t.CAst.v with
+      | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible :
 					     either we need to discard more than the number of arrows contained
 					     in this product declaration then we just recall [chop_n_arrow] on
 					     the remaining number of arrow to chop and [t'] we discard it and
@@ -792,104 +815,103 @@ let rec chop_n_arrow n t =
 	      let new_n =
 		let rec aux (n:int) = function
 		    [] -> n
-		| (nal,k,t'')::nal_ta' ->
+                | CLocalAssum(nal,k,t'')::nal_ta' ->
 		    let nal_l = List.length nal in
 		    if n >= nal_l
 		    then
 		      aux (n - nal_l) nal_ta'
 		    else
-		      let new_t' =
-			Constrexpr.CProdN(Loc.ghost,
-					((snd (List.chop n nal)),k,t'')::nal_ta',t')
+		      let new_t' = CAst.make @@
+			Constrexpr.CProdN(
+                                        CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t')
 		      in
 		      raise (Stop new_t')
+                | _ -> anomaly (Pp.str "Not enough products.")
 		in
 		aux n nal_ta'
 	    in
 	      chop_n_arrow new_n t'
 	    with Stop t -> t
 	  end
-      | _ -> anomaly (Pp.str "Not enough products")
+      | _ -> anomaly (Pp.str "Not enough products.")
 
 
-let rec get_args b t : Constrexpr.local_binder list *
+let rec get_args b t : Constrexpr.local_binder_expr list *
     Constrexpr.constr_expr * Constrexpr.constr_expr =
-  match b with
-    | Constrexpr.CLambdaN (loc, (nal_ta), b') ->
+  match b.CAst.v with
+    | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') ->
 	begin
-	  let n =
-	    (List.fold_left (fun n (nal,_,_) ->
-			       n+List.length nal) 0 nal_ta )
-	  in
-	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
-	  (List.map (fun (nal,k,ta) ->
-		       (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
+          let n = List.length nal in
+          let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in
+          d :: nal_tas, b'',t''
 	end
+    | Constrexpr.CLambdaN ([], b) -> [],b,t
     | _ -> [],b,t
 
 
 let make_graph (f_ref:global_reference) =
   let c,c_body =
     match f_ref with
-      | ConstRef c ->
-	  begin try c,Global.lookup_constant c
-	  with Not_found ->
-	    raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
-	  end
-      | _ -> raise (UserError ("", str "Not a function reference") )
+    | ConstRef c ->
+      begin try c,Global.lookup_constant c
+        with Not_found ->
+          let sigma, env = Pfedit.get_current_context () in
+          raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) )
+      end
+    | _ -> raise (UserError (None, str "Not a function reference") )
   in
   (match Global.body_of_constant_body c_body with
-     | None -> error "Cannot build a graph over an axiom !"
-     | Some body ->
+     | None -> error "Cannot build a graph over an axiom!"
+     | Some (body, _) ->
 	 let env = Global.env () in
 	 let sigma = Evd.from_env env in
 	 let extern_body,extern_type =
 	   with_full_print (fun () ->
-		(Constrextern.extern_constr false env sigma body,
+		(Constrextern.extern_constr false env sigma (EConstr.of_constr body),
 		 Constrextern.extern_type false env sigma
-                   ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type)
+                   (EConstr.of_constr (*FIXME*) c_body.const_type)
 		)
 	     )
 	     ()
 	 in
 	 let (nal_tas,b,t)  = get_args extern_body extern_type in
 	 let expr_list =
-	   match b with
-	     | Constrexpr.CFix(loc,l_id,fixexprl) ->
+	   match b.CAst.v with
+	     | Constrexpr.CFix(l_id,fixexprl) ->
 		 let l =
 		   List.map
 		     (fun (id,(n,recexp),bl,t,b) ->
-			let loc, rec_id = Option.get n in
+                        let { CAst.loc; v=rec_id } = Option.get n in
 			let new_args =
 			  List.flatten
 			    (List.map
 			       (function
-				  | Constrexpr.LocalRawDef (na,_)-> []
-				  | Constrexpr.LocalRawAssum (nal,_,_) ->
+				  | Constrexpr.CLocalDef (na,_,_)-> []
+				  | Constrexpr.CLocalAssum (nal,_,_) ->
 				      List.map
-					(fun (loc,n) ->
-					   CRef(Libnames.Ident(loc, Nameops.out_name n),None))
+                                        (fun {CAst.loc;v=n} -> CAst.make ?loc @@
+                                           CRef(CAst.make ?loc @@ Libnames.Ident(Nameops.Name.get_id n),None))
 					nal
-                                  | Constrexpr.LocalPattern _ -> assert false
+                                  | Constrexpr.CLocalPattern _ -> assert false
 			       )
 			       nal_tas
 			    )
 			in
-			let b' = add_args (snd id) new_args b in
-			((((id,None), ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
+                        let b' = add_args id.CAst.v new_args b in
+                        ((((id,None), ( Some CAst.(make rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
 		     )
 		     fixexprl
 		 in
 		 l
 	     | _ ->
-		let id = Label.to_id (con_label c) in
-		 [(((Loc.ghost,id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]]
+		let id = Label.to_id (Constant.label c) in
+                 [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]]
 	 in
-	 let mp,dp,_ = repr_con c in
+	 let mp,dp,_ = Constant.repr3 c in
 	 do_generate_principle [c,Univ.Instance.empty] error_error  false false expr_list;
 	 (* We register the infos *)
 	 List.iter
-	   (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id)))
+           (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make3 mp dp (Label.of_id id)))
 	   expr_list)
 
 let do_generate_principle = do_generate_principle [] warning_error true
diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli
index 1c27bdfa..dcc1c2ea 100644
--- a/plugins/funind/indfun.mli
+++ b/plugins/funind/indfun.mli
@@ -1,8 +1,8 @@
 open Misctypes
 
-val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit
+val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit
 
-val warn_cannot_define_principle : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit
+val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit
 
 val do_generate_principle :  
   bool -> 
@@ -12,10 +12,10 @@ val do_generate_principle :
 
 val functional_induction :  
   bool ->
-  Term.constr ->
-  (Term.constr * Term.constr bindings) option ->
-  Tacexpr.or_and_intro_pattern option ->
-  Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma
+  EConstr.constr ->
+  (EConstr.constr * EConstr.constr bindings) option ->
+  Ltac_plugin.Tacexpr.or_and_intro_pattern option ->
+  Goal.goal Evd.sigma -> Goal.goal list Evd.sigma
 
 
 val make_graph :  Globnames.global_reference -> unit
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index f56e9241..a0b9217c 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -1,8 +1,10 @@
 open Names
 open Pp
+open Constr
 open Libnames
 open Globnames
 open Refiner
+
 let mk_prefix pre id = Id.of_string (pre^(Id.to_string id))
 let mk_rel_id = mk_prefix "R_"
 let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
@@ -12,7 +14,7 @@ let mk_equation_id id = Nameops.add_suffix id "_equation"
 let msgnl m =
   ()
 
-let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid
+let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid)
 
 let fresh_name avoid s = Name (fresh_id avoid s)
 
@@ -21,19 +23,16 @@ let get_name avoid ?(default="H") = function
   | Name n -> Name n
 
 let array_get_start a =
-  try
-    Array.init
-      (Array.length a - 1)
-      (fun i -> a.(i))
-  with Invalid_argument "index out of bounds" ->
-    invalid_arg "array_get_start"
+  Array.init
+    (Array.length a - 1)
+    (fun i -> a.(i))
 
 let id_of_name = function
     Name id -> id
   | _ -> raise Not_found
 
 let locate  ref =
-    let (loc,qid) = qualid_of_reference ref in
+    let {CAst.v=qid} = qualid_of_reference ref in
     Nametab.locate qid
 
 let locate_ind ref =
@@ -49,7 +48,7 @@ let locate_constant ref =
 
 let locate_with_msg msg f x =
   try f x
-  with Not_found -> raise (CErrors.UserError("", msg))
+  with Not_found -> raise (CErrors.UserError(None, msg))
 
 
 let filter_map filter f =
@@ -69,11 +68,11 @@ let chop_rlambda_n  =
       if n == 0
       then List.rev acc,rt
       else
-	match rt with
-	  | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
-	  | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
+	match DAst.get rt with
+	  | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b
+	  | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b
 	  | _ ->
-	      raise (CErrors.UserError("chop_rlambda_n",
+	      raise (CErrors.UserError(Some "chop_rlambda_n",
 				    str "chop_rlambda_n: Not enough Lambdas"))
   in
   chop_lambda_n []
@@ -83,9 +82,9 @@ let chop_rprod_n  =
       if n == 0
       then List.rev acc,rt
       else
-	match rt with
-	  | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
-	  | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
+	match DAst.get rt with
+	  | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
+	  | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products"))
   in
   chop_prod_n []
 
@@ -101,20 +100,15 @@ let list_union_eq eq_fun l1 l2 =
 let list_add_set_eq eq_fun x l =
   if List.exists (eq_fun x) l then l else x::l
 
-
-
-
 let const_of_id id =
-  let _,princ_ref =
-    qualid_of_reference (Libnames.Ident (Loc.ghost,id))
-  in
+  let princ_ref = qualid_of_ident id in
   try Constrintern.locate_reference princ_ref
   with Not_found ->
-    CErrors.errorlabstrm "IndFun.const_of_id"
-      (str "cannot find " ++ Nameops.pr_id id)
+    CErrors.user_err ~hdr:"IndFun.const_of_id"
+      (str "cannot find " ++ Id.print id)
 
 let def_of_const t =
-   match (Term.kind_of_term t) with
+   match Constr.kind t with
     Term.Const sp ->
       (try (match Environ.constant_opt_value_in (Global.env()) sp with
              | Some c -> c
@@ -123,15 +117,16 @@ let def_of_const t =
     |_ -> assert false
 
 let coq_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition"
+  Universes.constr_of_global @@
+  Coqlib.gen_reference_in_modules "RecursiveDefinition"
     Coqlib.init_modules s;;
 
 let find_reference sl s =
   let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
   Nametab.locate (make_qualid dp (Id.of_string s))
 
-let eq = lazy(coq_constant "eq")
-let refl_equal = lazy(coq_constant "eq_refl")
+let eq = lazy(EConstr.of_constr (coq_constant "eq"))
+let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl"))
 
 (*****************************************************************)
 (* Copy of the standart save mechanism but without the much too  *)
@@ -162,7 +157,7 @@ let save with_clean id const (locality,_,kind) hook =
         let kn = declare_constant id ~local (DefinitionEntry const, k) in
 	(locality, ConstRef kn)
   in
-  if with_clean then  Pfedit.delete_current_proof ();
+  if with_clean then Proof_global.discard_current ();
   CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
   definition_message id
 
@@ -174,7 +169,7 @@ let cook_proof _ =
 
 let get_proof_clean do_reduce =
   let result = cook_proof do_reduce in
-  Pfedit.delete_current_proof ();
+  Proof_global.discard_current ();
   result
 
 let with_full_print f a =
@@ -183,12 +178,13 @@ let with_full_print f a =
   and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
   let old_rawprint = !Flags.raw_print in
   let old_printuniverses = !Constrextern.print_universes in
+  let old_printallowmatchdefaultclause = !Detyping.print_allow_match_default_clause in
   Constrextern.print_universes := true;
+  Detyping.print_allow_match_default_clause := false;
   Flags.raw_print := true;
   Impargs.make_implicit_args false;
   Impargs.make_strict_implicit_args false;
   Impargs.make_contextual_implicit_args false;
-  Impargs.make_contextual_implicit_args false;
   Dumpglob.pause ();
   try
     let res = f a in
@@ -197,6 +193,7 @@ let with_full_print f a =
     Impargs.make_contextual_implicit_args old_contextual_implicit_args;
     Flags.raw_print := old_rawprint;
     Constrextern.print_universes := old_printuniverses;
+    Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause;
     Dumpglob.continue ();
     res
   with
@@ -206,6 +203,7 @@ let with_full_print f a =
 	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
 	Flags.raw_print := old_rawprint;
 	Constrextern.print_universes := old_printuniverses;
+        Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause;
 	Dumpglob.continue ();
 	raise reraise
 
@@ -218,14 +216,14 @@ let with_full_print f a =
 
 type function_info =
     {
-      function_constant : constant;
+      function_constant : Constant.t;
       graph_ind : inductive;
-      equation_lemma : constant option;
-      correctness_lemma : constant option;
-      completeness_lemma : constant option;
-      rect_lemma : constant option;
-      rec_lemma : constant option;
-      prop_lemma : constant option;
+      equation_lemma : Constant.t option;
+      correctness_lemma : Constant.t option;
+      completeness_lemma : Constant.t option;
+      rect_lemma : Constant.t option;
+      rec_lemma : Constant.t option;
+      prop_lemma : Constant.t option;
       is_general : bool; (* Has this function been defined using general recursive definition *)
     }
 
@@ -332,18 +330,18 @@ let discharge_Function (_,finfos) =
 	   is_general = finfos.is_general
 	 }
 
-open Term
-
 let pr_ocst c =
-  Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ())
+  let sigma, env = Pfedit.get_current_context () in
+  Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ())
 
 let pr_info f_info =
+  let sigma, env = Pfedit.get_current_context () in
   str "function_constant := " ++
-  Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
+  Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++
   str "function_constant_type := " ++
   (try
-     Printer.pr_lconstr
-       (Global.type_of_global_unsafe (ConstRef f_info.function_constant))
+     Printer.pr_lconstr_env env sigma
+       (fst (Global.type_of_global_in_context env (ConstRef f_info.function_constant)))
    with e when CErrors.noncritical e -> mt ()) ++ fnl () ++
   str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++
   str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++
@@ -351,7 +349,7 @@ let pr_info f_info =
   str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++
   str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++
   str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++
-  str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
+  str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl ()
 
 let pr_table tb =
   let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in
@@ -371,7 +369,7 @@ let in_Function : function_info -> Libobject.obj =
 
 let find_or_none id =
   try Some
-    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant")
+    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.")
     )
   with Not_found -> None
 
@@ -390,7 +388,7 @@ let update_Function finfo =
 			 
 
 let add_Function is_general f =
-  let f_id = Label.to_id (con_label f) in
+  let f_id = Label.to_id (Constant.label f) in
   let equation_lemma = find_or_none (mk_equation_id f_id)
   and correctness_lemma = find_or_none (mk_correct_id f_id)
   and completeness_lemma = find_or_none (mk_complete_id f_id)
@@ -399,7 +397,7 @@ let add_Function is_general f =
   and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
   and graph_ind =
     match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
-    with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive")
+    with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.")
   in
   let finfos =
     { function_constant = f;
@@ -425,7 +423,6 @@ open Goptions
 
 let functional_induction_rewrite_dependent_proofs_sig = 
   {
-    optsync = false;
     optdepr = false;
     optname = "Functional Induction Rewrite Dependent";
     optkey =  ["Functional";"Induction";"Rewrite";"Dependent"];
@@ -438,7 +435,6 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t
 
 let function_debug_sig =
   {
-    optsync = false;
     optdepr = false;
     optname = "Function debug";
     optkey =  ["Function_debug"];
@@ -457,7 +453,6 @@ let strict_tcc = ref false
 let is_strict_tcc () = !strict_tcc
 let strict_tcc_sig =
   {
-    optsync = false;
     optdepr = false;
     optname = "Raw Function Tcc";
     optkey =  ["Function_raw_tcc"];
@@ -475,13 +470,17 @@ exception ToShow of exn
 let jmeq () =
   try
     Coqlib.check_required_library Coqlib.jmeq_module_name;
-    Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq"
+    EConstr.of_constr @@
+    Universes.constr_of_global @@
+      Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq"
   with e when CErrors.noncritical e -> raise (ToShow e)
 
 let jmeq_refl () =
   try
     Coqlib.check_required_library Coqlib.jmeq_module_name;
-    Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl"
+    EConstr.of_constr @@
+    Universes.constr_of_global @@
+      Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl"
   with e when CErrors.noncritical e -> raise (ToShow e)
 
 let h_intros l =
@@ -489,10 +488,13 @@ let h_intros l =
 
 let h_id = Id.of_string "h"
 let hrec_id = Id.of_string "hrec"
-let well_founded = function () -> (coq_constant "well_founded")
-let acc_rel = function () -> (coq_constant "Acc")
-let acc_inv_id = function () -> (coq_constant "Acc_inv")
-let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
+let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded")
+let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc")
+let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv")
+
+let well_founded_ltof () = EConstr.of_constr @@ Universes.constr_of_global @@
+    Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof"
+
 let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
 
 let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *)
@@ -501,8 +503,58 @@ let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (G
     | VarRef id -> EvalVarRef id
     | _ -> assert false;;
 
-let list_rewrite (rev:bool) (eqs: (constr*bool) list) =
+let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) =
   tclREPEAT
     (List.fold_right
        (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i)
        (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
+
+let decompose_lam_n sigma n =
+  if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive");
+  let rec lamdec_rec l n c =
+    if Int.equal n 0 then l,c
+    else match EConstr.kind sigma c with
+      | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
+      | Cast (c,_,_)     -> lamdec_rec l n c
+      | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions")
+  in
+  lamdec_rec [] n
+
+let lamn n env b =
+  let open EConstr in
+  let rec lamrec = function
+    | (0, env, b)        -> b
+    | (n, ((v,t)::l), b) -> lamrec (n-1,  l, mkLambda (v,t,b))
+    | _ -> assert false
+  in
+  lamrec (n,env,b)
+
+(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *)
+let compose_lam l b = lamn (List.length l) l b
+
+(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
+let prodn n env b =
+  let open EConstr in
+  let rec prodrec = function
+    | (0, env, b)        -> b
+    | (n, ((v,t)::l), b) -> prodrec (n-1,  l, mkProd (v,t,b))
+    | _ -> assert false
+  in
+  prodrec (n,env,b)
+
+(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *)
+let compose_prod l b = prodn (List.length l) l b
+
+type tcc_lemma_value =
+  | Undefined
+  | Value of constr
+  | Not_needed
+
+(* We only "purify" on exceptions. XXX: What is this doing here? *)
+let funind_purify f x =
+  let st = Vernacstate.freeze_interp_state `No in
+  try f x
+  with e ->
+    let e = CErrors.push e in
+    Vernacstate.unfreeze_interp_state st;
+    Exninfo.iraise e
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index e5c756f5..5cc7163a 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -1,5 +1,4 @@
 open Names
-open Pp
 
 (*
    The mk_?_id function build different name w.r.t. a function
@@ -11,7 +10,7 @@ val mk_complete_id : Id.t -> Id.t
 val mk_equation_id : Id.t -> Id.t
 
 
-val msgnl : std_ppcmds -> unit
+val msgnl : Pp.t -> unit
 
 val fresh_id : Id.t list -> string -> Id.t
 val fresh_name : Id.t list -> string -> Name.t
@@ -22,9 +21,9 @@ val array_get_start : 'a array -> 'a array
 val id_of_name : Name.t -> Id.t
 
 val locate_ind : Libnames.reference -> inductive
-val locate_constant : Libnames.reference -> constant
+val locate_constant : Libnames.reference -> Constant.t
 val locate_with_msg :
-  Pp.std_ppcmds -> (Libnames.reference -> 'a) ->
+  Pp.t -> (Libnames.reference -> 'a) ->
   Libnames.reference -> 'a
 
 val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
@@ -34,17 +33,17 @@ val list_add_set_eq :
   ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
 
 val chop_rlambda_n : int -> Glob_term.glob_constr ->
-  (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr
+  (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr
 
 val chop_rprod_n : int -> Glob_term.glob_constr ->
   (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr
 
-val def_of_const : Term.constr -> Term.constr
-val eq : Term.constr Lazy.t
-val refl_equal : Term.constr Lazy.t
+val def_of_const : Constr.t -> Constr.t
+val eq : EConstr.constr Lazy.t
+val refl_equal : EConstr.constr Lazy.t
 val const_of_id: Id.t ->  Globnames.global_reference(* constantyes *)
-val jmeq : unit -> Term.constr
-val jmeq_refl : unit -> Term.constr
+val jmeq : unit -> EConstr.constr
+val jmeq_refl : unit -> EConstr.constr
 
 val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry  -> Decl_kinds.goal_kind ->
   unit Lemmas.declaration_hook CEphemeron.key -> unit
@@ -69,28 +68,28 @@ val with_full_print : ('a -> 'b) -> 'a -> 'b
 
 type function_info =
     {
-      function_constant : constant;
+      function_constant : Constant.t;
       graph_ind : inductive;
-      equation_lemma : constant option;
-      correctness_lemma : constant option;
-      completeness_lemma : constant option;
-      rect_lemma : constant option;
-      rec_lemma : constant option;
-      prop_lemma : constant option;
+      equation_lemma : Constant.t option;
+      correctness_lemma : Constant.t option;
+      completeness_lemma : Constant.t option;
+      rect_lemma : Constant.t option;
+      rec_lemma : Constant.t option;
+      prop_lemma : Constant.t option;
       is_general : bool;
     }
 
-val find_Function_infos : constant -> function_info
+val find_Function_infos : Constant.t -> function_info
 val find_Function_of_graph : inductive -> function_info
 (* WARNING: To be used just after the graph definition !!! *)
-val add_Function : bool -> constant -> unit
+val add_Function : bool -> Constant.t -> unit
 
 val update_Function : function_info -> unit
 
 
 (** debugging *)
-val pr_info : function_info -> Pp.std_ppcmds
-val pr_table : unit -> Pp.std_ppcmds
+val pr_info : function_info -> Pp.t
+val pr_table : unit -> Pp.t
 
 
 (* val function_debug : bool ref  *)
@@ -104,13 +103,25 @@ exception ToShow of exn
 
 val is_strict_tcc : unit -> bool
 
-val h_intros: Names.Id.t list -> Proof_type.tactic
+val h_intros: Names.Id.t list -> Tacmach.tactic
 val h_id :  Names.Id.t
 val hrec_id :  Names.Id.t
-val acc_inv_id :  Term.constr Util.delayed
+val acc_inv_id :  EConstr.constr Util.delayed
 val ltof_ref : Globnames.global_reference Util.delayed
-val well_founded_ltof : Term.constr Util.delayed
-val acc_rel : Term.constr Util.delayed
-val well_founded : Term.constr Util.delayed
+val well_founded_ltof : EConstr.constr Util.delayed
+val acc_rel : EConstr.constr Util.delayed
+val well_founded : EConstr.constr Util.delayed
 val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference
-val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic
+val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic
+
+val decompose_lam_n : Evd.evar_map -> int -> EConstr.t ->
+  (Names.Name.t * EConstr.t) list * EConstr.t
+val compose_lam : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t
+val compose_prod : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t
+
+type tcc_lemma_value =
+  | Undefined
+  | Value of Constr.t
+  | Not_needed
+
+val funind_purify : ('a -> 'b) -> ('a -> 'b)
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index 26fc88a6..bed95740 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -1,17 +1,21 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
-open Tacexpr
+open Ltac_plugin
 open Declarations
 open CErrors
 open Util
 open Names
 open Term
+open Constr
+open EConstr
 open Vars
 open Pp
 open Globnames
@@ -23,30 +27,7 @@ open Misctypes
 open Termops
 open Context.Rel.Declaration
 
-(* Some pretty printing function for debugging purpose *)
-
-let pr_binding prc  =
-  function
-    | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
-    | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
-
-let pr_bindings prc prlc = function
-  | ImplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-      pr_sequence prc l
-  | ExplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-        pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | NoBindings -> mt ()
-
-
-let pr_with_bindings prc prlc (c,bl) =
-  prc c ++ hv 0 (pr_bindings prc prlc bl)
-
-
-
-let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds =
-  pr_with_bindings prc prc  (c,bl)
+module RelDecl = Context.Rel.Declaration
 
 (* The local debugging mechanism *)
 (* let msgnl = Pp.msgnl *)
@@ -77,12 +58,6 @@ let do_observe_tac s tac g =
 	     CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal ));
     iraise reraise;;
 
-
-let observe_tac_strm s tac g =
-  if do_observe ()
-  then do_observe_tac s tac g
-  else tac g
-
 let observe_tac s tac g =
   if do_observe ()
   then do_observe_tac (str s) tac g
@@ -106,12 +81,8 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl
 
 let make_eq () =
   try
-    Universes.constr_of_global (Coqlib.build_coq_eq ())
+    EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ()))
   with _ -> assert false 
-let make_eq_refl () =
-  try
-    Universes.constr_of_global (Coqlib.build_coq_eq_refl ())
-  with _ -> assert false
 
 	  
 (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true]
@@ -129,15 +100,16 @@ let make_eq_refl () =
 let generate_type evd g_to_f f graph i =
   (*i we deduce the number of arguments of the function and its returned type from the graph i*)
   let evd',graph =
-    Evd.fresh_global  (Global.env ()) !evd  (Globnames.IndRef (fst (destInd graph)))
+    Evd.fresh_global  (Global.env ()) !evd  (Globnames.IndRef (fst (destInd !evd graph)))
   in
+  let graph = EConstr.of_constr graph in
   evd:=evd';
   let graph_arity = Typing.e_type_of (Global.env ()) evd graph in
-  let ctxt,_ = decompose_prod_assum graph_arity in
+  let ctxt,_ = decompose_prod_assum !evd graph_arity in
   let fun_ctxt,res_type =
     match ctxt with
-      | [] | [_] -> anomaly (Pp.str "Not a valid context")
-      | decl :: fun_ctxt -> fun_ctxt, get_type decl
+      | [] | [_] -> anomaly (Pp.str "Not a valid context.")
+      | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl
   in
   let rec args_from_decl i accu = function
   | [] -> accu
@@ -148,13 +120,13 @@ let generate_type evd g_to_f f graph i =
     args_from_decl (succ i) (t :: accu) l
   in
   (*i We need to name the vars [res] and [fv] i*)
-  let filter = fun decl -> match get_name decl with
+  let filter = fun decl -> match RelDecl.get_name decl with
 			   | Name id -> Some id
 			   | Anonymous -> None
   in
-  let named_ctxt = List.map_filter filter fun_ctxt in
+  let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in
   let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in
-  let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in
+  let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in
   (*i we can then type the argument to be applied to the function [f] i*)
   let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in
   (*i
@@ -191,15 +163,16 @@ let generate_type evd g_to_f f graph i =
    WARNING: while convertible, [type_of body] and [type] can be non equal
 *)
 let find_induction_principle evd f =
-  let f_as_constant,u =  match kind_of_term f with
+  let f_as_constant,u =  match EConstr.kind !evd f with
     | Const c' -> c'
-    | _ -> error "Must be used with a function"
+    | _ -> user_err Pp.(str "Must be used with a function")
   in
   let infos = find_Function_infos f_as_constant in
   match infos.rect_lemma with
     | None -> raise Not_found
     | Some rect_lemma ->
        let evd',rect_lemma = Evd.fresh_global  (Global.env ()) !evd  (Globnames.ConstRef rect_lemma) in
+       let rect_lemma = EConstr.of_constr rect_lemma in
        let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in
        evd:=evd';
        rect_lemma,typ
@@ -209,14 +182,13 @@ let rec generate_fresh_id x avoid i =
   if i == 0
   then []
   else
-    let id = Namegen.next_ident_away_in_goal x avoid in
+    let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in
     id::(generate_fresh_id x (id::avoid) (pred i))
 
 
-(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
+(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ]
    is the tactic used to prove correctness lemma.
 
-   [functional_induction] is the tactic defined in [indfun] (dependency problem)
    [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
    (resp. graphs of the functions and principles and correctness lemma types) to prove correct.
 
@@ -237,29 +209,29 @@ let rec generate_fresh_id x avoid i =
    \end{enumerate}
 
 *)
-let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
+let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic =
   fun g ->
     (* first of all we recreate the lemmas types to be used as predicates of the induction principle
        that is~:
        \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
     *)
     (* we the get the definition of the graphs block *)
-    let graph_ind,u = destInd graphs_constr.(i) in
+    let graph_ind,u = destInd evd graphs_constr.(i) in
     let kn = fst graph_ind in
     let mib,_ = Global.lookup_inductive graph_ind in
     (* and the principle to use in this lemma in $\zeta$ normal form *)
     let f_principle,princ_type = schemes.(i) in
     let princ_type =  nf_zeta princ_type in
-    let princ_infos = Tactics.compute_elim_sig princ_type in
+    let princ_infos = Tactics.compute_elim_sig evd princ_type in
     (* The number of args of the function is then easily computable *)
-    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
+    let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in
     let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* Since we cannot ensure that the functional principle is defined in the
        environment and due to the bug #1174, we will need to pose the principle
        using a name
     *)
-    let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in
+    let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in
     let ids = principle_id :: ids in
     (* We get the branches of the principle *)
     let branches = List.rev princ_infos.branches in
@@ -268,14 +240,14 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       List.map
 	(fun decl ->
 	   List.map
-	     (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id))
-	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl)))))
+             (fun id -> CAst.make @@ IntroNaming (IntroIdentifier id))
+	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))
 	)
 	branches
     in
     (* before building the full intro pattern for the principle *)
     let eq_ind = make_eq () in
-    let eq_construct = mkConstructUi (destInd eq_ind, 1) in
+    let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in
     (* The next to referencies will be used to find out which constructor to apply in each branch *)
     let ind_number = ref 0
     and min_constr_number = ref 0 in
@@ -284,10 +256,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       (* We get the identifiers of this branch *)
       let pre_args =
       	List.fold_right
-      	  (fun (_,pat) acc ->
+          (fun {CAst.v=pat} acc ->
       	     match pat with
 	       | IntroNaming (IntroIdentifier id) -> id::acc
-      	       | _ -> anomaly (Pp.str "Not an identifier")
+      	       | _ -> anomaly (Pp.str "Not an identifier.")
       	  )
       	  (List.nth intro_pats (pred i))
       	  []
@@ -304,17 +276,18 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
 	List.fold_right 
 	  (fun hid acc ->
 	     let type_of_hid = pf_unsafe_type_of g (mkVar hid) in
-	     match kind_of_term type_of_hid with
+	     let sigma = project g in
+	     match EConstr.kind sigma type_of_hid with
 	       | Prod(_,_,t') ->
 		   begin
-		     match kind_of_term t' with
+		     match EConstr.kind sigma t' with
 		       | Prod(_,t'',t''') ->
 			   begin
-			     match kind_of_term t'',kind_of_term t''' with
+			     match EConstr.kind sigma t'',EConstr.kind sigma t''' with
 			       | App(eq,args), App(graph',_)
 				   when
-				     (eq_constr eq eq_ind) &&
-				       Array.exists  (Constr.eq_constr_nounivs graph') graphs_constr ->
+				     (EConstr.eq_constr sigma eq eq_ind) &&
+				       Array.exists  (EConstr.eq_constr_nounivs sigma graph') graphs_constr ->
 				   (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
 				    ::acc)
 			       | _ -> mkVar hid ::  acc
@@ -360,7 +333,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       in
       (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *)
       (
-	tclTHENSEQ
+	tclTHENLIST
 	  [
 	    observe_tac("h_intro_patterns ")  (let l = (List.nth intro_pats (pred i)) in 
 					       match l with 
@@ -379,7 +352,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
 	      Locusops.onConcl);
 	    observe_tac ("toto ") tclIDTAC;
     
-	    (* introducing the the result of the graph and the equality hypothesis *)
+            (* introducing the result of the graph and the equality hypothesis *)
 	    observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]);
 	    (* replacing [res] with its value *)
 	    observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres)));
@@ -395,11 +368,11 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       Array.map
 	(fun ((_,(ctxt,concl))) ->
 	   match ctxt with
-	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
+	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.")
 	     | hres::res::decl::ctxt ->
-		let res = Termops.it_mkLambda_or_LetIn
-			    (Termops.it_mkProd_or_LetIn concl [hres;res])
-			    (LocalAssum (get_name decl, get_type decl) :: ctxt)
+		let res = EConstr.it_mkLambda_or_LetIn
+			    (EConstr.it_mkProd_or_LetIn concl [hres;res])
+			    (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt)
 		in
 		res
 	)
@@ -415,7 +388,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       let params_bindings,avoid =
 	List.fold_left2
 	  (fun (bindings,avoid) decl p ->
-	     let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in
+	     let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in
 	     p::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
@@ -425,7 +398,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       let lemmas_bindings =
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) decl p ->
-	     let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in
+	     let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in
 	     (nf_zeta p)::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
@@ -433,7 +406,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
       in
       (params_bindings@lemmas_bindings)
     in
-    tclTHENSEQ
+    tclTHENLIST
       [ 
 	observe_tac "principle" (Proofview.V82.of_tactic (assert_by
 	  (Name principle_id)
@@ -465,7 +438,7 @@ let generalize_dependent_of x hyp g =
   tclMAP
     (function
        | LocalAssum (id,t) when not (Id.equal id hyp) &&
-	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id])
+	   (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id])
        | _ -> tclIDTAC
     )
     (pf_hyps g)
@@ -486,46 +459,47 @@ let tauto =
 
 let  rec intros_with_rewrite g =
   observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
-and intros_with_rewrite_aux : tactic =
+and intros_with_rewrite_aux : Tacmach.tactic =
   fun g ->
     let eq_ind = make_eq () in
-    match kind_of_term (pf_concl g) with
+    let sigma = project g in
+    match EConstr.kind sigma (pf_concl g) with
 	  | Prod(_,t,t') ->
 	      begin
-		match kind_of_term t with
-		  | App(eq,args) when (eq_constr eq eq_ind)  ->
+		match EConstr.kind sigma t with
+		  | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind)  ->
  		      if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
 		      then
 			let id = pf_get_new_id (Id.of_string "y") g  in
-			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g
-		      else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) 
-		      then tclTHENSEQ[
-			Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]);
-			tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) )))
+			tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g
+		      else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) 
+		      then tclTHENLIST[
+			Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]);
+			tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) )))
 			  (pf_ids_of_hyps g);
 			intros_with_rewrite
 		      ] g
-		      else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) 
-		      then tclTHENSEQ[
-			Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]);
-			tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )))
+		      else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) 
+		      then tclTHENLIST[
+			Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]);
+			tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) )))
 			  (pf_ids_of_hyps g);
 			intros_with_rewrite
 		      ] g
-		      else if isVar args.(1)
+		      else if isVar sigma args.(1)
 		      then
 			let id = pf_get_new_id (Id.of_string "y") g  in
-			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);
-				     generalize_dependent_of (destVar args.(1)) id;
+			tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);
+				     generalize_dependent_of (destVar sigma args.(1)) id;
 				     tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id)));
 				     intros_with_rewrite
 				   ]
 			  g
-		      else if isVar args.(2) 
+		      else if isVar sigma args.(2) 
 		      then 
 			let id = pf_get_new_id (Id.of_string "y") g  in
-			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);
-				     generalize_dependent_of (destVar args.(2)) id;
+			tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);
+				     generalize_dependent_of (destVar sigma args.(2)) id;
 				     tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id)));
 				     intros_with_rewrite
 				   ]
@@ -533,21 +507,21 @@ and intros_with_rewrite_aux : tactic =
 		      else
 			begin
 			  let id = pf_get_new_id (Id.of_string "y") g  in
-			  tclTHENSEQ[
+			  tclTHENLIST[
 			    Proofview.V82.of_tactic (Simple.intro id);
 			    tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id)));
 			    intros_with_rewrite
 			  ] g
 			end
-		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
+		  | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ())) ->
 		      Proofview.V82.of_tactic tauto g
 		  | Case(_,_,v,_) ->
-		      tclTHENSEQ[
+		      tclTHENLIST[
 			Proofview.V82.of_tactic (simplest_case v);
 			intros_with_rewrite
 		      ] g
 		  | LetIn _ ->
-		      tclTHENSEQ[
+		      tclTHENLIST[
 			Proofview.V82.of_tactic (reduce
 			  (Genredexpr.Cbv
 			     {Redops.all_flags
@@ -559,10 +533,10 @@ and intros_with_rewrite_aux : tactic =
 		      ] g
 		  | _ ->
 		      let id = pf_get_new_id (Id.of_string "y") g  in
-		      tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g
+		      tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g
 	      end
 	  | LetIn _ ->
-	      tclTHENSEQ[
+	      tclTHENLIST[
 		Proofview.V82.of_tactic (reduce
 		  (Genredexpr.Cbv
 		     {Redops.all_flags
@@ -577,9 +551,9 @@ and intros_with_rewrite_aux : tactic =
 let rec reflexivity_with_destruct_cases g =
   let destruct_case () =
     try
-      match kind_of_term (snd (destApp (pf_concl g))).(2) with
+      match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with
 	| Case(_,_,v,_) ->
-	    tclTHENSEQ[
+	    tclTHENLIST[
 	      Proofview.V82.of_tactic (simplest_case v);
 	      Proofview.V82.of_tactic intros;
 	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
@@ -588,18 +562,23 @@ let rec reflexivity_with_destruct_cases g =
     with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity
   in
   let eq_ind = make_eq () in
+  let my_inj_flags = Some {
+    Equality.keep_proof_equalities = false;
+    injection_in_context = false; (* for compatibility, necessary *)
+    injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *)
+  } in
   let discr_inject =
     Tacticals.onAllHypsAndConcl (
        fun sc g ->
 	 match sc with
 	     None -> tclIDTAC g
 	   | Some id ->
-	       match kind_of_term  (pf_unsafe_type_of g (mkVar id)) with
-		 | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
+	       match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with
+		 | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind ->
 		     if Equality.discriminable (pf_env g) (project g) t1 t2
 		     then Proofview.V82.of_tactic (Equality.discrHyp id) g
-		     else if Equality.injectable (pf_env g) (project g) t1 t2
-		     then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite]  g
+		     else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2
+		     then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite]  g
 		     else tclIDTAC g
 		 | _ -> tclIDTAC g
     )
@@ -646,25 +625,25 @@ let rec reflexivity_with_destruct_cases g =
 *)
 
 
-let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
+let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic =
   fun g ->
     (* We compute the types of the different mutually recursive lemmas
        in $\zeta$ normal form
     *)
     let lemmas =
       Array.map
-	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt))
+	(fun (_,(ctxt,concl)) -> nf_zeta (EConstr.it_mkLambda_or_LetIn concl ctxt))
 	lemmas_types_infos
     in
     (* We get the constant and the principle corresponding to this lemma *)
     let f = funcs.(i) in
-    let graph_principle = nf_zeta schemes.(i)  in
+    let graph_principle = nf_zeta (EConstr.of_constr schemes.(i))  in
     let princ_type = pf_unsafe_type_of g graph_principle in
-    let princ_infos = Tactics.compute_elim_sig princ_type in
+    let princ_infos = Tactics.compute_elim_sig (project g) princ_type in
     (* Then we get the number of argument of the function
        and compute a fresh name for each of them
     *)
-    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
+    let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in
     let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* and fresh names for res H and the principle (cf bug bug #1174) *)
@@ -682,7 +661,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	(fun decl ->
 	   List.map
 	     (fun id -> id)
-	     (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl)))
+	     (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl)))
 	)
 	branches
     in
@@ -690,20 +669,20 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
        using [f_equation] if it is recursive (that is the graph is infinite
        or unfold if the graph is finite
     *)
-    let rewrite_tac j ids : tactic =
+    let rewrite_tac j ids : Tacmach.tactic =
       let graph_def = graphs.(j) in
       let infos =
-        try find_Function_infos (fst (destConst funcs.(j)))
-        with Not_found ->  error "No graph found"
+        try find_Function_infos (fst (destConst (project g) funcs.(j)))
+        with Not_found ->  user_err Pp.(str "No graph found")
       in
       if infos.is_general
         || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs
       then
 	let eq_lemma =
 	  try Option.get (infos).equation_lemma
-	  with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma")
+	  with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.")
 	in
-	tclTHENSEQ[
+	tclTHENLIST[
 	  tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids;
 	  Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma));
 	  (* Don't forget to $\zeta$ normlize the term since the principles
@@ -719,7 +698,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	  thin ids
 	]
       else
-        Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))])
+        Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))])
     in
     (* The proof of each branche itself *)
     let ind_number = ref 0 in
@@ -739,7 +718,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	  end
       in
       let this_branche_ids = List.nth intro_pats (pred i) in
-      tclTHENSEQ[
+      tclTHENLIST[
 	(* we expand the definition of the function *)
         observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
 	(* introduce hypothesis with some rewrite *)
@@ -750,8 +729,9 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	g
     in
     let params_names = fst (List.chop princ_infos.nparams args_names) in
+    let open EConstr in
     let params = List.map mkVar params_names in
-    tclTHENSEQ
+    tclTHENLIST
       [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]);
 	observe_tac "h_generalize"
 	(Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]));
@@ -763,19 +743,20 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
       g
 
 
-(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
+(* [derive_correctness make_scheme funs graphs] create correctness and completeness
    lemmas for each function in [funs] w.r.t. [graphs]
 
    [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and
-   [functional_induction] is Indfun.functional_induction (same pb)
 *)
 
-let derive_correctness make_scheme functional_induction (funs: pconstant list) (graphs:inductive list) =
+let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list) =
   assert (funs <> []);
   assert (graphs <> []);
   let funs = Array.of_list funs and graphs = Array.of_list graphs in
-  let funs_constr = Array.map mkConstU funs  in
-  States.with_state_protection_on_exception
+  let map (c, u) = mkConstU (c, EInstance.make u) in
+  let funs_constr = Array.map map funs  in
+  (* XXX STATE Why do we need this... why is the toplevel protection not enought *)
+  funind_purify
     (fun () ->
      let env = Global.env () in
      let evd = ref (Evd.from_env env) in 
@@ -789,10 +770,10 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
 	 in
 	 let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in
 	 graphs_constr.(i) <- graph;
-	 let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in
+	 let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in
 	 let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in 
 	   let type_of_lemma = nf_zeta type_of_lemma in
-	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma);
+	   observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma);
 	   type_of_lemma,type_info
 	)
 	funs_constr
@@ -811,18 +792,18 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
 	  Array.of_list
 	    (List.map
 	       (fun entry ->
-		  (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type )
+		  (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type ))
 	       )
-	       (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs))
+	       (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs))
 	    )
 	)
     in
     let proving_tac =
-      prove_fun_correct !evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos
+      prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos
     in
     Array.iteri
       (fun i f_as_constant ->
-	 let f_id = Label.to_id (con_label (fst f_as_constant)) in
+	 let f_id = Label.to_id (Constant.label (fst f_as_constant)) in
 	 (*i The next call to mk_correct_id is valid since we are constructing the lemma
 	     Ensures by: obvious
 	 i*)
@@ -842,7 +823,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
 	 (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *)
 	 let _,lem_cst_constr = Evd.fresh_global
 				  (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in
-	 let (lem_cst,_) = destConst lem_cst_constr in
+        let lem_cst_constr = EConstr.of_constr lem_cst_constr in
+	 let (lem_cst,_) = destConst !evd lem_cst_constr in
 	 update_Function {finfo with correctness_lemma = Some lem_cst};
 
       )
@@ -856,23 +838,23 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
 	 let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in
 	 graphs_constr.(i) <- graph;
 	 let type_of_lemma =
-	   Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt
+	   EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt
 	 in
 	 let type_of_lemma = nf_zeta type_of_lemma in
-	 observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
+         observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma);
 	 type_of_lemma,type_info
 	)
 	funs_constr
 	graphs_constr
     in
 
-    let (kn,_) as graph_ind,u  = (destInd graphs_constr.(0)) in
+    let (kn,_) as graph_ind,u  = (destInd !evd graphs_constr.(0)) in
     let mib,mip = Global.lookup_inductive graph_ind in
     let sigma, scheme = 
 	(Indrec.build_mutual_induction_scheme (Global.env ()) !evd
 	   (Array.to_list
 	      (Array.mapi
-		 (fun i _ -> ((kn,i),u(* Univ.Instance.empty *)),true,InType)
+		 (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType)
 		 mib.Declarations.mind_packets
 	      )
 	   )
@@ -886,7 +868,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
     in
     Array.iteri
       (fun i f_as_constant ->
-	 let f_id = Label.to_id (con_label (fst f_as_constant)) in
+	 let f_id = Label.to_id (Constant.label (fst f_as_constant)) in
 	 (*i The next call to mk_complete_id is valid since we are constructing the lemma
 	     Ensures by: obvious
 	   i*)
@@ -902,7 +884,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
 	 let finfo = find_Function_infos (fst f_as_constant) in
 	 let _,lem_cst_constr = Evd.fresh_global
 				  (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in
-	 let (lem_cst,_) = destConst lem_cst_constr in
+         let lem_cst_constr = EConstr.of_constr lem_cst_constr in
+	 let (lem_cst,_) = destConst !evd lem_cst_constr in
 	 update_Function {finfo with completeness_lemma = Some lem_cst}
       )
       funs)
@@ -917,16 +900,17 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) (
    if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
 *)
 let revert_graph kn post_tac hid g =
+    let sigma = project g in
     let typ = pf_unsafe_type_of g (mkVar hid) in
-    match kind_of_term typ with
-      | App(i,args) when isInd i ->
-	  let ((kn',num) as ind'),u = destInd i in
+    match EConstr.kind sigma typ with
+      | App(i,args) when isInd sigma i ->
+	  let ((kn',num) as ind'),u = destInd sigma i in
 	  if MutInd.equal kn kn'
 	  then (* We have generated a graph hypothesis so that we must change it if we can *)
 	    let info =
 	      try find_Function_of_graph ind'
 	      with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
-		anomaly (Pp.str "Cannot retrieve infos about a mutual block")
+		anomaly (Pp.str "Cannot retrieve infos about a mutual block.")
 	    in
 	    (* if we can find a completeness lemma for this function
 	       then we can come back to the functional form. If not, we do nothing
@@ -935,7 +919,7 @@ let revert_graph kn post_tac hid g =
 	      | None -> tclIDTAC g
 	      | Some f_complete ->
 		  let f_args,res = Array.chop (Array.length args - 1) args in
-		  tclTHENSEQ
+		  tclTHENLIST
 		    [
 		      Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]);
 		      thin [hid];
@@ -965,21 +949,22 @@ let revert_graph kn post_tac hid g =
    \end{enumerate}
 *)
 
-let functional_inversion kn hid fconst f_correct : tactic =
+let functional_inversion kn hid fconst f_correct : Tacmach.tactic =
   fun g ->
     let old_ids = List.fold_right Id.Set.add  (pf_ids_of_hyps g) Id.Set.empty in
+    let sigma = project g in
     let type_of_h = pf_unsafe_type_of g (mkVar hid) in
-    match kind_of_term type_of_h with
-      | App(eq,args) when eq_constr eq (make_eq ())  ->
+    match EConstr.kind sigma type_of_h with
+      | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ())  ->
 	  let pre_tac,f_args,res =
-	    match kind_of_term args.(1),kind_of_term args.(2) with
-	      | App(f,f_args),_ when eq_constr f fconst ->
+	    match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with
+	      | App(f,f_args),_ when EConstr.eq_constr sigma f fconst ->
 		  ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2))
-	      |_,App(f,f_args) when eq_constr f fconst ->
+	      |_,App(f,f_args) when EConstr.eq_constr sigma f fconst ->
 		 ((fun hid -> tclIDTAC),f_args,args.(1))
 	      | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
 	  in
-	  tclTHENSEQ[
+	  tclTHENLIST [
 	    pre_tac hid;
 	    Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]);
 	    thin [hid];
@@ -993,12 +978,13 @@ let functional_inversion kn hid fconst f_correct : tactic =
       | _ -> tclFAIL 1 (mt ()) g
 
 
+let error msg = user_err Pp.(str msg)
 
 let invfun qhyp f  =
   let f =
     match f with
       | ConstRef f -> f
-      | _ -> raise (CErrors.UserError("",str "Not a function"))
+      | _ -> raise (CErrors.UserError(None,str "Not a function"))
   in
   try
     let finfos = find_Function_infos f in
@@ -1012,7 +998,7 @@ let invfun qhyp f  =
     | Not_found ->  error "No graph found"
     | Option.IsNone  -> error "Cannot use equivalence with graph!"
 
-
+exception NoFunction
 let invfun qhyp f g =
   match f with
     | Some f -> invfun qhyp f g
@@ -1020,42 +1006,43 @@ let invfun qhyp f g =
        Proofview.V82.of_tactic begin
 	Tactics.try_intros_until
 	  (fun hid -> Proofview.V82.tactic begin fun g ->
+            let sigma = project g in
 	     let hyp_typ = pf_unsafe_type_of g (mkVar hid)  in
-	     match kind_of_term hyp_typ with
-	       | App(eq,args) when eq_constr eq (make_eq ()) ->
+	     match EConstr.kind sigma hyp_typ with
+	       | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) ->
 		   begin
-		     let f1,_ = decompose_app args.(1) in
+		     let f1,_ = decompose_app sigma args.(1) in
 		     try
-		       if not (isConst f1) then failwith "";
-		       let finfos = find_Function_infos (fst (destConst f1)) in
+		       if not (isConst sigma f1) then raise NoFunction;
+		       let finfos = find_Function_infos (fst (destConst sigma f1)) in
 		       let f_correct = mkConst(Option.get finfos.correctness_lemma)
 		       and kn = fst finfos.graph_ind
 		       in
 		       functional_inversion kn hid f1 f_correct g
-		     with | Failure "" | Option.IsNone | Not_found ->
+		     with | NoFunction | Option.IsNone | Not_found ->
 		       try
-			 let f2,_ = decompose_app args.(2) in
-			 if not (isConst f2) then failwith "";
-			 let finfos = find_Function_infos (fst (destConst f2)) in
+			 let f2,_ = decompose_app sigma args.(2) in
+			 if not (isConst sigma f2) then raise NoFunction;
+			 let finfos = find_Function_infos (fst (destConst sigma f2)) in
 			 let f_correct = mkConst(Option.get finfos.correctness_lemma)
 			 and kn = fst finfos.graph_ind
 			 in
 			 functional_inversion kn hid  f2 f_correct g
 		       with
-			 | Failure "" ->
-			     errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function")
+			 | NoFunction ->
+			     user_err  (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function")
 			 | Option.IsNone  ->
 			     if do_observe ()
 			     then
 			       error "Cannot use equivalence with graph for any side of the equality"
-			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+			     else user_err  (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
 			 | Not_found ->
 			     if do_observe ()
 			     then
 			       error "No graph found for any side of equality"
-			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+			     else user_err  (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
 		   end
-	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
+	       | _ -> user_err  (Ppconstr.pr_id hid ++ str " must be an equality ")
 	  end)
 	  qhyp
           end
diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli
new file mode 100644
index 00000000..ad306ab2
--- /dev/null
+++ b/plugins/funind/invfun.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+val invfun :
+  Misctypes.quantified_hypothesis ->
+  Globnames.global_reference option ->
+  Evar.t Evd.sigma -> Evar.t list Evd.sigma
+val derive_correctness :
+  (Evd.evar_map ref ->
+   (Constr.pconstant * Sorts.family) list ->
+   'a Entries.definition_entry list) ->
+   Constr.pconstant list -> Names.inductive list -> unit
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
deleted file mode 100644
index de4210af..00000000
--- a/plugins/funind/merge.ml
+++ /dev/null
@@ -1,1009 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Merging of induction principles. *)
-
-open Globnames
-open Tactics
-open Indfun_common
-open CErrors
-open Util
-open Constrexpr
-open Vernacexpr
-open Pp
-open Names
-open Term
-open Vars
-open Termops
-open Declarations
-open Glob_term
-open Glob_termops
-open Decl_kinds
-open Context.Rel.Declaration
-
-(** {1 Utilities}  *)
-
-(** {2 Useful operations on constr and glob_constr} *)
-
-let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
-
-(** Substitutions in constr *)
-let compare_constr_nosub t1 t2 =
-  if compare_constr (fun _ _ -> false) t1 t2
-  then true
-  else false
-
-let rec compare_constr' t1 t2 =
-  if compare_constr_nosub t1 t2
-  then true
-  else (compare_constr (compare_constr') t1 t2)
-
-let rec substitterm prof t by_t in_u =
-  if (compare_constr' (lift prof t) in_u)
-  then (lift prof by_t)
-  else map_constr_with_binders succ
-    (fun i -> substitterm i t by_t) prof in_u
-
-let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
-
-let understand = Pretyping.understand (Global.env()) Evd.empty
-
-(** Operations on names and identifiers *)
-let id_of_name = function
-    Anonymous -> Id.of_string "H"
-  | Name id   -> id;;
-let name_of_string str = Name (Id.of_string str)
-let string_of_name nme = Id.to_string (id_of_name nme)
-
-(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
-let isVarf f x =
-    match x with
-      | GVar (_,x) -> Id.equal x f
-      | _ -> false
-
-(** [ident_global_exist id] returns true if identifier [id] is linked
-    in global environment. *)
-let ident_global_exist id =
-  try
-    let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in
-    let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in
-    true
-  with e when CErrors.noncritical e -> false
-
-(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
-    global env) with base [id]. *)
-let next_ident_fresh (id:Id.t) =
-    let res = ref id in
-    while ident_global_exist !res do res := Nameops.lift_subscript !res done;
-    !res
-
-
-(** {2 Debugging} *)
-(* comment this line to see debug msgs *)
-let msg x = () ;; let pr_lconstr c = str ""
-(* uncomment this to see debugging *)
-let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c)
-let prconstrnl c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
-let prlistconstr lc = List.iter prconstr lc
-let prstr s = msg(str s)
-let prNamedConstr s c =
-  begin
-    msg(str "");
-    msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
-    msg(str "");
-  end
-let prNamedRConstr s c =
-  begin
-    msg(str "");
-    msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} ");
-    msg(str "");
-  end
-let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
-let prNamedLConstr s lc =
-  begin
-    prstr "[§§§ ";
-    prstr s;
-    prNamedLConstr_aux lc;
-    prstr " §§§]\n";
-  end
-let prNamedLDecl s lc =
-  begin
-    prstr s; prstr "\n";
-    List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
-    prstr "\n";
-  end
-let prNamedRLDecl s lc =
-  begin
-    prstr s; prstr "\n"; prstr "{§§ ";
-    List.iter
-      (fun x ->
-        match x with
-          | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp
-          | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy
-          | _ -> assert false
-        ) lc;
-    prstr " §§}\n";
-    prstr "\n";
-  end
-
-let showind (id:Id.t) =
-  let cstrid = Constrintern.global_reference id in
-  let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
-  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in
-  List.iter (fun decl ->
-    print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":");
-    prconstr (get_type decl); print_string "\n")
-    ib1.mind_arity_ctxt;
-    Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1);
-  Array.iteri
-    (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
-    ib1.mind_user_lc
-
-(** {2 Misc} *)
-
-exception Found of int
-
-(* Array scanning *)
-
-let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
-match Array.findi pred arr with
-| None -> Array.length arr (* all elt are positive *)
-| Some i -> i
-
-(* Like List.chop but except that [i] is the size of the suffix of [l]. *)
-let list_chop_end i l =
-  let size_prefix = List.length l -i in
-  if size_prefix < 0 then failwith "list_chop_end"
-  else List.chop size_prefix l
-
-let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
-  let i = ref 0 in
-  List.fold_left
-    (fun acc x ->
-      let res = f !i acc x in i := !i + 1; res)
-    acc arr
-
-let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list =
-  let i = ref 0 in
-  List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
-
-
-(** Iteration module *)
-module For =
-struct
-  let rec map i j (f: int -> 'a)  = if i>j then [] else f i :: (map (i+1) j f)
-  let rec foldup i j (f: 'a -> int -> 'a) acc =
-    if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
-  let rec folddown i j (f: 'a -> int -> 'a) acc =
-    if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
-  let fold i j = if i<j then foldup i j else folddown i j
-end
-
-
-(** {1 Parameters shifting and linking information} *)
-
-(** This type is used to deal with debruijn linked indices. When a
-    variable is linked to a previous one, we will ignore it and refer
-    to previous one. *)
-type linked_var =
-    | Linked of int
-    | Unlinked
-    | Funres
-
-(** When merging two graphs, parameters may become regular arguments,
-    and thus be shifted. This type describes the result of computing
-    the changes. *)
-type 'a shifted_params =
-    {
-      nprm1:'a;
-      nprm2:'a;
-      prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *)
-      nuprm1:'a;
-      nuprm2:'a;
-      nargs1:'a;
-      nargs2:'a;
-    }
-
-
-let prlinked x =
-  match x with
-    | Linked i -> Printf.sprintf "Linked %d" i
-    | Unlinked -> Printf.sprintf "Unlinked"
-    | Funres -> Printf.sprintf "Funres"
-
-let linkmonad f lnkvar =
-  match lnkvar with
-    | Linked i -> Linked (f i)
-    | Unlinked -> Unlinked
-    | Funres -> Funres
-
-let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
-
-(* This map is used to deal with debruijn linked indices. *)
-module Link = Map.Make (Int)
-
-let pr_links l =
-  Printf.printf "links:\n";
-  Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
-  Printf.printf "_____________\n"
-
-type 'a merged_arg =
-    | Prm_stable of 'a
-    | Prm_linked of 'a
-    | Prm_arg of 'a
-    | Arg_stable of 'a
-    | Arg_linked of 'a
-    | Arg_funres
-
-(** Information about graph merging of two inductives.
-   All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *)
-
-type merge_infos =
-    {
-      ident:Id.t; (** new inductive name *)
-      mib1: mutual_inductive_body;
-      oib1: one_inductive_body;
-      mib2: mutual_inductive_body;
-      oib2: one_inductive_body;
-
-      (** Array of links of the first inductive (should be all stable) *)
-      lnk1: int merged_arg array;
-
-      (** Array of links of the second inductive (point to the first ind param/args) *)
-      lnk2: int merged_arg array;
-
-      (** rec params which remain rec param (ie not linked) *)
-      recprms1: Context.Rel.Declaration.t list;
-      recprms2: Context.Rel.Declaration.t list;
-      nrecprms1: int;
-      nrecprms2: int;
-
-      (** rec parms which became non parm (either linked to something
-         or because after a rec parm that became non parm) *)
-      otherprms1: Context.Rel.Declaration.t list;
-      otherprms2: Context.Rel.Declaration.t list;
-      notherprms1:int;
-      notherprms2:int;
-
-      (** args which remain args in merge *)
-      args1:Context.Rel.Declaration.t list;
-      args2:Context.Rel.Declaration.t list;
-      nargs1:int;
-      nargs2:int;
-
-      (** functional result args *)
-      funresprms1: Context.Rel.Declaration.t list;
-      funresprms2: Context.Rel.Declaration.t list;
-      nfunresprms1:int;
-      nfunresprms2:int;
-    }
-
-
-let pr_merginfo x =
-  let i,s=
-    match x with
-      | Prm_linked i -> Some i,"Prm_linked"
-      | Arg_linked i -> Some i,"Arg_linked"
-      | Prm_stable i -> Some i,"Prm_stable"
-      | Prm_arg i -> Some i,"Prm_arg"
-      | Arg_stable i -> Some i,"Arg_stable"
-      | Arg_funres -> None , "Arg_funres" in
-  match i with
-    | Some i -> Printf.sprintf "%s(%d)" s i
-    | None -> Printf.sprintf "%s" s
-
-let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
-
-(* ?? prm_linked?? *)
-let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false
-
-let is_stable x =
-  match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false
-
-let isArg_funres x = match x with Arg_funres -> true | _ -> false
-
-let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
-  let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in
-  let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in
-  let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in
-  prms@args@fres
-
-(** Reverse the link map, keeping only linked vars, elements are list
-    of int as several vars may be linked to the same var. *)
-let revlinked lnk =
-  For.fold 0 (Array.length lnk - 1)
-    (fun acc k ->
-      match lnk.(k) with
-        | Unlinked | Funres -> acc
-        | Linked i ->
-            let old = try Link.find i acc with Not_found -> [] in
-            Link.add i (k::old) acc)
-    Link.empty
-
-let array_switch arr i j =
-  let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
-
-let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
-  let larr = Array.of_list l in
-  let _ =
-    Array.iteri
-      (fun j x ->
-        match x with
-          | Prm_linked i -> array_switch larr i j
-          | Arg_linked i -> array_switch larr i j
-          | Prm_stable i -> ()
-          | Prm_arg i -> ()
-          | Arg_stable i -> ()
-          | Arg_funres -> ()
-      ) lnk in
-  filter_shift_stable lnk (Array.to_list larr)
-
-
-
-
-(** {1 Utilities for merging} *)
-
-let ind1name = Id.of_string "__ind1"
-let ind2name = Id.of_string "__ind2"
-
-(** Performs verifications on two graphs before merging: they must not
-    be co-inductive, and for the moment they must not be mutual
-    either. *)
-let verify_inds mib1 mib2 =
-  if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive";
-  if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive";
-  if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual";
-  if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual";
-  ()
-
-(*
-(** [build_raw_params prms_decl avoid] returns a list of variables
-    attributed to the list of decl [prms_decl], avoiding names in
-    [avoid]. *)
-let build_raw_params prms_decl avoid =
-  let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in
-  let _ = prNamedConstr "DUMMY" dummy_constr in
-  let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in
-  let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in
-  let res,_ = glob_decompose_prod dummy_glob_constr in
-  let comblist = List.combine prms_decl res in
-  comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr)))
-*)
-
-let ids_of_rawlist avoid rawl =
-    List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl)
-
-
-
-(** {1 Merging function graphs} *)
-
-(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec
-    uniform and ordinary ones) of mutual inductives [mib1] and [mib2]
-    remain uniform when linked by [lnk]. All parameters are
-    considered, ie we take parameters of the first inductive body of
-    [mib1] and [mib2].
-
-    Explanation: The two inductives have parameters, some of the first
-    are recursively uniform, some of the last are functional result of
-    the functional graph.
-
-   (I x1 x2 ... xk ... xk' ... xn)
-   (J y1 y2 ... xl ... yl' ... ym)
-
-   Problem is, if some rec unif params are linked to non rec unif
-   ones, they become non rec (and the following too). And functinal
-   argument have to be shifted at the end *)
-let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id =
-  let _ = prstr "\nYOUHOU shift\n" in
-  let linked_targets = revlinked lnk2 in
-  let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
-  let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
-  let is_targetted_by_non_recparam_lnk1 i =
-    try
-      let targets = Link.find i linked_targets in
-      List.exists (fun x -> not (is_param_of_mib2 x)) targets
-    with Not_found -> false in
-  let mlnk1 =
-    Array.mapi
-      (fun i lkv ->
-        let isprm = is_param_of_mib1 i in
-        let prmlost = is_targetted_by_non_recparam_lnk1 i in
-        match isprm , prmlost, lnk1.(i) with
-          | true , true , _ -> Prm_arg i (* recparam becoming ordinary *)
-          | true , false , _-> Prm_stable i (* recparam remains recparam*)
-          | false , false , Funres -> Arg_funres
-          | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
-          | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
-      lnk1 in
-  let mlnk2 =
-    Array.mapi
-      (fun i lkv ->
-        (* Is this correct if some param of ind2 is lost? *)
-        let isprm = is_param_of_mib2 i in
-        match isprm , lnk2.(i) with
-          | true , Linked j when not (is_param_of_mib1 j) ->
-              Prm_arg j (* recparam becoming ordinary *)
-          | true , Linked j -> Prm_linked j (*recparam linked to recparam*)
-          | true , Unlinked -> Prm_stable i (* recparam remains recparam*)
-          | false , Linked j -> Arg_linked j (* Args of lnk2 lost *)
-          | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *)
-          | false , Funres -> Arg_funres
-          | true , Funres -> assert false (* fun res cannot be a rec param *)
-      )
-      lnk2 in
-  let oib1 = mib1.mind_packets.(0) in
-  let oib2 = mib2.mind_packets.(0) in
-  (* count params remaining params *)
-  let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
-  let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
-  let bldprms arity_ctxt mlnk =
-    list_fold_lefti
-      (fun i (acc1,acc2,acc3,acc4) x ->
-        prstr (pr_merginfo mlnk.(i));prstr "\n";
-        match mlnk.(i) with
-          | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4
-          | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4
-          | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4
-          | Arg_funres -> acc1 , acc2 , acc3, x::acc4
-          | _ -> acc1 , acc2 , acc3, acc4)
-      ([],[],[],[]) arity_ctxt in
-(*  let arity_ctxt2 =
-    build_raw_params oib2.mind_arity_ctxt
-      (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*)
-  let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
-  let _ = prstr "\n\n\n" in
-  let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
-  let _ = prstr "\notherprms1:\n" in
-  let _ =
-    List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : ");
-			   prconstr (get_type decl); prstr "\n")
-    otherprms1 in
-  let _ = prstr "\notherprms2:\n" in
-  let _ =
-    List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n")
-    otherprms2 in
-  {
-    ident=id;
-    mib1=mib1;
-    oib1 = oib1;
-    mib2=mib2;
-    oib2 = oib2;
-    lnk1 = mlnk1;
-    lnk2 = mlnk2;
-    nrecprms1 = n_params1;
-    recprms1 = recprms1;
-    otherprms1 = otherprms1;
-    args1 = args1;
-    funresprms1 = funresprms1;
-    notherprms1 = Array.length mlnk1 - n_params1;
-    nfunresprms1 = List.length funresprms1;
-    nargs1 = List.length args1;
-    nrecprms2 = n_params2;
-    recprms2 = recprms2;
-    otherprms2 = otherprms2;
-    args2 = args2;
-    funresprms2 = funresprms2;
-    notherprms2 = Array.length mlnk2 - n_params2;
-    nargs2 = List.length args2;
-    nfunresprms2 = List.length funresprms2;
-  }
-
-
-
-
-(** {1 Merging functions} *)
-
-exception NoMerge
-
-let rec merge_app c1 c2 id1 id2 shift filter_shift_stable =
-  let lnk = Array.append shift.lnk1 shift.lnk2 in
-  match c1 , c2 with
-    | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
-        let _ = prstr "\nICI1!\n" in
-        let args = filter_shift_stable lnk (arr1 @ arr2) in
-        GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args)
-    | GApp(_,f1, arr1), GApp(_,f2,arr2)  -> raise NoMerge
-    | GLetIn(_,nme,bdy,trm) , _ ->
-        let _ = prstr "\nICI2!\n" in
-        let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
-        GLetIn(Loc.ghost,nme,bdy,newtrm)
-    | _, GLetIn(_,nme,bdy,trm) ->
-        let _ = prstr "\nICI3!\n" in
-        let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
-        GLetIn(Loc.ghost,nme,bdy,newtrm)
-    | _ -> let _ = prstr "\nICI4!\n" in
-           raise NoMerge
-
-let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
-  let lnk = Array.append shift.lnk1 shift.lnk2 in
-  match c1 , c2 with
-    | GApp(_,f1, arr1), GApp(_,f2,arr2) ->
-        let args = filter_shift_stable lnk (arr1 @ arr2) in
-        GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args)
-          (* FIXME: what if the function appears in the body of the let? *)
-    | GLetIn(_,nme,bdy,trm) , _ ->
-      let _ = prstr "\nICI2 '!\n" in
-        let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
-        GLetIn(Loc.ghost,nme,bdy,newtrm)
-    | _, GLetIn(_,nme,bdy,trm) ->
-        let _ = prstr "\nICI3 '!\n" in
-        let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
-        GLetIn(Loc.ghost,nme,bdy,newtrm)
-    | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge
-
-
-
-(* Heuristic when merging two lists of hypothesis: merge every rec
-   calls of branch 1 with all rec calls of branch 2. *)
-(* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
-let rec merge_rec_hyps shift accrec
-    (ltyp:(Name.t * glob_constr option * glob_constr option) list)
-    filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list =
-  let mergeonehyp t reldecl =
-    match reldecl with
-      | (nme,x,Some (GApp(_,i,args) as ind))
-        -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable)
-      | (nme,Some _,None) -> error "letins with recursive calls not treated yet"
-      | (nme,None,Some _) -> assert false
-      | (nme,None,None) | (nme,Some _,Some _) -> assert false in
-  match ltyp with
-    | [] -> []
-    | (nme,None,Some (GApp(_,f, largs) as t)) :: lt when isVarf ind2name f ->
-        let rechyps = List.map (mergeonehyp t) accrec in
-        rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable
-    | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
-
-
-let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift =
-  List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
-
-
-let find_app (nme:Id.t) ltyp =
-  try
-    ignore
-      (List.map
-          (fun x ->
-            match x with
-              | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0)
-              | _ -> ())
-          ltyp);
-    false
-  with Found _ -> true
-
-let prnt_prod_or_letin nm letbdy typ =
-  match letbdy , typ with
-    | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy
-    | None , Some tp -> prNamedRConstr (string_of_name nm) tp
-    | _ , _ -> assert false
-
-
-let rec merge_types shift accrec1
-    (ltyp1:(Name.t * glob_constr option * glob_constr option) list)
-    (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2
-    : (Name.t * glob_constr option * glob_constr option) list * glob_constr =
-  let _ = prstr "MERGE_TYPES\n" in
-  let _ = prstr "ltyp 1 : " in
-  let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
-  let _ = prstr "\nltyp 2 : " in
-  let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in
-  let _ = prstr "\n" in
-  let res =
-    match ltyp1 with
-      | [] ->
-          let isrec1 = not (List.is_empty accrec1) in
-          let isrec2 = find_app ind2name ltyp2 in
-          let rechyps =
-            if isrec1 && isrec2
-            then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *)
-              merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
-                filter_shift_stable_right
-              @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2]
-                filter_shift_stable
-            else if isrec1
-                (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
-            then
-              merge_rec_hyps shift accrec1
-                (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable
-            else if isrec2
-            then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
-              filter_shift_stable_right
-            else ltyp2 in
-          let _ = prstr"\nrechyps : " in
-          let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in
-          let _ = prstr "MERGE CONCL :  " in
-          let _ = prNamedRConstr "concl1" concl1 in
-          let _ = prstr " with " in
-          let _ = prNamedRConstr "concl2" concl2 in
-          let _ = prstr "\n" in
-          let concl =
-            merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
-          let _ = prstr "FIN " in
-          let _ = prNamedRConstr "concl" concl in
-          let _ = prstr "\n" in
-
-          rechyps , concl
-      | (nme,None, Some t1)as e ::lt1 ->
-          (match t1 with
-            | GApp(_,f,carr) when isVarf ind1name f ->
-                merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2
-            | _ ->
-                let recres, recconcl2 =
-                  merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
-                ((nme,None,Some t1) :: recres) , recconcl2)
-      | (nme,Some bd, None) ::lt1 ->
-          (* FIXME: what if ind1name appears in bd? *)
-          let recres, recconcl2 =
-            merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
-          ((nme,Some bd,None) :: recres) , recconcl2
-      | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false
-  in
-  res
-
-
-(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of
-    linked args [allargs2] to target args of [allargs1] as specified
-    in [shift]. [allargs1] and [allargs2] are in reverse order.  Also
-    returns the list of unlinked vars of [allargs2]. *)
-let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array)
-    (lnk:int merged_arg array) =
-  Array.fold_left_i
-    (fun i acc e ->
-      if Int.equal i (Array.length lnk - 1) then acc (* functional arg, not in allargs *)
-      else
-        match e with
-          | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc
-          | _ -> acc)
-    Id.Map.empty lnk
-
-let build_link_map allargs1 allargs2 lnk =
-  let allargs1 =
-    Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in
-  let allargs2 =
-    Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in
-  build_link_map_aux allargs1 allargs2 lnk
-
-
-(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two
-    constructor rawtypes [typcstr1] and [typcstr2].  [typcstr1] and
-    [typcstr2] contain all parameters (including rec. unif. ones) of
-    their inductive.
-
-    if  [typcstr1] and [typcstr2] are of the form:
-
-    forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1)
-    forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2)
-
-    we build:
-
-    forall recparams1 (recparams2 without linked params),
-     forall ordparams1 (ordparams2 without linked params),
-      H1a' -> H2a' -> ...  -> H2a' -> H2b'(shifted) -> ...
-        -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
-
-    where Hix' have been adapted, ie:
-      - linked vars have been changed,
-      - rec calls to I1 and I2 have been replaced by rec calls to
-        newI. More precisely calls to I1 and I2 have been merge by an
-        experimental heuristic (in particular if n o rec calls for I1
-        or I2 is found, we use the conclusion as a rec call). See
-        [merge_types] above.
-
-    Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint.
-
-    TODO: return nothing if equalities (after linking) are contradictory. *)
-let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr)
-    (typcstr2:glob_constr) : glob_constr =
-  (* FIXME: les noms des parametres corerspondent en principe au
-     parametres du niveau mib, mais il faudrait s'en assurer *)
-  (* shift.nfunresprmsx last args are functional result *)
-  let nargs1 =
-    shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
-  let nargs2 =
-    shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
-  let allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in
-  let allargs2,rest2 = glob_decompose_prod_or_letin_n nargs2 typcstr2 in
-  (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *)
-  let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in
-  let rest2 = change_vars linked_map rest2 in
-  let hyps1,concl1 = glob_decompose_prod_or_letin rest1 in
-  let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in
-  let ltyp,concl2 =
-    merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in
-  let _ = prNamedRLDecl "ltyp result:" ltyp in
-  let typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in
-  let revargs1 =
-    list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
-  let _ = prNamedRLDecl "ltyp allargs1" allargs1 in
-  let _ = prNamedRLDecl "ltyp revargs1" revargs1 in
-  let revargs2 =
-    list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
-  let _ = prNamedRLDecl "ltyp allargs2" allargs2 in
-  let _ = prNamedRLDecl "ltyp revargs2" revargs2 in
-  let typwithprms =
-    glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in
-  typwithprms
-
-
-(** constructor numbering *)
-let fresh_cstror_suffix , cstror_suffix_init =
-  let cstror_num = ref 0 in
-  (fun () ->
-    let res = string_of_int !cstror_num in
-    cstror_num := !cstror_num + 1;
-    res) ,
-  (fun () -> cstror_num := 0)
-
-(** [merge_constructor_id id1 id2 shift] returns the identifier of the
-    new constructor from the id of the two merged constructor and
-    the merging info. *)
-let merge_constructor_id id1 id2 shift:Id.t =
-  let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in
-  next_ident_fresh (Id.of_string id)
-
-
-
-(** [merge_constructors lnk shift avoid] merges the two list of
-    constructor [(name*type)]. These are translated to glob_constr
-    first, each of them having distinct var names. *)
-let merge_constructors (shift:merge_infos) (avoid:Id.Set.t)
-    (typcstr1:(Id.t * glob_constr) list)
-    (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list =
-  List.flatten
-    (List.map
-        (fun (id1,rawtyp1) ->
-          List.map
-            (fun (id2,rawtyp2) ->
-              let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
-              let newcstror_id = merge_constructor_id id1 id2 shift in
-              let _ = prstr "\n**************\n" in
-              newcstror_id , typ)
-            typcstr2)
-        typcstr1)
-
-(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
-    inductive bodies [oib1] and [oib2], linking with [lnk], params
-    info in [shift], avoiding identifiers in [avoid]. *)
-let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
-    (oib2:one_inductive_body) =
-  (* building glob_constr type of constructors *)
-  let mkrawcor nme avoid typ =
-    (* first replace rel 1 by a varname *)
-    let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
-    Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in
-  let lcstr1: glob_constr list =
-    Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
-  (* add  to avoid all indentifiers of lcstr1 *)
-  let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in
-  let lcstr2 =
-    Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
-  let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in
-
-  let params1 =
-    try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
-    with e when CErrors.noncritical e -> [] in
-  let params2 =
-    try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
-    with e when CErrors.noncritical e -> [] in
-
-  let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
-  let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
-
-  cstror_suffix_init();
-  params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2
-
-
-(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
-    inductive bodies [mib1] and [mib2] linking vars with
-    [lnk]. [shift] information on parameters of the new inductive.
-    For the moment, inductives are supposed to be non mutual.
-*)
-let merge_mutual_inductive_body
-    (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
-  (* Mutual not treated, we take first ind body of each. *)
-  merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
-
-
-let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *)
-  Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x
-
-let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
-  let params = prms2 @ prms1 in
-  let resparams =
-    List.fold_left
-      (fun acc (nme,tp) ->
-        let _ = prstr "param :" in
-        let _ = prNamedRConstr (string_of_name nme) tp in
-        let _ = prstr "  ;  " in
-        let typ = glob_constr_to_constr_expr tp in
-        LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc)
-      [] params in
-  let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in
-  let arity,_ =
-    List.fold_left
-      (fun (acc,env) decl ->
-        let nm = Context.Rel.Declaration.get_name decl in
-        let c = get_type decl in
-        let typ = Constrextern.extern_constr false env Evd.empty c in
-        let newenv = Environ.push_rel (LocalAssum (nm,c)) env in
-        CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv)
-      (concl,Global.env())
-      (shift.funresprms2 @ shift.funresprms1
-        @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
-  resparams,arity
-
-
-
-(** [glob_constr_list_to_inductive_expr ident rawlist] returns the
-    induct_expr corresponding to the the list of constructor types
-    [rawlist], named ident.
-    FIXME: params et cstr_expr (arity) *)
-let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
-    (rawlist:(Id.t * glob_constr) list) =
-  let lident = (Loc.ghost, shift.ident), None in
-  let bindlist , cstr_expr = (* params , arities *)
-    merge_rec_params_and_arity prms1 prms2 shift mkSet in
-  let lcstor_expr : (bool * (lident * constr_expr)) list  =
-    List.map (* zeta_normalize t ? *)
-      (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t))
-      rawlist in
-  lident , bindlist , Some cstr_expr , lcstor_expr
-
-
-let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) =
-  match rdecl with
-    | LocalAssum (nme,t) ->
-        let traw = Detyping.detype false [] (Global.env()) Evd.empty t in
-        GProd (Loc.ghost,nme,Explicit,traw,t2)
-    | LocalDef _ -> assert false
-
-
-(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
-    variables specified in [lnk]. Graphs are not supposed to be mutual
-    inductives for the moment. *)
-let merge_inductive (ind1: inductive) (ind2: inductive)
-    (lnk1: linked_var array) (lnk2: linked_var array) id =
-  let env = Global.env() in
-  let mib1,_ = Inductive.lookup_mind_specif env ind1 in
-  let mib2,_ = Inductive.lookup_mind_specif env ind2 in
-  let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
-  (* compute params that become ordinary args (because linked to ord. args) *)
-  let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
-  let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
-  let _ = prstr "\nrawlist : " in
-  let _ =
-    List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in
-  let _ = prstr "\nend rawlist\n" in
-(* FIX: retransformer en constr ici
-   let shift_prm =
-    { shift_prm with
-      recprms1=prms1;
-      recprms1=prms1;
-    } in *)
-  let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
-  (* Declare inductive *)
-  let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in
-  let mie,pl,impls = Command.interp_mutual_inductive indl []
-          false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in
-  (* Declare the mutual inductive block with its associated schemes *)
-  ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls)
-
-
-(* Find infos on identifier id. *)
-let find_Function_infos_safe (id:Id.t): Indfun_common.function_info =
-  let kn_of_id x =
-    let f_ref = Libnames.Ident (Loc.ghost,x) in
-    locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref)
-      locate_constant f_ref in
-    try find_Function_infos (kn_of_id id)
-    with Not_found ->
-      errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme")
-
-(** [merge id1 id2 args1 args2 id] builds and declares a new inductive
-    type called [id], representing the merged graphs of both graphs
-    [ind1] and [ind2]. identifiers occurring in both arrays [args1] and
-    [args2] are considered linked (i.e. are the same variable) in the
-    new graph.
-
-    Warning: For the moment, repetitions of an id in [args1] or
-    [args2] are not supported. *)
-let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array)
-    (args2:Id.t array) id : unit =
-  let finfo1 = find_Function_infos_safe id1 in
-  let finfo2 = find_Function_infos_safe id2 in
-  (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
-  (* We add one arg (functional arg of the graph) *)
-  let lnk1 = Array.make (Array.length args1 + 1) Unlinked in
-  let lnk2' = (* args2 may be linked to args1 members. FIXME: same
-                 as above: vars may be linked inside args2?? *)
-    Array.mapi
-      (fun i c ->
-        match Array.findi (fun i x -> Id.equal x c) args1 with
-          | Some j -> Linked j
-          | None -> Unlinked)
-      args2 in
-  (* We add one arg (functional arg of the graph) *)
-  let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in
-  (* setting functional results *)
-  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in
-  let _ = lnk2.(Array.length lnk2 - 1) <- Funres in
-  merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id
-
-
-let remove_last_arg c =
-  let (x,y) = decompose_prod c in
-  let xnolast = List.rev (List.tl (List.rev x)) in
-  compose_prod xnolast y
-
-let rec remove_n_fst_list n l = if Int.equal n 0 then l else remove_n_fst_list (n-1) (List.tl l)
-let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l))
-
-let remove_last_n_arg n c =
-  let (x,y) = decompose_prod c in
-  let xnolast = remove_n_last_list n x in
-  compose_prod xnolast y
-
-(* [funify_branches relinfo nfuns branch] returns the branch [branch]
-   of the relinfo [relinfo] modified to fit in a functional principle.
-   Things to do:
-    - remove indargs from rel applications
-    - replace *variables only* corresponding to function (recursive)
-      results by the actual function application. *)
-let funify_branches relinfo nfuns branch =
-  let mut_induct, induct =
-    match relinfo.indref with
-      | None -> assert false
-      | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind
-      | _ -> assert false in
-  let is_dom c =
-    match kind_of_term c with
-      | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct
-      | _ -> false in
-  let _dom_i c =
-    assert (is_dom c);
-    match kind_of_term c with
-      | Ind((u,i)) | Construct((u,_),i) -> i
-      | _ -> assert false in
-  let _is_pred c shift =
-    match kind_of_term c with
-      | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
-      | _ -> false in
-  (* FIXME: *)
-  LocalDef (Anonymous,mkProp,mkProp)
-
-
-let relprinctype_to_funprinctype relprinctype nfuns =
-  let relinfo = compute_elim_sig relprinctype in
-  assert (not relinfo.farg_in_concl);
-  assert (relinfo.indarg_in_concl);
-  (* first remove indarg and indarg_in_concl *)
-  let relinfo_noindarg = { relinfo with
-    indarg_in_concl = false; indarg = None;
-    concl = remove_last_arg (pop relinfo.concl); } in
-  (* the nfuns last induction arguments are functional ones: remove them *)
-  let relinfo_argsok = { relinfo_noindarg with
-    nargs = relinfo_noindarg.nargs - nfuns;
-    (* args is in reverse order, so remove fst *)
-    args = remove_n_fst_list nfuns relinfo_noindarg.args;
-    concl = popn nfuns relinfo_noindarg.concl
-  } in
-  let new_branches =
-    List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in
-  let relinfo_branches = { relinfo_argsok with branches = new_branches } in
-  relinfo_branches
-
-(* @article{ bundy93rippling,
-    author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill",
-    title = "Rippling: A Heuristic for Guiding Inductive Proofs",
-    journal = "Artificial Intelligence",
-    volume = "62",
-    number = "2",
-    pages = "185-253",
-    year = "1993",
-    url = "citeseer.ist.psu.edu/bundy93rippling.html" }
-
- *)
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index fa84e4dd..fb9ae64b 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -1,12 +1,18 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
 (*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
-open Term
+
+module CVars = Vars
+
+open Constr
+open EConstr
 open Vars
 open Namegen
 open Environ
@@ -25,7 +31,7 @@ open Nametab
 open Declare
 open Decl_kinds
 open Tacred
-open Proof_type
+open Goal
 open Pfedit
 open Glob_term
 open Pretyping
@@ -39,56 +45,63 @@ open Auto
 open Eauto
 
 open Indfun_common
-open Sigma.Notations
 open Context.Rel.Declaration
 
-
 (* Ugly things which should not be here *)
 
-let coq_constant m s =
-  Coqlib.coq_constant "RecursiveDefinition" m s
+let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@
+  Coqlib.coq_reference "RecursiveDefinition" m s
 
 let arith_Nat = ["Arith";"PeanoNat";"Nat"]
 let arith_Lt = ["Arith";"Lt"]
 
+let pr_leconstr_rd =
+  let sigma, env = Pfedit.get_current_context () in
+  Printer.pr_leconstr_env env sigma
+
 let coq_init_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s
+  EConstr.of_constr (
+    Universes.constr_of_global @@
+    Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s)
 
 let find_reference sl s =
   let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
   locate (make_qualid dp (Id.of_string s))
 
-let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value =
-  let ce = definition_entry ~univs:ctx value (*FIXME *) in
+let declare_fun f_id kind ?univs value =
+  let ce = definition_entry ?univs value (*FIXME *) in
     ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
 
 let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None)))
 
 let def_of_const t =
-   match (kind_of_term t) with
+   match (Constr.kind t) with
     Const sp ->
       (try (match constant_opt_value_in (Global.env ()) sp with
              | Some c -> c
 	     | _ -> raise Not_found)
        with Not_found ->
 	 anomaly (str "Cannot find definition of constant " ++
-		    (Id.print (Label.to_id (con_label (fst sp)))))
+		    (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".")
       )
      |_ -> assert false
 
-let type_of_const t =
-   match (kind_of_term t) with
-    Const sp -> Typeops.type_of_constant (Global.env()) sp
+let type_of_const sigma t =
+   match (EConstr.kind sigma t) with
+   | Const (sp, u) ->
+      let u = EInstance.kind sigma u in
+      (* FIXME discarding universe constraints *)
+      Typeops.type_of_constant_in (Global.env()) (sp, u)
     |_ -> assert false
 
 let constr_of_global x = 
-  fst (Universes.unsafe_constr_of_global x)
+  fst (Global.constr_of_global_in_context (Global.env ()) x)
 
 let constant sl s = constr_of_global (find_reference sl s)
 
 let const_of_ref = function
     ConstRef kn -> kn
-  | _ -> anomaly (Pp.str "ConstRef expected")
+  | _ -> anomaly (Pp.str "ConstRef expected.")
 
 
 let nf_zeta env =
@@ -98,9 +111,7 @@ let nf_zeta env =
 
 
 let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
-  let clos_norm_flags flgs env sigma t =
-    CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags CClosure.betaiotazeta  Environ.empty_env Evd.empty
+  Reductionops.clos_norm_flags CClosure.betaiotazeta  Environ.empty_env Evd.empty
 
 
 
@@ -110,13 +121,17 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta
 (* Generic values *)
 let pf_get_new_ids idl g =
   let ids = pf_ids_of_hyps g in
+  let ids = Id.Set.of_list ids in
   List.fold_right
-    (fun id acc -> next_global_ident_away id (acc@ids)::acc)
+    (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc)
     idl
     []
 
+let next_ident_away_in_goal ids avoid =
+  next_ident_away_in_goal ids (Id.Set.of_list avoid)
+
 let compute_renamed_type gls c =
-  rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) []
+  rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) []
     (pf_unsafe_type_of gls c)
 let h'_id = Id.of_string "h'"
 let teq_id = Id.of_string "teq"
@@ -128,13 +143,13 @@ let def_id = Id.of_string "def"
 let p_id = Id.of_string "p"
 let rec_res_id = Id.of_string "rec_res";;
 let lt = function () -> (coq_init_constant "lt")
-let le = function () -> (coq_init_constant "le")
+let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le")
 let ex = function () -> (coq_init_constant "ex")
 let nat = function () -> (coq_init_constant "nat")
 let iter_ref () =  
   try find_reference ["Recdef"] "iter" 
-  with Not_found -> error "module Recdef not loaded"
-let iter = function () -> (constr_of_global (delayed_force iter_ref))
+  with Not_found -> user_err Pp.(str "module Recdef not loaded")
+let iter_rd = function () -> (constr_of_global (delayed_force iter_ref))
 let eq = function () -> (coq_init_constant "eq")
 let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
 let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm")
@@ -147,7 +162,7 @@ let coq_O = function () -> (coq_init_constant "O")
 let coq_S = function () -> (coq_init_constant "S")
 let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r")
 let max_ref = function () -> (find_reference ["Recdef"] "max")
-let max_constr = function () -> (constr_of_global (delayed_force max_ref))
+let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref))
 let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj"
 
 let f_S t = mkApp(delayed_force coq_S, [|t|]);;
@@ -166,9 +181,10 @@ let simpl_iter clause =
     clause
 
 (* Others ugly things ... *)
-let (value_f:constr list -> global_reference -> constr) =
+let (value_f: Constr.t list -> global_reference -> Constr.t) =
+  let open Term in
+  let open Constr in
   fun al fterm ->
-    let d0 = Loc.ghost in
     let rev_x_id_l =
       (
 	List.fold_left
@@ -185,21 +201,21 @@ let (value_f:constr list -> global_reference -> constr) =
     in
     let env = Environ.push_rel_context context (Global.env ()) in
     let glob_body =
-      GCases
-	(d0,RegularStyle,None,
-	 [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l),
+      DAst.make @@
+       GCases
+	(RegularStyle,None,
+	 [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l),
 	  (Anonymous,None)],
-	 [d0, [v_id], [PatCstr(d0,(destIndRef
-				     (delayed_force coq_sig_ref),1),
-			       [PatVar(d0, Name v_id);
-				PatVar(d0, Anonymous)],
-			       Anonymous)],
-	  GVar(d0,v_id)])
+         [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1),
+			   [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous],
+                           Anonymous)],
+	    DAst.make @@ GVar v_id)])
     in
     let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in
+    let body = EConstr.Unsafe.to_constr body in
     it_mkLambda_or_LetIn body context
 
-let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) =
+let (declare_f : Id.t -> logical_kind -> Constr.t list -> global_reference -> global_reference) =
   fun f_id kind input_type fterm_ref ->
     declare_fun f_id kind (value_f input_type fterm_ref);;
 
@@ -301,14 +317,14 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
 (* [check_not_nested forbidden e] checks that [e] does not contains any variable 
    of [forbidden]
 *)
-let check_not_nested forbidden e =
+let check_not_nested sigma forbidden e =
   let rec check_not_nested e =  
-    match kind_of_term e with 
+    match EConstr.kind sigma e with 
       | Rel _ -> ()
       | Var x ->
         if Id.List.mem x forbidden
-        then errorlabstrm "Recdef.check_not_nested"
-               (str "check_not_nested: failure " ++ pr_id x)
+        then user_err ~hdr:"Recdef.check_not_nested"
+               (str "check_not_nested: failure " ++ Id.print x)
       | Meta _ | Evar _ | Sort _ -> ()
       | Cast(e,_,t) -> check_not_nested e;check_not_nested t
       | Prod(_,t,b) -> check_not_nested t;check_not_nested b
@@ -321,13 +337,14 @@ let check_not_nested forbidden e =
       | Construct _ -> ()
       | Case(_,t,e,a) -> 
 	check_not_nested t;check_not_nested e;Array.iter check_not_nested a
-      | Fix _ -> error "check_not_nested : Fix"
-      | CoFix _ -> error "check_not_nested : Fix"
+      | Fix _ -> user_err Pp.(str "check_not_nested : Fix")
+      | CoFix _ -> user_err Pp.(str "check_not_nested : Fix")
   in
   try 
     check_not_nested e 
   with UserError(_,p) -> 
-    errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p)
+    let _, env = Pfedit.get_current_context () in
+    user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p)
 
 (* ['a info] contains the local information for traveling *)
 type 'a infos = 
@@ -374,15 +391,17 @@ type journey_info =
 
 	       
 
-let rec add_vars forbidden e = 
-  match kind_of_term e with 
+let add_vars sigma forbidden e = 
+  let rec aux forbidden e =
+  match EConstr.kind sigma e with 
     | Var x -> x::forbidden 
-    | _ -> fold_constr add_vars forbidden e 
-
+    | _ -> EConstr.fold sigma aux forbidden e
+  in
+  aux forbidden e
 
 let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = 
   fun g -> 
-    let rev_context,b = decompose_lam_n nb_lam e in 
+    let rev_context,b = decompose_lam_n (project g) nb_lam e in
     let ids = List.fold_left (fun acc (na,_) -> 	
       let pre_id = 
 	match na with 
@@ -404,17 +423,17 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic =
 	    (fun g' -> 
 	      let ty_teq = pf_unsafe_type_of g' (mkVar heq) in
 	      let teq_lhs,teq_rhs =
-		let _,args = try destApp ty_teq with DestKO -> assert false in
+		let _,args = try destApp (project g') ty_teq with DestKO -> assert false in
 		args.(1),args.(2)
 	      in
-	      let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in 
+	      let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in 
 	      let new_infos = {
 		infos with 
 		  info = new_b';
 		  eqs = heq::infos.eqs;
 		  forbidden_ids = 
 		  if forbid_new_ids 
-		  then add_vars infos.forbidden_ids new_b'
+		  then add_vars (project g') infos.forbidden_ids new_b'
 		  else infos.forbidden_ids
 	      } in 
 	      finalize_tac new_infos g' 
@@ -423,34 +442,35 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic =
 	)
       ] g
 
-let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
-  match kind_of_term expr_info.info with 
-    | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint"
-    | Proj _ -> error "Function cannot treat projections"
+let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g =
+  let sigma = project g in
+  match EConstr.kind sigma expr_info.info with 
+    | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint")
+    | Proj _ -> user_err Pp.(str "Function cannot treat projections")
     | LetIn(na,b,t,e) -> 
       begin
 	let new_continuation_tac = 
 	  jinfo.letiN (na,b,t,e) expr_info continuation_tac
 	in
 	travel jinfo new_continuation_tac 
-	  {expr_info with info = b; is_final=false}
+	  {expr_info with info = b; is_final=false} g
       end
-    | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !")
+    | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!")
     | Prod _ -> 
       begin
 	try
-	  check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
-	  jinfo.otherS () expr_info continuation_tac expr_info
+	  check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
+	  jinfo.otherS () expr_info continuation_tac expr_info g
 	with e when CErrors.noncritical e ->
-	  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
+          user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id)
       end
     | Lambda(n,t,b) -> 
       begin
 	try
-	  check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
-	  jinfo.otherS () expr_info continuation_tac expr_info
+	  check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
+	  jinfo.otherS () expr_info continuation_tac expr_info g
 	with e when CErrors.noncritical e ->
-	  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
+          user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id)
       end
     | Case(ci,t,a,l) -> 
       begin
@@ -461,15 +481,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
 	travel 
 	  jinfo continuation_tac_a 
 	  {expr_info with info = a; is_main_branch = false; 
-	    is_final = false}
+	    is_final = false} g
       end
     | App _ -> 
-      let f,args = decompose_app expr_info.info in 
-      if eq_constr f (expr_info.f_constr) 
-      then jinfo.app_reC (f,args) expr_info continuation_tac expr_info 
+      let f,args = decompose_app sigma expr_info.info in 
+      if EConstr.eq_constr sigma f (expr_info.f_constr) 
+      then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g
       else
       begin
-	match kind_of_term f with 
+	match EConstr.kind sigma f with 
 	  | App _ -> assert false (* f is coming from a decompose_app *)
 	  | Const _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ 
 	  | Sort _ | Prod _ | Var _ -> 
@@ -477,15 +497,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
 	    let new_continuation_tac = 
 	      jinfo.apP (f,args) expr_info continuation_tac in 
 	    travel_args jinfo
-	      expr_info.is_main_branch new_continuation_tac new_infos
-	  | Case _ ->  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)")
-	  | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info)
+	      expr_info.is_main_branch new_continuation_tac new_infos g
+          | Case _ ->  user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)")
+          | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".")
       end
-    | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t}
+    | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g
     | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
       let new_continuation_tac = 
 	jinfo.otherS () expr_info continuation_tac in
-      new_continuation_tac expr_info
+      new_continuation_tac expr_info g
 and travel_args jinfo is_final continuation_tac infos = 
   let (f_args',args) = infos.info in 
   match args with 
@@ -502,27 +522,28 @@ and travel_args jinfo is_final continuation_tac infos =
 	{infos with info=arg;is_final=false} 
 and travel jinfo continuation_tac expr_info = 
   observe_tac 
-    (str jinfo.message ++ Printer.pr_lconstr expr_info.info) 
+    (str jinfo.message ++ pr_leconstr_rd expr_info.info)
     (travel_aux jinfo continuation_tac expr_info)
 
 (* Termination proof *) 
 
 let rec prove_lt hyple g = 
+  let sigma = project g in
   begin
     try
-      let (varx,varz) = match decompose_app (pf_concl g) with
-        | _, x::z::_ when isVar x && isVar z -> x, z
+      let (varx,varz) = match decompose_app sigma (pf_concl g) with
+        | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z
         | _ -> assert false
       in
       let h =
 	List.find (fun id ->
-          match decompose_app (pf_unsafe_type_of g (mkVar id)) with
-            | _, t::_ -> eq_constr t varx
+          match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with
+            | _, t::_ -> EConstr.eq_constr sigma t varx
             | _ -> false
 	) hyple
       in
       let y =
-	List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (mkVar h))))) in
+	List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in
       observe_tclTHENLIST (str "prove_lt1")[
 	Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|])));
 	observe_tac (str "prove_lt") (prove_lt hyple)
@@ -638,12 +659,13 @@ let terminate_others _ expr_info continuation_tac infos =
     ]
   else continuation_tac infos
 
-let terminate_letin (na,b,t,e) expr_info continuation_tac info = 
+let terminate_letin (na,b,t,e) expr_info continuation_tac info g =
+  let sigma = project g in
   let new_e = subst1 info.info e in 
   let new_forbidden = 
     let forbid = 
       try 
-	check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b;
+	check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b;
 	true
       with e when CErrors.noncritical e -> false
     in
@@ -654,7 +676,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info =
 	| Name id -> id::info.forbidden_ids
     else info.forbidden_ids 
   in
-  continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} 
+  continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g
 
 let pf_type c tac gl = 
   let evars, ty = Typing.type_of (pf_env gl) (project gl) c in
@@ -673,7 +695,7 @@ let pf_typel l tac =
   introduced back later; the result is the pair of the tactic and the
   list of hypotheses that have been generalized and cleared. *)
 let mkDestructEq :
-  Id.t list -> constr -> goal sigma -> tactic * Id.t list =
+  Id.t list -> constr -> goal Evd.sigma -> tactic * Id.t list =
   fun not_on_hyp expr g ->
   let hyps = pf_hyps g in
   let to_revert =
@@ -681,7 +703,7 @@ let mkDestructEq :
       (fun decl ->
         let open Context.Named.Declaration in
         let id = get_id decl in
-        if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl))
+        if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl))
         then None else Some id) hyps in
   let to_revert_constr = List.rev_map mkVar to_revert in
   let type_of_expr = pf_unsafe_type_of g expr in
@@ -691,18 +713,18 @@ let mkDestructEq :
     observe_tclTHENLIST (str "mkDestructEq")
      [Proofview.V82.of_tactic (generalize new_hyps);
       (fun g2 ->
-        let changefun patvars = { run = fun sigma ->
-          let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in
-          redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2)
-        } in
+        let changefun patvars sigma =
+          pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2)
+        in
 	Proofview.V82.of_tactic (change_in_concl None changefun) g2);
       Proofview.V82.of_tactic (simplest_case expr)]), to_revert
 
 
 let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g =
+  let sigma = project g in
   let f_is_present =
     try
-      check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a;
+      check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a;
       false
     with e when CErrors.noncritical e ->
       true
@@ -716,25 +738,26 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g =
   let destruct_tac,rev_to_thin_intro = 
     mkDestructEq [expr_info.rec_arg_id] a' g in 
   let to_thin_intro = List.rev rev_to_thin_intro in 
-  observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_lconstr a') 
+  observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a')
     (try
       (tclTHENS
 	 destruct_tac
 	 (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l)
 	 ))
     with 
-      | UserError("Refiner.thensn_tac3",_) 
-      | UserError("Refiner.tclFAIL_s",_) ->
-	(observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} )
+      | UserError(Some "Refiner.thensn_tac3",_) 
+      | UserError(Some "Refiner.tclFAIL_s",_) ->
+        (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} )
 	))
     g
     
-let terminate_app_rec (f,args) expr_info continuation_tac _ = 
-  List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids))
+let terminate_app_rec (f,args) expr_info continuation_tac _ g =
+  let sigma = project g in
+  List.iter (check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids))
     args;
   begin
     try 
-      let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in
+      let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in
       let new_infos = {expr_info with info = v} in 
       observe_tclTHENLIST (str "terminate_app_rec")[
 	continuation_tac new_infos;
@@ -748,7 +771,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ =
 	  ]
 	else
 	  tclIDTAC			       
-      ]    
+      ] g
     with Not_found -> 
       observe_tac (str "terminate_app_rec not found") (tclTHENS
 	(Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args))))
@@ -805,7 +828,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ =
 		      );
 		  ]
 	      ])
-	])
+	]) g
   end
 
 let terminate_info = 
@@ -827,8 +850,9 @@ let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos =
   observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos)
 
 let rec prove_le g = 
+  let sigma = project g in
   let x,z = 
-    let _,args = decompose_app (pf_concl g) in 
+    let _,args = decompose_app sigma (pf_concl g) in 
     (List.hd args,List.hd (List.tl args))
   in 
   tclFIRST[
@@ -836,13 +860,17 @@ let rec prove_le g =
     Proofview.V82.of_tactic (apply (delayed_force le_n));
     begin
       try
-	let matching_fun = 
-	  pf_is_matching g
-	    (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in 
+        let matching_fun c = match EConstr.kind sigma c with
+        | App (c, [| x0 ; _ |]) ->
+          EConstr.isVar sigma x0 &&
+          Id.equal (destVar sigma x0) (destVar sigma x) &&
+          EConstr.is_global sigma (le ()) c
+        | _ -> false
+        in
 	let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g)
 	in 
 	let y = 
-	  let _,args = decompose_app t in 
+	  let _,args = decompose_app sigma t in 
 	  List.hd (List.tl args)
 	in 
 	observe_tclTHENLIST (str "prove_le")[
@@ -858,21 +886,21 @@ let rec make_rewrite_list expr_info max = function
   | [] -> tclIDTAC
   | (_,p,hp)::l -> 
     observe_tac (str "make_rewrite_list") (tclTHENS
-      (observe_tac (str "rewrite heq on " ++ pr_id p ) (
+      (observe_tac (str "rewrite heq on " ++ Id.print p ) (
 	(fun g -> 
+          let sigma = project g in
 	  let t_eq = compute_renamed_type g (mkVar hp) in
 	  let k,def =
-	    let k_na,_,t = destProd t_eq in
-	    let _,_,t  = destProd t in
-	    let def_na,_,_ = destProd t in
-	    Nameops.out_name k_na,Nameops.out_name def_na
+	    let k_na,_,t = destProd sigma t_eq in
+	    let _,_,t  = destProd sigma t in
+	    let def_na,_,_ = destProd sigma t in
+	    Nameops.Name.get_id k_na,Nameops.Name.get_id def_na
 	  in
 	  Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences
 	    true (* dep proofs also: *) true 
 	    (mkVar hp,
-	     ExplicitBindings[Loc.ghost,NamedHyp def,
-			      expr_info.f_constr;Loc.ghost,NamedHyp k,
-			      (f_S max)]) false) g) )
+             ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr);
+                              CAst.make @@ (NamedHyp k, f_S max)]) false) g) )
       )
       [make_rewrite_list expr_info max l;
        observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *)
@@ -886,20 +914,20 @@ let make_rewrite expr_info l hp max =
     (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l))
     (observe_tac (str "make_rewrite") (tclTHENS
        (fun g -> 
+          let sigma = project g in
 	  let t_eq = compute_renamed_type g (mkVar hp) in
 	  let k,def =
-	    let k_na,_,t = destProd t_eq in
-	    let _,_,t  = destProd t in
-	    let def_na,_,_ = destProd t in
-	    Nameops.out_name k_na,Nameops.out_name def_na
+	    let k_na,_,t = destProd sigma t_eq in
+	    let _,_,t  = destProd sigma t in
+	    let def_na,_,_ = destProd sigma t in
+	    Nameops.Name.get_id k_na,Nameops.Name.get_id def_na
 	  in
 	 observe_tac (str "general_rewrite_bindings")
 	   (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences
 	    true (* dep proofs also: *) true 
 	    (mkVar hp,
-	     ExplicitBindings[Loc.ghost,NamedHyp def,
-			      expr_info.f_constr;Loc.ghost,NamedHyp k,
-			      (f_S (f_S max))]) false)) g)
+             ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr);
+                              CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g)
        [observe_tac(str "make_rewrite finalize") (
 	 (* tclORELSE( h_reflexivity) *)
 	 (observe_tclTHENLIST (str "make_rewrite")[
@@ -916,7 +944,7 @@ let make_rewrite expr_info l hp max =
 	    ]))
        ;
 	 observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *)
-	 Proofview.V82.of_tactic (apply (delayed_force le_lt_SS));
+	 Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS)));
 	 observe_tac (str "prove_le (3)") prove_le
 	 ]
        ])  
@@ -953,7 +981,7 @@ let rec destruct_hex expr_info acc l =
 	onNthHypId 1 (fun hp -> 
 	  onNthHypId 2 (fun p -> 
 	    observe_tac 
-	      (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p)
+	      (str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p)
 	      (destruct_hex expr_info ((v,p,hp)::acc) l)
 	  )
 	)
@@ -974,23 +1002,24 @@ let rec intros_values_eq expr_info acc =
 let equation_others _ expr_info continuation_tac infos = 
   if expr_info.is_final && expr_info.is_main_branch 
   then 
-    observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_lconstr expr_info.info)
+    observe_tac (str "equation_others (cont_tac +intros) " ++ pr_leconstr_rd expr_info.info)
 		(tclTHEN 
       (continuation_tac infos) 
-      (observe_tac (str "intros_values_eq equation_others "  ++ Printer.pr_lconstr expr_info.info) (intros_values_eq expr_info [])))
-  else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_lconstr expr_info.info) (continuation_tac infos)
+      (observe_tac (str "intros_values_eq equation_others "  ++ pr_leconstr_rd expr_info.info) (intros_values_eq expr_info [])))
+  else observe_tac (str "equation_others (cont_tac) " ++ pr_leconstr_rd expr_info.info) (continuation_tac infos)
 
 let equation_app f_and_args expr_info continuation_tac infos = 
     if expr_info.is_final && expr_info.is_main_branch 
     then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info [])))
     else continuation_tac infos
 	    
-let equation_app_rec (f,args) expr_info continuation_tac info = 
+let equation_app_rec (f,args) expr_info continuation_tac info g = 
+  let sigma = project g in
   begin
     try
-      let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in
+      let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in
       let new_infos = {expr_info with info = v} in
-      observe_tac (str "app_rec found") (continuation_tac new_infos)
+      observe_tac (str "app_rec found") (continuation_tac new_infos) g
     with Not_found ->
       if expr_info.is_final && expr_info.is_main_branch 
       then 
@@ -998,12 +1027,12 @@ let equation_app_rec (f,args) expr_info continuation_tac info =
 	  [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args)));
 	    continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc};
 	    observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info [])
-	  ]
+	  ] g
       else 
 	observe_tclTHENLIST (str "equation_app_rec1")[
   	  Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args)));
 	  observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc})
-	]
+	] g
   end
 
 let equation_info = 
@@ -1022,10 +1051,13 @@ let prove_eq = travel equation_info
 (* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F
 *)
 let compute_terminate_type nb_args func =
+  let open Term in
+  let open Constr in
+  let open CVars in
   let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in
   let rev_args,b = decompose_prod_n nb_args a_arrow_b in
   let left =
-    mkApp(delayed_force iter,
+    mkApp(delayed_force iter_rd,
 	  Array.of_list
 	    (lift 5 a_arrow_b:: mkRel 3::
 	       constr_of_global func::mkRel 1::
@@ -1034,6 +1066,7 @@ let compute_terminate_type nb_args func =
 	 )
   in
   let right = mkRel 5 in
+  let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in
   let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in
   let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
   let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in
@@ -1046,7 +1079,7 @@ let compute_terminate_type nb_args func =
 		  delayed_force nat,
 		  (mkProd (Name k_id, delayed_force nat,
 			   mkArrow cond result))))|])in
-  let value = mkApp(constr_of_global (delayed_force coq_sig_ref),
+  let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref),
 		    [|b;
 		      (mkLambda (Name v_id, b, nb_iter))|]) in
   compose_prod rev_args value
@@ -1130,25 +1163,27 @@ let termination_proof_header is_mes input_type ids args_id relation
 
 
 
-let rec instantiate_lambda t l =
+let rec instantiate_lambda sigma t l =
   match l with
   | [] -> t
   | a::l ->
-      let (_, _, body) = destLambda t in
-      instantiate_lambda (subst1 a body) l
+      let (_, _, body) = destLambda sigma t in
+      instantiate_lambda sigma (subst1 a body) l
 
 let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num  : tactic =
   begin
     fun g ->
+      let sigma = project g in
       let ids = Termops.ids_of_named_context (pf_hyps g) in
       let func_body = (def_of_const (constr_of_global func)) in
-      let (f_name, _, body1) = destLambda func_body in
+      let func_body = EConstr.of_constr func_body in
+      let (f_name, _, body1) = destLambda sigma func_body in
       let f_id =
 	match f_name with
 	  | Name f_id -> next_ident_away_in_goal f_id ids
-	  | Anonymous -> anomaly (Pp.str "Anonymous function")
+	  | Anonymous -> anomaly (Pp.str "Anonymous function.")
       in
-      let n_names_types,_ = decompose_lam_n nb_args body1 in
+      let n_names_types,_ = decompose_lam_n sigma nb_args body1 in
       let n_ids,ids =
 	List.fold_left
 	  (fun (n_ids,ids) (n_name,_) ->
@@ -1156,13 +1191,13 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	       | Name id ->
 		   let n_id = next_ident_away_in_goal id ids in
 		   n_id::n_ids,n_id::ids
-	       | _ -> anomaly (Pp.str "anonymous argument")
+	       | _ -> anomaly (Pp.str "anonymous argument.")
 	  )
 	  ([],(f_id::ids))
 	  n_names_types
       in
       let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
-      let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in
+      let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in
       termination_proof_header
 	is_mes
 	input_type
@@ -1201,20 +1236,21 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 
 let get_current_subgoals_types () =
   let p = Proof_global.give_me_the_proof () in
-  let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in
-    sigma, List.map (Goal.V82.abstract_type sigma) sgs
+  let sgs,_,_,_,sigma = Proof.proof p in
+  sigma, List.map (Goal.V82.abstract_type sigma) sgs
 
-let build_and_l l =
-  let and_constr =  Coqlib.build_coq_and () in
+exception EmptySubgoals
+let build_and_l sigma l =
+  let and_constr =  Universes.constr_of_global @@ Coqlib.build_coq_and () in
   let conj_constr = coq_conj () in
   let mk_and p1 p2 =
-    Term.mkApp(and_constr,[|p1;p2|]) in
+    mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in
   let rec is_well_founded t = 
-    match kind_of_term t with 
+    match EConstr.kind sigma t with 
       | Prod(_,_,t') -> is_well_founded t'
       | App(_,_) -> 
-	let (f,_) = decompose_app t in 
-	eq_constr f (well_founded ())
+	let (f,_) = decompose_app sigma t in 
+	EConstr.eq_constr sigma f (well_founded ())
       | _ -> 
 	false
   in
@@ -1225,13 +1261,13 @@ let build_and_l l =
   in
   let l = List.sort compare l in 
   let rec f  = function
-    | [] -> failwith "empty list of subgoals!"
+    | [] -> raise EmptySubgoals
     | [p] -> p,tclIDTAC,1
     | p1::pl ->
 	let c,tac,nb = f pl in
 	mk_and p1 c,
 	tclTHENS
-	  (Proofview.V82.of_tactic (apply (constr_of_global conj_constr)))
+	  (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr))))
 	  [tclIDTAC;
 	   tac
 	  ],nb+1
@@ -1245,16 +1281,16 @@ let is_rec_res id =
     String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name
   with Invalid_argument _ -> false
  
-let clear_goals =
+let clear_goals sigma =
   let rec clear_goal t =
-    match kind_of_term t with
+    match EConstr.kind sigma t with
       | Prod(Name id as na,t',b) ->
 	  let b' = clear_goal b in
-	  if noccurn 1 b' && (is_rec_res id)
-	  then Termops.pop b'
+	  if noccurn sigma 1 b' && (is_rec_res id)
+	  then Vars.lift (-1) b'
 	  else if b' == b then t
 	  else mkProd(na,t',b')
-      | _ -> Term.map_constr clear_goal t
+      | _ -> EConstr.map sigma clear_goal t
   in
   List.map clear_goal
 
@@ -1262,41 +1298,41 @@ let clear_goals =
 let build_new_goal_type () =
   let sigma, sub_gls_types = get_current_subgoals_types () in
   (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
-  let sub_gls_types = clear_goals sub_gls_types in
+  let sub_gls_types = clear_goals sigma sub_gls_types in
   (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
-  let res = build_and_l sub_gls_types in
+  let res = build_and_l sigma sub_gls_types in
     sigma, res
 
 let is_opaque_constant c =
   let cb = Global.lookup_constant c in
   match cb.Declarations.const_body with
-    | Declarations.OpaqueDef _ -> Vernacexpr.Opaque None
-    | Declarations.Undef _ -> Vernacexpr.Opaque None
+    | Declarations.OpaqueDef _ -> Vernacexpr.Opaque
+    | Declarations.Undef _ -> Vernacexpr.Opaque
     | Declarations.Def _ -> Vernacexpr.Transparent
 
 let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
   (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *)
-  let current_proof_name = get_current_proof_name () in
+  let current_proof_name = Proof_global.get_current_proof_name () in
   let name = match goal_name with
     | Some s -> s
     | None   ->
 	try add_suffix current_proof_name "_subproof"
 	with e when CErrors.noncritical e ->
-          anomaly (Pp.str "open_new_goal with an unamed theorem")
+          anomaly (Pp.str "open_new_goal with an unamed theorem.")
   in
-  let na = next_global_ident_away name [] in
-  if Termops.occur_existential gls_type then
-    CErrors.error "\"abstract\" cannot handle existentials";
+  let na = next_global_ident_away name Id.Set.empty in
+  if Termops.occur_existential sigma gls_type then
+    CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials");
   let hook _ _ =
     let opacity =
-      let na_ref = Libnames.Ident (Loc.ghost,na) in
+      let na_ref = CAst.make @@ Libnames.Ident na in
       let na_global = Smartlocate.global_with_alias na_ref in
       match na_global with
 	  ConstRef c -> is_opaque_constant c
-	| _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant")
+	| _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.")
     in
     let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in
-    ref_ := Some lemma ;
+    ref_ := Value (EConstr.Unsafe.to_constr lemma);
     let lid = ref [] in
     let h_num = ref (-1) in
     let env = Global.env () in
@@ -1322,8 +1358,9 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
 	       );
 	     ] gls)
       (fun g ->
-	 match kind_of_term (pf_concl g) with
-	   | App(f,_) when eq_constr f (well_founded ()) ->
+        let sigma = project g in
+	 match EConstr.kind sigma (pf_concl g) with
+	   | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) ->
 	       Proofview.V82.of_tactic (Auto.h_auto None [] (Some []))  g
 	   | _ ->
 	       incr h_num;
@@ -1336,7 +1373,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
 			  (Proofview.V82.of_tactic e_assumption);
 		      Eauto.eauto_with_bases
 			(true,5)
-			[{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}]
+			[(fun _ sigma -> (sigma, (Lazy.force refl_equal)))]
 			[Hints.Hint_db.empty empty_transparent_state false]
 		      ]
 		    )
@@ -1366,7 +1403,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
 	 	     (fun c ->
 	 		Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST 
 	 		  [intros;
-	 		   Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*);
+                           Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*);
 	 		   Tacticals.New.tclCOMPLETE Auto.default_auto
 	 		  ])
 	 	     )
@@ -1393,10 +1430,10 @@ let com_terminate
     nb_args ctx
     hook =
   let start_proof ctx (tac_start:tactic) (tac_end:tactic) =
-    let (evmap, env) = Lemmas.get_current_context() in
+    let evd, env = Pfedit.get_current_context () in
     Lemmas.start_proof thm_name
       (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env)
-      ctx (compute_terminate_type nb_args fonctional_ref) hook;
+      ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook;
 
     ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start)));
     ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref
@@ -1410,8 +1447,9 @@ let com_terminate
       using_lemmas tcc_lemma_ref
       (Some tcc_lemma_name)
       (new_goal_type);
-  with Failure "empty list of subgoals!" ->
+  with EmptySubgoals ->
     (* a non recursive function declared with measure ! *)
+    tcc_lemma_ref := Not_needed;
     defined ()
 
 
@@ -1420,9 +1458,11 @@ let com_terminate
 
 let start_equation (f:global_reference) (term_f:global_reference)
   (cont_tactic:Id.t list -> tactic) g =
+  let sigma = project g in
   let ids = pf_ids_of_hyps g in
   let terminate_constr = constr_of_global term_f in
-  let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in
+  let terminate_constr = EConstr.of_constr terminate_constr in
+  let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in
   let x = n_x_id ids nargs in
   observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [
     h_intros x;
@@ -1434,34 +1474,35 @@ let start_equation (f:global_reference) (term_f:global_reference)
 
 let (com_eqn : int -> Id.t ->
        global_reference -> global_reference -> global_reference
-	 -> constr -> unit) =
+	 -> Constr.t -> unit) =
   fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
+    let open CVars in
     let opacity =
       match terminate_ref with
 	| ConstRef c -> is_opaque_constant c
-	| _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant")
+	| _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.")
     in
-    let (evmap, env) = Lemmas.get_current_context() in
-    let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in
+    let evd, env = Pfedit.get_current_context () in
+    let evd = Evd.from_ctx (Evd.evar_universe_context evd) in
     let f_constr = constr_of_global f_ref in
     let equation_lemma_type = subst1 f_constr equation_lemma_type in
     (Lemmas.start_proof eq_name (Global, false, Proof Lemma)
        ~sign:(Environ.named_context_val env)
-       evmap
-       equation_lemma_type
+       evd
+       (EConstr.of_constr equation_lemma_type)
        (Lemmas.mk_hook (fun _ _ -> ()));
      ignore (by
        (Proofview.V82.tactic (start_equation f_ref terminate_ref
 	  (fun  x ->
 	     prove_eq (fun _ -> tclIDTAC)
 	       {nb_arg=nb_arg;
-		f_terminate = constr_of_global terminate_ref; 
-	        f_constr = f_constr; 
+		f_terminate = EConstr.of_constr (constr_of_global terminate_ref); 
+	        f_constr = EConstr.of_constr f_constr; 
 		concl_tac = tclIDTAC;
 		func=functional_ref;
-		info=(instantiate_lambda
-	       		(def_of_const (constr_of_global functional_ref))
-	       		(f_constr::List.map mkVar x)
+		info=(instantiate_lambda Evd.empty
+	       		(EConstr.of_constr (def_of_const (constr_of_global functional_ref)))
+	       		(EConstr.of_constr f_constr::List.map mkVar x)
 		);
 		is_main_branch = true;
 		is_final = true;
@@ -1484,27 +1525,33 @@ let (com_eqn : int -> Id.t ->
 (*      Pp.msgnl (str "eqn finished"); *)
     );;
 
-
 let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
     generate_induction_principle using_lemmas : unit =
+  let open Term in
+  let open Constr in
+  let open CVars in
   let env = Global.env() in
-  let evd = ref (Evd.from_env env) in
-  let function_type = interp_type_evars env evd type_of_f in
+  let evd = Evd.from_env env in
+  let evd, function_type = interp_type_evars env evd type_of_f in
+  let function_type = EConstr.Unsafe.to_constr function_type in
   let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in
   (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type);  *)
-  let ty = interp_type_evars env evd ~impls:rec_impls eq in
-  let evm, nf = Evarutil.nf_evars_and_universes !evd in
-  let equation_lemma_type = nf_betaiotazeta (nf ty) in
+  let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in
+  let ty = EConstr.Unsafe.to_constr ty in
+  let evd, nf = Evarutil.nf_evars_and_universes evd in
+  let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in
   let function_type = nf function_type in
+  let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in
  (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *)
   let res_vars,eq' = decompose_prod equation_lemma_type in
   let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in
-  let eq' = nf_zeta env_eq' eq'  in
+  let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in
+  let eq' = EConstr.Unsafe.to_constr eq' in
   let res =
 (*     Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
 (*     Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
 (*     Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
-    match kind_of_term eq' with
+    match Constr.kind eq' with
       | App(e,[|_;_;eq_fix|]) ->
 	  mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars  eq_fix))
       | _ -> failwith "Recursive Definition (res not eq)"
@@ -1515,21 +1562,24 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   let equation_id = add_suffix function_name "_equation" in
   let functional_id =  add_suffix function_name "_F" in
   let term_id = add_suffix function_name "_terminate" in
-  let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in
+  let functional_ref =
+    let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evd) in
+    declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res
+  in
   (* Refresh the global universes, now including those of _F *)
-  let evm = Evd.from_env (Global.env ()) in
+  let evd = Evd.from_env (Global.env ()) in
   let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in
   let relation, evuctx =
-    interp_constr env_with_pre_rec_args evm r
+    interp_constr env_with_pre_rec_args evd r
   in
-  let evm = Evd.from_ctx evuctx in
+  let evd = Evd.from_ctx evuctx in
   let tcc_lemma_name = add_suffix function_name "_tcc" in
-  let tcc_lemma_constr = ref None in
+  let tcc_lemma_constr = ref Undefined in
   (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
   let hook _ _ = 
     let term_ref = Nametab.locate (qualid_of_ident term_id) in
     let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
-    let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.ghost,term_id)] in
+    let _ = Extraction_plugin.Table.extraction_inline true [CAst.make @@ Ident term_id] in
     (*     message "start second proof"; *)
     let stop = 
       try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type);
@@ -1538,7 +1588,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
 	begin
 	  if do_observe ()
 	  then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e)
-	  else CErrors.errorlabstrm "Cannot create equation Lemma"
+	  else CErrors.user_err ~hdr:"Cannot create equation Lemma"
                (str "Cannot create equation lemma." ++ spc () ++ 
                 str "This may be because the function is nested-recursive.")
 	  ;
@@ -1552,23 +1602,26 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
       and functional_ref = destConst (constr_of_global functional_ref)
       and eq_ref = destConst (constr_of_global eq_ref) in
       generate_induction_principle f_ref tcc_lemma_constr
-	functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
-      if Flags.is_verbose ()
-      then msgnl (h 1 (Ppconstr.pr_id function_name ++
+        functional_ref eq_ref rec_arg_num
+        (EConstr.of_constr rec_arg_type)
+        (nb_prod evd (EConstr.of_constr res)) relation;
+      Flags.if_verbose
+        msgnl (h 1 (Ppconstr.pr_id function_name ++
 			 spc () ++ str"is defined" )++ fnl () ++
 		    h 1 (Ppconstr.pr_id equation_id ++
 			   spc () ++ str"is defined" )
       )
   in
-  States.with_state_protection_on_exception (fun () ->
+  (* XXX STATE Why do we need this... why is the toplevel protection not enought *)
+  funind_purify (fun () ->
     com_terminate
       tcc_lemma_name
       tcc_lemma_constr
       is_mes functional_ref
-      rec_arg_type
+      (EConstr.of_constr rec_arg_type)
       relation rec_arg_num
       term_id
       using_lemmas
       (List.length res_vars)
-      evm (Lemmas.mk_hook hook))
+      evd (Lemmas.mk_hook hook))
     ()
diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli
index f60eedbe..b95d64ce 100644
--- a/plugins/funind/recdef.mli
+++ b/plugins/funind/recdef.mli
@@ -1,20 +1,19 @@
+open Constr
 
-
-(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *)
 val tclUSER_if_not_mes : 
-  Proof_type.tactic ->
+  Tacmach.tactic ->
   bool -> 
   Names.Id.t list option -> 
-  Proof_type.tactic
+  Tacmach.tactic
 val recursive_definition :  
 bool ->
            Names.Id.t ->
            Constrintern.internalization_env ->
            Constrexpr.constr_expr ->
            Constrexpr.constr_expr ->
-           int -> Constrexpr.constr_expr -> (Term.pconstant ->
-            Term.constr option ref ->
-            Term.pconstant ->
-            Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit
+           int -> Constrexpr.constr_expr -> (pconstant ->
+            Indfun_common.tcc_lemma_value ref ->
+            pconstant ->
+            pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit
 
 
diff --git a/plugins/funind/recdef_plugin.mlpack b/plugins/funind/recdef_plugin.mlpack
index 2b443f2a..755fa4f8 100644
--- a/plugins/funind/recdef_plugin.mlpack
+++ b/plugins/funind/recdef_plugin.mlpack
@@ -6,5 +6,4 @@ Functional_principles_proofs
 Functional_principles_types
 Invfun
 Indfun
-Merge
 G_indfun
diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget
deleted file mode 100644
index 33c96830..00000000
--- a/plugins/funind/vo.itarget
+++ /dev/null
@@ -1 +0,0 @@
-Recdef.vo