Imported Upstream version 8.0pl1upstream/8.0pl1

42 files changed, 8578 insertions, 0 deletions

diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
new file mode 100644
index 00000000..21098a57
--- /dev/null
+++ b/toplevel/cerrors.ml
@@ -0,0 +1,134 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: cerrors.ml,v 1.12.2.2 2004/07/16 20:48:17 herbelin Exp $ *)
+
+open Pp
+open Util
+open Ast
+open Indtypes
+open Type_errors
+open Pretype_errors
+open Lexer
+
+let print_loc loc =
+  if loc = dummy_loc then 
+    (str"<unknown>")
+  else 
+    let loc = unloc loc in
+    (int (fst loc) ++ str"-" ++ int (snd loc))
+
+let guill s = "\""^s^"\""
+
+let where s =
+  if !Options.debug then  (str"in " ++ str s ++ str":" ++ spc ()) else (mt ())
+
+let report () = (str "." ++ spc () ++ str "Please report.")
+
+(* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *)
+
+let rec explain_exn_default = function
+  | Stream.Failure -> 
+      hov 0 (str "Anomaly: uncaught Stream.Failure.")
+  | Stream.Error txt -> 
+      hov 0 (str "Syntax error: " ++ str txt)
+  | Token.Error txt -> 
+      hov 0 (str "Syntax error: " ++ str txt)
+  | Sys_error msg -> 
+      hov 0 (str "Anomaly: uncaught exception Sys_error " ++ str (guill msg) ++ report ())
+  | UserError(s,pps) -> 
+      hov 1 (str "User error: " ++ where s ++ pps)
+  | Out_of_memory -> 
+      hov 0 (str "Out of memory")
+  | Stack_overflow -> 
+      hov 0 (str "Stack overflow")
+  | Ast.No_match s -> 
+      hov 0 (str "Anomaly: Ast matching error: " ++ str s ++ report ())
+  | Anomaly (s,pps) -> 
+      hov 1 (str "Anomaly: " ++ where s ++ pps ++ report ())
+  | Match_failure(filename,pos1,pos2) ->
+      hov 1 (str "Anomaly: Match failure in file " ++ str (guill filename) ++ 
+      if Sys.ocaml_version = "3.06" then
+		   (str " from character " ++ int pos1 ++ 
+                    str " to " ++ int pos2)
+		 else
+		   (str " at line " ++ int pos1 ++
+		    str " character " ++ int pos2)
+	           ++ report ())
+  | Not_found -> 
+      hov 0 (str "Anomaly: uncaught exception Not_found" ++ report ())
+  | Failure s -> 
+      hov 0 (str "Anomaly: uncaught exception Failure " ++ str (guill s) ++ report ())
+  | Invalid_argument s -> 
+      hov 0 (str "Anomaly: uncaught exception Invalid_argument " ++ str (guill s) ++ report ())
+  | Sys.Break -> 
+      hov 0 (fnl () ++ str "User Interrupt.")
+  | Univ.UniverseInconsistency -> 
+      hov 0 (str "Error: Universe Inconsistency.")
+  | TypeError(ctx,te) -> 
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te)
+  | PretypeError(ctx,te) ->
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te)
+  | InductiveError e -> 
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e)
+  | Cases.PatternMatchingError (env,e) -> 
+      hov 0
+	(str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e)
+  | Logic.RefinerError e -> 
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e)
+  | Nametab.GlobalizationError q ->
+      hov 0 (str "Error:" ++ spc () ++
+	       str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
+	       spc () ++ str "was not found" ++ 
+	       spc () ++ str "in the current" ++ spc () ++ str "environment")
+  | Nametab.GlobalizationConstantError q ->
+      hov 0 (str "Error:" ++ spc () ++
+	       str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q)
+  | Refiner.FailError (i,s) ->
+      let s = if s="" then "" else " \""^s^"\"" in
+      hov 0 (str "Error: Tactic failure" ++ str s ++
+             if i=0 then mt () else str " (level " ++ int i ++ str").")
+  | Stdpp.Exc_located (loc,exc) ->
+      hov 0 ((if loc = dummy_loc then (mt ())
+               else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
+               ++ explain_exn_default exc)
+  | Lexer.Error Illegal_character -> 
+      hov 0 (str "Syntax error: Illegal character.")
+  | Lexer.Error Unterminated_comment -> 
+      hov 0 (str "Syntax error: Unterminated comment.")
+  | Lexer.Error Unterminated_string -> 
+      hov 0 (str "Syntax error: Unterminated string.")
+  | Lexer.Error Undefined_token -> 
+      hov 0 (str "Syntax error: Undefined token.")
+  | Lexer.Error (Bad_token s) -> 
+      hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".")
+  | Assert_failure (s,b,e) ->
+      hov 0 (str "Anomaly: assert failure" ++ spc () ++
+	       (if s <> "" then 
+		 if Sys.ocaml_version = "3.06" then
+		   (str ("(file \"" ^ s ^ "\", characters ") ++ 
+		    int b ++ str "-" ++ int e ++ str ")")
+		 else
+		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
+		    str ", characters " ++ int e ++ str "-" ++
+		    int (e+6) ++ str ")")
+	       else
+		 (mt ())) ++
+	       report ())
+  | reraise ->
+      hov 0 (str "Anomaly: Uncaught exception " ++ 
+	       str (Printexc.to_string reraise) ++ report ())
+
+let raise_if_debug e =
+  if !Options.debug then raise e
+
+let _ = Tactic_debug.explain_logic_error := explain_exn_default
+
+let explain_exn_function = ref explain_exn_default
+
+let explain_exn e = !explain_exn_function e
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
new file mode 100644
index 00000000..09d79cec
--- /dev/null
+++ b/toplevel/cerrors.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: cerrors.mli,v 1.2.6.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+(*i*)
+
+(* Error report. *)
+
+val print_loc : loc -> std_ppcmds
+
+val explain_exn : exn -> std_ppcmds
+
+val explain_exn_function : (exn -> std_ppcmds) ref
+val explain_exn_default : exn -> std_ppcmds
+
+val raise_if_debug : exn -> unit
diff --git a/toplevel/class.ml b/toplevel/class.ml
new file mode 100644
index 00000000..429469b1
--- /dev/null
+++ b/toplevel/class.ml
@@ -0,0 +1,460 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: class.ml,v 1.44.2.2 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Nameops
+open Term
+open Termops
+open Inductive
+open Declarations
+open Entries
+open Environ
+open Inductive
+open Lib
+open Classops
+open Declare
+open Libnames
+open Nametab
+open Decl_kinds
+open Safe_typing
+
+let strength_min4 stre1 stre2 stre3 stre4 =
+  strength_min ((strength_min (stre1,stre2)),(strength_min (stre3,stre4)))
+
+let id_of_varid c = match kind_of_term c with
+  | Var id -> id
+  | _ -> anomaly "class__id_of_varid"
+
+(* lf liste des variable dont depend la coercion f
+   lc liste des variable dont depend la classe source *)
+
+let rec stre_unif_cond = function
+  | ([],[]) -> Global
+  | (v::l,[]) -> variable_strength v
+  | ([],v::l) -> variable_strength v
+  | (v1::l1,v2::l2) ->
+      if v1=v2 then 
+	stre_unif_cond (l1,l2)
+      else
+	let stre1 = (variable_strength v1)
+	and stre2 = (variable_strength v2) in 
+	strength_min (stre1,stre2)
+
+(* Errors *)
+
+type coercion_error_kind =
+  | AlreadyExists
+  | NotAFunction
+  | NoSource of cl_typ option
+  | ForbiddenSourceClass of cl_typ
+  | NotUniform
+  | NoTarget
+  | WrongTarget of cl_typ * cl_typ
+  | NotAClass of global_reference
+  | NotEnoughClassArgs of cl_typ
+
+exception CoercionError of coercion_error_kind
+
+let explain_coercion_error g = function
+  | AlreadyExists ->
+      (Printer.pr_global g ++ str" is already a coercion")
+  | NotAFunction ->
+      (Printer.pr_global g ++ str" is not a function")
+  | NoSource (Some cl) ->
+      (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " 
+       ++ Printer.pr_global g)
+  | NoSource None ->
+      (str ": cannot find the source class of " ++ Printer.pr_global g)
+  | ForbiddenSourceClass cl ->
+      pr_class cl ++ str " cannot be a source class"
+  | NotUniform ->
+      (Printer.pr_global g ++
+         str" does not respect the inheritance uniform condition");
+  | NoTarget ->
+      (str"Cannot find the target class")
+  | WrongTarget (clt,cl) ->
+      (str"Found target class " ++ pr_class cl ++
+       str " instead of " ++ pr_class clt)
+  | NotAClass ref ->
+      (str "Type of " ++ Printer.pr_global ref ++
+         str " does not end with a sort")
+  | NotEnoughClassArgs cl ->
+      (str"Wrong number of parameters for " ++ pr_class cl)
+
+(* Verifications pour l'ajout d'une classe *)
+
+let rec arity_sort a = match kind_of_term a with
+  | Sort (Prop _ | Type _) -> 0
+  | Prod (_,_,c) -> (arity_sort c) +1
+  | LetIn (_,_,_,c) -> arity_sort c    (* Utile ?? *)
+  | Cast (c,_) -> arity_sort c
+  | _ -> raise Not_found
+
+let check_reference_arity ref =
+  try arity_sort (Global.type_of_global ref)
+  with Not_found -> raise (CoercionError (NotAClass ref))
+
+let check_arity = function
+  | CL_FUN | CL_SORT -> 0
+  | CL_CONST sp -> check_reference_arity (ConstRef sp)
+  | CL_SECVAR sp -> check_reference_arity (VarRef sp)
+  | CL_IND sp  -> check_reference_arity (IndRef sp)
+
+(* try_add_class : cl_typ -> strength option -> bool -> unit *)
+
+let strength_of_cl = function 
+  | CL_CONST kn -> constant_strength (sp_of_global (ConstRef kn))
+  | CL_SECVAR sp -> variable_strength sp
+  | _ -> Global
+
+let try_add_class cl streopt fail_if_exists =
+  if not (class_exists cl) then
+    let p = check_arity cl in
+    let stre' = strength_of_cl cl in 
+    let stre = match streopt with
+      | Some stre -> strength_min (stre,stre')
+      | None -> stre'
+    in
+    declare_class (cl,stre,p)
+  else
+    if fail_if_exists then errorlabstrm "try_add_new_class" 
+      (pr_class cl ++ str " is already a class")
+
+
+(* Coercions *)
+
+(* check that the computed target is the provided one *)
+let check_target clt = function
+  | Some cl when cl <> clt -> raise (CoercionError (WrongTarget(clt,cl)))
+  | _ -> ()
+
+(* condition d'heritage uniforme *)
+
+let uniform_cond nargs lt = 
+  let rec aux = function
+    | (0,[]) -> true
+    | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l))
+    | _ -> false
+  in 
+  aux (nargs,lt)
+
+let id_of_cl  = function
+  | CL_FUN -> id_of_string "FUNCLASS"
+  | CL_SORT -> id_of_string "SORTCLASS"
+  | CL_CONST kn -> id_of_label (label kn)
+  | CL_IND ind ->
+      let (_,mip) = Global.lookup_inductive ind in
+      mip.mind_typename
+  | CL_SECVAR id -> id
+
+let class_of_ref = function
+  | ConstRef sp -> CL_CONST sp
+  | IndRef sp -> CL_IND sp
+  | VarRef id -> CL_SECVAR id
+  | ConstructRef _ as c -> 
+      errorlabstrm "class_of_ref"
+	(str "Constructors, such as " ++ Printer.pr_global c ++ 
+	   str " cannot be used as class")
+
+(* 
+lp est la liste (inverse'e) des arguments de la coercion
+ids est le nom de la classe source
+sps_opt est le sp de la classe source dans le cas des structures
+retourne:
+la classe source
+nbre d'arguments de la classe
+le constr de la class
+la liste des variables dont depend la classe source
+l'indice de la classe source dans la liste lp
+*)
+
+let get_source lp source =
+  match source with
+    | None ->
+	let (cl1,lv1) =
+          match lp with
+	    | [] -> raise Not_found
+            | t1::_ -> find_class_type t1
+        in 
+	(cl1,lv1,1)
+    | Some cl ->
+	let rec aux = function
+	  | [] -> raise Not_found
+	  | t1::lt ->
+	      try 
+		let cl1,lv1 = find_class_type t1 in
+		if cl = cl1 then cl1,lv1,(List.length lt+1)
+		else raise Not_found
+              with Not_found -> aux lt
+	in aux (List.rev lp)
+
+let get_target t ind =
+  if (ind > 1) then 
+    CL_FUN
+  else 
+    fst (find_class_type t)
+
+let prods_of t = 
+  let rec aux acc d = match kind_of_term d with
+    | Prod (_,c1,c2) -> aux (c1::acc) c2
+    | Cast (c,_) -> aux acc c
+    | _ -> (d,acc)
+  in 
+  aux [] t
+
+let get_strength stre ref cls clt =
+  let stres = (snd (class_info cls)).cl_strength in
+  let stret = (snd (class_info clt)).cl_strength in
+  let stref = strength_of_global ref in
+(* 01/00: Supprimé la prise en compte de la force des variables locales. Sens ?
+  let streunif = stre_unif_cond (s_vardep,f_vardep) in
+ *)
+  let streunif = Global in
+  let stre' = strength_min4 stres stret stref streunif in
+  strength_min (stre,stre')
+
+(* coercion identité *)
+
+let error_not_transparent source =
+  errorlabstrm "build_id_coercion"
+    (pr_class source ++ str " must be a transparent constant")
+
+let build_id_coercion idf_opt source =
+  let env = Global.env () in
+  let vs = match source with
+    | CL_CONST sp -> mkConst sp
+    | _ -> error_not_transparent source in
+  let c = match constant_opt_value env (destConst vs) with
+    | Some c -> c
+    | None -> error_not_transparent source in
+  let lams,t = Sign.decompose_lam_assum c in
+  let val_f =
+    it_mkLambda_or_LetIn
+      (mkLambda (Name (id_of_string "x"),
+		 applistc vs (extended_rel_list 0 lams),
+		 mkRel 1))
+       lams
+  in
+  let typ_f =
+    it_mkProd_wo_LetIn
+      (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t))
+      lams
+  in
+  (* juste pour verification *)
+  let _ = 
+    if not
+      (Reductionops.is_conv_leq env Evd.empty
+	(Typing.type_of env Evd.empty val_f) typ_f)
+    then
+      error ("cannot be defined as coercion - "^
+             "maybe a bad number of arguments") 
+  in
+  let idf =
+    match idf_opt with
+      | Some idf -> idf
+      | None ->
+	  id_of_string ("Id_"^(string_of_class source)^"_"^
+                        (string_of_class (fst (find_class_type t)))) 
+  in
+  let constr_entry = (* Cast is necessary to express [val_f] is identity *)
+    DefinitionEntry
+      { const_entry_body = mkCast (val_f, typ_f);
+	const_entry_type = Some typ_f;
+        const_entry_opaque = false } in
+  let (_,kn) = declare_constant idf (constr_entry,Decl_kinds.IsDefinition) in
+  ConstRef kn
+
+let check_source = function
+| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s))
+| _ -> ()
+
+(* 
+nom de la fonction coercion
+strength de f
+nom de la classe source (optionnel)
+sp de la classe source (dans le cas des structures)
+nom de la classe target (optionnel)
+booleen "coercion identite'?"
+
+lorque source est None alors target est None aussi.
+*)
+
+let add_new_coercion_core coef stre source target isid =
+  check_source source;
+  let env = Global.env () in
+  let v = constr_of_reference coef in
+  let vj = Retyping.get_judgment_of env Evd.empty v in
+  if coercion_exists coef then raise (CoercionError AlreadyExists);
+  let tg,lp = prods_of (vj.uj_type) in
+  let llp = List.length lp in
+  if llp = 0 then raise (CoercionError NotAFunction);
+  let (cls,lvs,ind) =
+    try 
+      get_source lp source
+    with Not_found ->
+      raise (CoercionError (NoSource source))
+  in
+  check_source (Some cls);
+  if not (uniform_cond (llp-ind) lvs) then
+    raise (CoercionError NotUniform);
+  let clt =
+    try
+      get_target tg ind 
+    with Not_found ->
+      raise (CoercionError NoTarget)
+  in
+  check_target clt target;
+  try_add_class cls None false;
+  try_add_class clt None false;
+  let stre' = get_strength stre coef cls clt in
+  declare_coercion coef vj stre' isid cls clt (List.length lvs)
+
+let try_add_new_coercion_core ref b c d e =
+  try add_new_coercion_core ref b c d e
+  with CoercionError e ->
+      errorlabstrm "try_add_new_coercion_core" (explain_coercion_error ref e)
+
+let try_add_new_coercion ref stre =
+  try_add_new_coercion_core ref stre None None false
+
+let try_add_new_coercion_subclass cl stre =
+  let coe_ref = build_id_coercion None cl in
+  try_add_new_coercion_core coe_ref stre (Some cl) None true
+
+let try_add_new_coercion_with_target ref stre ~source ~target =
+  try_add_new_coercion_core ref stre (Some source) (Some target) false
+
+let try_add_new_identity_coercion id stre ~source ~target =
+  let ref = build_id_coercion (Some id) source in
+  try_add_new_coercion_core ref stre (Some source) (Some target) true
+
+let try_add_new_coercion_with_source ref stre ~source =
+  try_add_new_coercion_core ref stre (Some source) None false
+
+let add_coercion_hook stre ref = 
+  try_add_new_coercion ref stre;
+  Options.if_verbose message
+    (string_of_qualid (shortest_qualid_of_global Idset.empty ref)
+    ^ " is now a coercion")
+
+let add_subclass_hook stre ref =
+  let cl = class_of_ref ref in
+  try_add_new_coercion_subclass cl stre
+
+(* try_add_new_class : global_reference -> strength -> unit *)
+
+let class_of_global = function
+  | VarRef sp -> CL_SECVAR sp
+  | ConstRef sp -> CL_CONST sp
+  | IndRef sp -> CL_IND sp
+  | ConstructRef _ as ref -> raise (CoercionError (NotAClass ref))
+
+let try_add_new_class ref stre =
+  try try_add_class (class_of_global ref) (Some stre) true
+  with CoercionError e ->
+    errorlabstrm "try_add_new_class" (explain_coercion_error ref e)
+
+(* fonctions pour le discharge: encore un peu sale mais ça s'améliore *)
+
+type coercion_entry = 
+    global_reference * strength * bool * cl_typ * cl_typ * int
+
+let add_new_coercion (ref,stre,isid,cls,clt,n) =
+  (* Un peu lourd, tout cela pour trouver l'instance *)
+  let env = Global.env () in
+  let v = constr_of_reference ref in
+  let vj = Retyping.get_judgment_of env Evd.empty v in
+  declare_coercion ref vj stre isid cls clt n
+
+let count_extra_abstractions hyps ids_to_discard =
+  let _,n =
+    List.fold_left
+      (fun (hyps,n as sofar) id -> 
+	 match hyps with
+	   | (hyp,None,_)::rest when id = hyp ->(rest, n+1)
+	   | _ -> sofar)
+      (hyps,0) ids_to_discard
+  in n
+
+let defined_in_sec kn olddir = 
+  let _,dir,_ = repr_kn kn in
+    dir = olddir
+
+(* This moves the global path one step below *)
+let process_global olddir = function
+  | VarRef _ ->
+      anomaly "process_global only processes global surviving the section"
+  | ConstRef kn as x ->
+      if defined_in_sec kn olddir then
+        let newkn = Lib.make_kn (id_of_label (label kn)) in
+        ConstRef newkn
+      else x
+  | IndRef (kn,i) as x -> 
+      if defined_in_sec kn olddir then
+        let newkn = Lib.make_kn (id_of_label (label kn)) in
+        IndRef (newkn,i)
+      else x
+  | ConstructRef ((kn,i),j) as x -> 
+      if defined_in_sec kn olddir then
+        let newkn = Lib.make_kn (id_of_label (label kn)) in
+        ConstructRef ((newkn,i),j)
+      else x
+
+let process_class olddir ids_to_discard x =
+  let (cl,{cl_strength=stre; cl_param=p}) = x in
+(*  let env = Global.env () in*)
+  match cl with 
+    | CL_SECVAR _ -> x
+    | CL_CONST kn -> 
+       if defined_in_sec kn olddir then
+         let newkn = Lib.make_kn (id_of_label (label kn)) in
+	 let hyps = (Global.lookup_constant kn).const_hyps in
+	 let n = count_extra_abstractions hyps ids_to_discard in
+           (CL_CONST newkn,{cl_strength=stre;cl_param=p+n})
+       else 
+	 x
+    | CL_IND (kn,i) ->
+	if defined_in_sec kn olddir then
+          let newkn = Lib.make_kn (id_of_label (label kn)) in
+	  let hyps = (Global.lookup_mind kn).mind_hyps in
+	  let n = count_extra_abstractions hyps ids_to_discard in
+          (CL_IND (newkn,i),{cl_strength=stre;cl_param=p+n})
+        else 
+	  x
+    | _ -> anomaly "process_class" 
+
+let process_cl sec_sp cl =
+  match cl with
+    | CL_SECVAR id -> cl
+    | CL_CONST kn ->
+	if defined_in_sec kn sec_sp then
+          let newkn = Lib.make_kn (id_of_label (label kn)) in
+          CL_CONST newkn
+        else 
+	  cl
+    | CL_IND (kn,i) ->
+	if defined_in_sec kn sec_sp then
+          let newkn = Lib.make_kn (id_of_label (label kn)) in
+          CL_IND (newkn,i)
+        else 
+	  cl
+    | _ -> cl
+
+let process_coercion olddir ids_to_discard (coe,coeinfo,cls,clt) =
+  let hyps = context_of_global_reference coe in
+  let nargs = count_extra_abstractions hyps ids_to_discard in
+  (process_global olddir coe,
+   coercion_strength coeinfo,
+   coercion_identity coeinfo,
+   process_cl olddir cls,
+   process_cl olddir clt,
+   nargs + coercion_params coeinfo)
diff --git a/toplevel/class.mli b/toplevel/class.mli
new file mode 100644
index 00000000..b0350985
--- /dev/null
+++ b/toplevel/class.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: class.mli,v 1.17.6.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Classops
+open Declare
+open Libnames
+open Decl_kinds
+open Nametab
+(*i*)
+
+(* Classes and coercions. *)
+
+(* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
+   from [src] to [tg] *)
+val try_add_new_coercion_with_target : global_reference -> strength -> 
+  source:cl_typ -> target:cl_typ ->  unit
+
+(* [try_add_new_coercion ref s] declares [ref], assumed to be of type
+   [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *)
+val try_add_new_coercion : global_reference -> strength -> unit
+
+(* [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
+   transparent constant which unfolds to some class [tg]; it declares
+   an identity coercion from [cst] to [tg], named something like
+   ["Id_cst_tg"] *)
+val try_add_new_coercion_subclass : cl_typ -> strength -> unit
+
+(* [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
+   from [src] to [tg] where the target is inferred from the type of [ref] *)
+val try_add_new_coercion_with_source : global_reference -> strength ->
+  source:cl_typ -> unit
+
+(* [try_add_new_identity_coercion id s src tg] enriches the
+   environment with a new definition of name [id] declared as an
+   identity coercion from [src] to [tg] *)
+val try_add_new_identity_coercion : identifier -> strength ->
+  source:cl_typ -> target:cl_typ -> unit
+
+val add_coercion_hook : Tacexpr.declaration_hook
+
+val add_subclass_hook : Tacexpr.declaration_hook
+
+(* [try_add_new_class ref] declares [ref] as a new class; usually,
+   this is done implicitely by [try_add_new_coercion]'s functions *)
+val try_add_new_class : global_reference -> strength -> unit
+
+(*s This is used for the discharge *)
+type coercion_entry
+
+val add_new_coercion : coercion_entry -> unit
+
+val process_class :
+  dir_path -> identifier list -> 
+    (cl_typ * cl_info_typ) -> (cl_typ * cl_info_typ)
+val process_coercion :
+  dir_path -> identifier list -> coercion -> coercion_entry
+
+val class_of_ref : global_reference -> cl_typ
diff --git a/toplevel/command.ml b/toplevel/command.ml
new file mode 100644
index 00000000..b9a47781
--- /dev/null
+++ b/toplevel/command.ml
@@ -0,0 +1,701 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: command.ml,v 1.116.2.1 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Term
+open Termops
+open Declarations
+open Entries
+open Inductive
+open Environ
+open Reduction
+open Tacred
+open Declare
+open Nametab
+open Names
+open Libnames
+open Nameops
+open Topconstr
+open Library
+open Libobject
+open Constrintern
+open Proof_type
+open Tacmach
+open Safe_typing
+open Nametab
+open Typeops
+open Indtypes
+open Vernacexpr
+open Decl_kinds
+open Pretyping
+open Symbols
+
+let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,a,b))
+let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,a,b))
+
+let rec abstract_rawconstr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_rawconstr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl
+        (abstract_rawconstr c bl)
+
+let rec prod_rawconstr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_rawconstr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkProdC([x],t,b)) idl
+        (prod_rawconstr c bl)
+
+let rec destSubCast c = match kind_of_term c with
+  | Lambda (x,t,c) -> 
+      let (b,u) = destSubCast c in mkLambda (x,t,b), mkProd (x,t,u)
+  | LetIn (x,b,t,c) ->
+      let (d,u) = destSubCast c in mkLetIn (x,b,t,d), mkLetIn (x,b,t,u)
+  | Cast (b,u) -> (b,u)
+  | _ -> assert false
+
+let rec adjust_conclusion a cs = function
+  | CProdN (loc,bl,c) -> CProdN (loc,bl,adjust_conclusion a cs c)
+  | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,adjust_conclusion a cs c)
+  | CHole loc ->
+      let (nar,name,params) = a in
+      if nar <> 0 then
+	user_err_loc (loc,"",
+	  str "Cannot infer the non constant arguments of the conclusion of "
+	  ++ pr_id cs);
+      let args = List.map (fun id -> CRef(Ident(loc,id))) params in
+      CAppExpl (loc,(None,Ident(loc,name)),List.rev args)
+  | c -> c
+
+(* Commands of the interface *)
+
+(* 1| Constant definitions *)
+
+let definition_message id =
+  if_verbose message ((string_of_id id) ^ " is defined")
+
+let constant_entry_of_com (bl,com,comtypopt,opacity) =
+  let sigma = Evd.empty in
+  let env = Global.env() in
+  match comtypopt with
+      None -> 
+	let b = abstract_rawconstr com bl in
+	let j = judgment_of_rawconstr sigma env b in
+	{ const_entry_body = j.uj_val;
+	  const_entry_type = Some (Evarutil.refresh_universes j.uj_type);
+          const_entry_opaque = opacity }
+    | Some comtyp ->
+	(* We use a cast to avoid troubles with evars in comtyp *)
+	(* that can only be resolved knowing com *)
+	let b = abstract_rawconstr (mkCastC (com,comtyp)) bl in
+	let (body,typ) = destSubCast (interp_constr sigma env b) in
+	{ const_entry_body = body;
+	  const_entry_type = Some typ;
+          const_entry_opaque = opacity }
+
+let red_constant_entry ce = function
+  | None -> ce
+  | Some red ->
+      let body = ce.const_entry_body in
+      { ce with const_entry_body = 
+	  reduction_of_redexp red (Global.env()) Evd.empty body }
+
+let declare_global_definition ident ce local =
+  let (_,kn) = declare_constant ident (DefinitionEntry ce,IsDefinition) in
+  if local = Local then
+    msg_warning (pr_id ident ++ str" is declared as a global definition");
+  definition_message ident;
+  ConstRef kn
+
+let declare_definition ident (local,_) bl red_option c typopt hook =
+  let ce = constant_entry_of_com (bl,c,typopt,false) in
+  if bl<>[] && red_option <> None then 
+    error "Evaluation under a local context not supported";
+  let ce' = red_constant_entry ce red_option in
+  let r = match local with
+    | Local when Lib.sections_are_opened () ->
+        let c =
+          SectionLocalDef(ce'.const_entry_body,ce'.const_entry_type,false) in
+        let _ = declare_variable ident (Lib.cwd(), c, IsDefinition) in
+        definition_message ident;
+        if Pfedit.refining () then 
+          msgerrnl (str"Warning: Local definition " ++ pr_id ident ++ 
+          str" is not visible from current goals");
+        VarRef ident
+    | (Global|Local) ->
+        declare_global_definition ident ce' local in
+  hook local r
+
+let syntax_definition ident c local onlyparse =
+  let c = snd (interp_aconstr [] [] c) in
+  let onlyparse = !Options.v7_only or onlyparse in
+  Syntax_def.declare_syntactic_definition local ident onlyparse c
+
+(* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
+
+let assumption_message id =
+  if_verbose message ((string_of_id id) ^ " is assumed")
+
+let declare_one_assumption is_coe (local,kind) c (_,ident) =
+  let r = match local with
+    | Local when Lib.sections_are_opened () ->
+        let r = 
+          declare_variable ident 
+            (Lib.cwd(), SectionLocalAssum c, IsAssumption kind) in
+        assumption_message ident;
+        if is_verbose () & Pfedit.refining () then 
+          msgerrnl (str"Warning: Variable " ++ pr_id ident ++ 
+          str" is not visible from current goals");
+        VarRef ident
+    | (Global|Local) ->
+        let (_,kn) =
+          declare_constant ident (ParameterEntry c, IsAssumption kind) in
+        assumption_message ident;
+        if local=Local & Options.is_verbose () then
+          msg_warning (pr_id ident ++ str" is declared as a parameter" ++
+          str" because it is at a global level");
+        ConstRef kn in
+  if is_coe then Class.try_add_new_coercion r local
+
+let declare_assumption idl is_coe k bl c =
+  let c = prod_rawconstr c bl in
+  let c = interp_type Evd.empty (Global.env()) c in
+  List.iter (declare_one_assumption is_coe k c) idl
+
+(* 3a| Elimination schemes for mutual inductive definitions *)
+
+open Indrec
+
+let non_type_eliminations = 
+  [ (InProp,elimination_suffix InProp);
+    (InSet,elimination_suffix InSet) ]
+
+let declare_one_elimination ind =
+  let (mib,mip) = Global.lookup_inductive ind in 
+  let mindstr = string_of_id mip.mind_typename in
+  let declare s c t =
+    let id = id_of_string s in
+    let kn = Declare.declare_internal_constant id
+      (DefinitionEntry
+        { const_entry_body = c;
+          const_entry_type = t;
+          const_entry_opaque = false }, 
+       Decl_kinds.IsDefinition) in
+    definition_message id;
+    kn
+  in
+  let env = Global.env () in
+  let sigma = Evd.empty in
+  let elim_scheme = Indrec.build_indrec env sigma ind in
+  let npars = mip.mind_nparams in
+  let make_elim s = Indrec.instanciate_indrec_scheme s npars elim_scheme in
+  let kelim = mip.mind_kelim in
+  (* in case the inductive has a type elimination, generates only one
+     induction scheme, the other ones share the same code with the
+     apropriate type *)
+  if List.mem InType kelim then
+    let elim = make_elim (new_sort_in_family InType) in
+    let cte = declare (mindstr^(Indrec.elimination_suffix InType)) elim None in
+    let c = mkConst (snd cte) and t = constant_type (Global.env()) (snd cte) in
+    List.iter (fun (sort,suff) -> 
+      let (t',c') = 
+	Indrec.instanciate_type_indrec_scheme (new_sort_in_family sort)
+	  npars c t in
+      let _ = declare (mindstr^suff) c' (Some t') in ())
+      non_type_eliminations
+   else (* Impredicative or logical inductive definition *)
+     List.iter
+    (fun (sort,suff) -> 
+       if List.mem sort kelim then
+	 let elim = make_elim (new_sort_in_family sort) in
+	 let _ = declare (mindstr^suff) elim None in ())
+       non_type_eliminations
+
+let declare_eliminations sp =
+  let mib = Global.lookup_mind sp in
+  if mib.mind_finite then
+    for i = 0 to Array.length mib.mind_packets - 1 do
+      declare_one_elimination (sp,i)
+    done
+
+(* 3b| Mutual Inductive definitions *)
+
+let minductive_message = function 
+  | []  -> error "no inductive definition"
+  | [x] -> (pr_id x ++ str " is defined")
+  | l   -> hov 0  (prlist_with_sep pr_coma pr_id l ++
+		     spc () ++ str "are defined")
+
+let recursive_message v =
+  match Array.length v with
+    | 0 -> error "no recursive definition"
+    | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
+    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
+		    spc () ++ str "are recursively defined")
+
+let corecursive_message v =
+  match Array.length v with
+    | 0 -> error "no corecursive definition"
+    | 1 -> (Printer.pr_global v.(0) ++ str " is corecursively defined")
+    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
+                    spc () ++ str "are corecursively defined")
+
+let interp_mutual lparams lnamearconstrs finite = 
+  let allnames = 
+    List.fold_left (fun acc (id,_,_,l) -> id::(List.map fst l)@acc)
+      [] lnamearconstrs in
+  if not (list_distinct allnames) then
+    error "Two inductive objects have the same name";
+  let nparams = local_binders_length lparams
+  and sigma = Evd.empty 
+  and env0 = Global.env() in
+  let env_params, params =
+    List.fold_left
+      (fun (env, params) d -> match d with
+	| LocalRawAssum ([_,na],(CHole _ as t)) ->
+	    let t = interp_binder sigma env na t in
+	    let d = (na,None,t) in
+	    (push_rel d env, d::params)
+	| LocalRawAssum (nal,t) ->
+	    let t = interp_type sigma env t in
+	    let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
+	    let ctx = List.rev ctx in
+	    (push_rel_context ctx env, ctx@params)
+	| LocalRawDef ((_,na),c) ->
+	    let c = judgment_of_rawconstr sigma env c in
+	    let d = (na, Some c.uj_val, c.uj_type) in
+	    (push_rel d env,d::params))
+      (env0,[]) lparams
+  in
+  (* Builds the params of the inductive entry *)
+  let params' =
+    List.map (fun (na,b,t) ->
+		let id = match na with
+		  | Name id -> id
+		  | Anonymous -> anomaly "Unnamed inductive variable" in 
+		match b with
+		  | None -> (id, LocalAssum t)
+		  | Some b -> (id, LocalDef b)) params
+  in
+  let paramassums = 
+    List.fold_right (fun d l -> match d with
+	(id,LocalAssum _) -> id::l | (_,LocalDef _) -> l) params' [] in
+  let indnames =
+    List.map (fun (id,_,_,_)-> id) lnamearconstrs @ paramassums in
+  let nparamassums = List.length paramassums in
+  let (ind_env,ind_impls,arityl) =
+    List.fold_left
+      (fun (env, ind_impls, arl) (recname, _, arityc, _) ->
+         let arity = interp_type sigma env_params arityc in
+	 let fullarity = it_mkProd_or_LetIn arity params in
+	 let env' = Termops.push_rel_assum (Name recname,fullarity) env in
+	 let argsc = compute_arguments_scope fullarity in
+	 let ind_impls' = 
+	   if Impargs.is_implicit_args() then
+	     let impl = Impargs.compute_implicits false env_params fullarity in
+	     let paramimpl,_ = list_chop nparamassums impl in
+	     let l = List.fold_right
+	       (fun imp l -> if Impargs.is_status_implicit imp then
+		 Impargs.name_of_implicit imp::l else l) paramimpl [] in
+	     (recname,(l,impl,argsc))::ind_impls
+	   else
+	     (recname,([],[],argsc))::ind_impls in
+	 (env', ind_impls', (arity::arl)))
+      (env0, [], []) lnamearconstrs
+  in
+  (* Names of parameters as arguments of the inductive type (defs removed) *)
+  let lparargs = 
+    List.flatten
+      (List.map (function (id,LocalAssum _) -> [id] | _ -> []) params') in
+  let notations = 
+    List.fold_right (fun (_,ntnopt,_,_) l -> option_cons ntnopt l) 
+      lnamearconstrs [] in
+  let fs = States.freeze() in
+  (* Declare the notations for the inductive types pushed in local context*)
+  try
+  List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
+    Metasyntax.add_notation_interpretation df ind_impls c None) notations;
+  let ind_env_params = push_rel_context params ind_env in
+
+  let mispecvec = 
+    List.map2
+      (fun ar (name,_,_,lname_constr) ->
+	 let constrnames, bodies = List.split lname_constr in
+         (* Compute the conclusions of constructor types *)
+	 (* for inductive given in ML syntax *)
+	 let nar = 
+	   List.length (fst (Reductionops.splay_arity env_params Evd.empty ar))
+	 in
+	 let bodies =
+	   List.map2 (adjust_conclusion (nar,name,lparargs))
+	     constrnames bodies
+	 in
+
+         (* Interpret the constructor types *)
+         let constrs =
+	   List.map 
+	     (interp_type_with_implicits sigma ind_env_params
+	       (paramassums,ind_impls))
+	     bodies
+	 in
+
+         (* Build the inductive entry *)
+	 { mind_entry_params = params';
+	   mind_entry_typename = name;
+	   mind_entry_arity = ar;
+	   mind_entry_consnames = constrnames;
+	   mind_entry_lc = constrs })
+      (List.rev arityl) lnamearconstrs
+  in
+  States.unfreeze fs;
+  notations, { mind_entry_finite = finite; mind_entry_inds = mispecvec }
+  with e -> States.unfreeze fs; raise e
+
+let declare_mutual_with_eliminations isrecord mie =
+  let lrecnames =
+    List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
+  let (_,kn) = declare_mind isrecord mie in
+  if_verbose ppnl (minductive_message lrecnames);
+  declare_eliminations kn;
+  kn
+
+(* Very syntactical equality *)
+let eq_la d1 d2 = match d1,d2 with
+  | LocalRawAssum (nal,ast), LocalRawAssum (nal',ast') ->
+      List.for_all2 (fun (_,na) (_,na') -> na = na') nal nal'
+      & (try let _ = Constrextern.check_same_type ast ast' in true with _ -> false)
+  | LocalRawDef ((_,id),ast), LocalRawDef ((_,id'),ast') ->
+      id=id' & (try let _ = Constrextern.check_same_type ast ast' in true with _ -> false)
+  | _ -> false
+
+let extract_coe lc =
+  List.fold_right
+    (fun (addcoe,((_,(id:identifier)),t)) (l1,l2) ->
+      ((if addcoe then id::l1 else l1), (id,t)::l2)) lc ([],[])
+
+let extract_coe_la_lc = function
+  | []            -> anomaly "Vernacentries: empty list of inductive types"
+  | ((_,id),ntn,la,ar,lc)::rest ->
+      let rec check = function 
+	| []             -> [],[]
+  	| ((_,id),ntn,la',ar,lc)::rest ->
+            if (List.length la = List.length la') && 
+               (List.for_all2 eq_la la la')
+	    then
+	      let mcoes, mspec = check rest in
+	      let coes, lc' = extract_coe lc in
+	      (coes::mcoes,(id,ntn,ar,lc')::mspec)
+	    else 
+	      error ("Parameters should be syntactically the same "^
+		     "for each inductive type")
+      in
+      let mcoes, mspec = check rest in
+      let coes, lc' = extract_coe lc in
+      (coes,la,(id,ntn,ar,lc'):: mspec)
+
+let build_mutual lind finite =
+  let ((coes:identifier list),lparams,lnamearconstructs) = extract_coe_la_lc lind in
+  let notations,mie = interp_mutual lparams lnamearconstructs finite in
+  let kn = declare_mutual_with_eliminations false mie in
+  (* Declare the notations now bound to the inductive types *)
+  List.iter (fun (df,c,scope) ->
+    Metasyntax.add_notation_interpretation df [] c scope) notations;
+  List.iter
+    (fun id -> 
+      Class.try_add_new_coercion (locate (make_short_qualid id)) Global) coes
+
+(* try to find non recursive definitions *)
+
+let list_chop_hd i l = match list_chop i l with
+  | (l1,x::l2) -> (l1,x,l2)
+  | _ -> assert false
+
+let collect_non_rec env = 
+  let rec searchrec lnonrec lnamerec ldefrec larrec nrec = 
+    try
+      let i = 
+        list_try_find_i
+          (fun i f ->
+             if List.for_all (fun def -> not (occur_var env f def)) ldefrec
+             then i else failwith "try_find_i")
+          0 lnamerec 
+      in
+      let (lf1,f,lf2) = list_chop_hd i lnamerec in
+      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
+      let (lar1,ar,lar2) = list_chop_hd i larrec in
+      let newlnv = 
+	try 
+	  match list_chop i nrec with 
+            | (lnv1,_::lnv2) -> (lnv1@lnv2)
+	    | _ -> [] (* nrec=[] for cofixpoints *)
+        with Failure "list_chop" -> []
+      in 
+      searchrec ((f,def,ar)::lnonrec) 
+	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
+    with Failure "try_find_i" -> 
+      (List.rev lnonrec,
+       (Array.of_list lnamerec, Array.of_list ldefrec,
+        Array.of_list larrec, Array.of_list nrec))
+  in 
+  searchrec [] 
+
+let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list)  =
+  let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef 
+  and sigma = Evd.empty
+  and env0 = Global.env()
+  and nv = Array.of_list (List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef) in
+  (* Build the recursive context and notations for the recursive types *)
+  let (rec_sign,rec_impls,arityl) = 
+    List.fold_left 
+      (fun (env,impls,arl) ((recname,_,bl,arityc,_),_) -> 
+        let arityc = prod_rawconstr arityc bl in
+        let arity = interp_type sigma env0 arityc in
+	let impl = 
+	  if Impargs.is_implicit_args()
+	  then Impargs.compute_implicits false env0 arity
+	  else [] in
+	let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
+        (Environ.push_named (recname,None,arity) env, impls', arity::arl))
+      (env0,[],[]) lnameargsardef in
+  let arityl = List.rev arityl in
+  let notations = 
+    List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) 
+      lnameargsardef [] in
+
+  let recdef =
+
+    (* Declare local notations *)
+    let fs = States.freeze() in
+    let def = 
+      try
+	List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
+	  Metasyntax.add_notation_interpretation df [] c None) notations;
+	List.map2
+	  (fun ((_,_,bl,_,def),_) arity ->
+            let def = abstract_rawconstr def bl in
+            interp_casted_constr_with_implicits 
+	      sigma rec_sign rec_impls def arity)
+          lnameargsardef arityl
+      with e ->
+	States.unfreeze fs; raise e in
+    States.unfreeze fs; def 
+  in
+
+  let (lnonrec,(namerec,defrec,arrec,nvrec)) = 
+    collect_non_rec env0 lrecnames recdef arityl (Array.to_list nv) in
+  let recvec = 
+    Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in
+  let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
+  let rec declare i fi =
+    let ce = 
+      { const_entry_body = mkFix ((nvrec,i),recdecls);
+        const_entry_type = Some arrec.(i);
+        const_entry_opaque = false } in
+    let (_,kn) = declare_constant fi (DefinitionEntry ce, IsDefinition) in
+    (ConstRef kn)
+  in 
+  (* declare the recursive definitions *)
+  let lrefrec = Array.mapi declare namerec in
+  if_verbose ppnl (recursive_message lrefrec);
+  (* The others are declared as normal definitions *)
+  let var_subst id = (id, global_reference id) in
+  let _ = 
+    List.fold_left
+      (fun subst (f,def,t) ->
+	 let ce = { const_entry_body = replace_vars subst def;
+		    const_entry_type = Some t;
+                    const_entry_opaque = false } in
+	 let _ = declare_constant f (DefinitionEntry ce, IsDefinition) in
+      	 warning ((string_of_id f)^" is non-recursively defined");
+      	 (var_subst f) :: subst)
+      (List.map var_subst (Array.to_list namerec))
+      lnonrec 
+  in
+  List.iter (fun (df,c,scope) ->
+    Metasyntax.add_notation_interpretation df [] c scope) notations
+
+let build_corecursive lnameardef = 
+  let lrecnames = List.map (fun (f,_,_,_) -> f) lnameardef
+  and sigma = Evd.empty
+  and env0 = Global.env() in
+  let fs = States.freeze() in
+  let (rec_sign,arityl) = 
+    try 
+      List.fold_left 
+        (fun (env,arl) (recname,bl,arityc,_) -> 
+           let arityc = prod_rawconstr arityc bl in
+           let arj = type_judgment_of_rawconstr Evd.empty env0 arityc in
+	   let arity = arj.utj_val in
+           let _ = declare_variable recname
+	     (Lib.cwd(),SectionLocalAssum arj.utj_val,IsAssumption Definitional) in
+           (Environ.push_named (recname,None,arity) env, (arity::arl)))
+        (env0,[]) lnameardef
+    with e -> 
+      States.unfreeze fs; raise e in 
+  let arityl = List.rev arityl in
+  let recdef =
+    try 
+      List.map (fun (_,bl,arityc,def) ->
+        let arityc = prod_rawconstr arityc bl in
+        let def = abstract_rawconstr def bl in
+	let arity = interp_constr sigma rec_sign arityc in
+                  interp_casted_constr sigma rec_sign def arity)
+        lnameardef
+    with e -> 
+      States.unfreeze fs; raise e 
+  in
+  States.unfreeze fs;
+  let (lnonrec,(namerec,defrec,arrec,_)) = 
+    collect_non_rec env0 lrecnames recdef arityl [] in
+  let recvec = 
+    Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in
+  let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
+  let rec declare i fi =
+    let ce = 
+      { const_entry_body = mkCoFix (i, recdecls);
+        const_entry_type = Some (arrec.(i));
+        const_entry_opaque = false } 
+    in
+    let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in
+    (ConstRef kn)
+  in 
+  let lrefrec = Array.mapi declare namerec in
+  if_verbose ppnl (corecursive_message lrefrec);
+  let var_subst id = (id, global_reference id) in
+  let _ = 
+    List.fold_left
+      (fun subst (f,def,t) ->
+	 let ce = { const_entry_body = replace_vars subst def;
+		    const_entry_type = Some t;
+                    const_entry_opaque = false } in
+	 let _ = declare_constant f (DefinitionEntry ce,IsDefinition) in
+      	 warning ((string_of_id f)^" is non-recursively defined");
+      	 (var_subst f) :: subst)
+      (List.map var_subst (Array.to_list namerec))
+      lnonrec 
+  in ()
+
+let build_scheme lnamedepindsort = 
+  let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
+  and sigma = Evd.empty
+  and env0 = Global.env() in
+  let lrecspec =
+    List.map
+      (fun (_,dep,indid,sort) ->
+        let ind = Nametab.global_inductive indid in
+        let (mib,mip) = Global.lookup_inductive ind in
+         (ind,mib,mip,dep,interp_elimination_sort sort)) 
+      lnamedepindsort
+  in
+  let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in 
+  let rec declare decl fi lrecref =
+    let decltype = Retyping.get_type_of env0 Evd.empty decl in
+    let decltype = Evarutil.refresh_universes decltype in
+    let ce = { const_entry_body = decl;
+               const_entry_type = Some decltype;
+               const_entry_opaque = false } in
+    let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in
+    ConstRef kn :: lrecref
+  in 
+  let lrecref = List.fold_right2 declare listdecl lrecnames [] in
+  if_verbose ppnl (recursive_message (Array.of_list lrecref))
+
+let rec generalize_rawconstr c = function
+  | [] -> c
+  | LocalRawDef (id,b)::bl -> mkLetInC(id,b,generalize_rawconstr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkProdC([x],t,b)) idl
+        (generalize_rawconstr c bl)
+
+let start_proof id kind c hook =
+  let sign = Global.named_context () in
+  let sign = clear_proofs sign in
+  Pfedit.start_proof id kind sign c hook
+
+let start_proof_com sopt kind (bl,t) hook =
+  let id = match sopt with
+    | Some id ->
+        (* We check existence here: it's a bit late at Qed time *)
+        if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
+          errorlabstrm "start_proof" (pr_id id ++ str " already exists");
+        id
+    | None ->
+	next_global_ident_away false (id_of_string "Unnamed_thm")
+ 	  (Pfedit.get_all_proof_names ())
+  in
+  let env = Global.env () in
+  let c = interp_type Evd.empty env (generalize_rawconstr t bl) in
+  let _ = Typeops.infer_type env c in
+  start_proof id kind c hook
+
+let save id const kind hook =
+  let {const_entry_body = pft;
+       const_entry_type = tpo;
+       const_entry_opaque = opacity } = const in
+  let l,r = match kind with
+    | IsLocal when Lib.sections_are_opened () ->
+	let c = SectionLocalDef (pft, tpo, opacity) in
+	let _ = declare_variable id (Lib.cwd(), c, IsDefinition) in
+	(Local, VarRef id)
+    | IsLocal ->
+        let k = IsDefinition in
+        let _,kn = declare_constant id (DefinitionEntry const, k) in
+	(Global, ConstRef kn)
+    | IsGlobal k ->
+        let k = theorem_kind_of_goal_kind k in
+        let _,kn = declare_constant id (DefinitionEntry const, k) in
+	(Global, ConstRef kn) in
+  hook l r;
+  Pfedit.delete_current_proof ();
+  definition_message id
+
+let save_named opacity =
+  let id,(const,persistence,hook) = Pfedit.cook_proof () in
+  let const = { const with const_entry_opaque = opacity } in
+  save id const persistence hook
+
+let check_anonymity id save_ident =
+  if atompart_of_id id <> "Unnamed_thm" then
+    error "This command can only be used for unnamed theorem"
+(*
+    message("Overriding name "^(string_of_id id)^" and using "^save_ident)
+*)
+
+let save_anonymous opacity save_ident =
+  let id,(const,persistence,hook) = Pfedit.cook_proof () in
+  let const = { const with const_entry_opaque = opacity } in
+  check_anonymity id save_ident;
+  save save_ident const persistence hook
+
+let save_anonymous_with_strength kind opacity save_ident =
+  let id,(const,_,hook) = Pfedit.cook_proof () in
+  let const = { const with const_entry_opaque = opacity } in
+  check_anonymity id save_ident;
+  (* we consider that non opaque behaves as local for discharge *)
+  save save_ident const (IsGlobal (Proof kind)) hook
+
+let admit () =
+  let (id,k,typ,hook) = Pfedit.current_proof_statement () in
+(* Contraire aux besoins d'interactivité...
+  if k <> IsGlobal (Proof Conjecture) then
+    error "Only statements declared as conjecture can be admitted";
+*)
+  let (_,kn) = declare_constant id (ParameterEntry typ, IsConjecture) in
+  hook Global (ConstRef kn);
+  Pfedit.delete_current_proof ();
+  assumption_message id
+
+let get_current_context () =
+  try Pfedit.get_current_goal_context ()
+  with e when Logic.catchable_exception e -> 
+    (Evd.empty, Global.env())
diff --git a/toplevel/command.mli b/toplevel/command.mli
new file mode 100644
index 00000000..7997288c
--- /dev/null
+++ b/toplevel/command.mli
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: command.mli,v 1.38.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Nametab
+open Declare
+open Library
+open Libnames
+open Nametab
+open Tacexpr
+open Vernacexpr
+open Rawterm
+open Topconstr
+open Decl_kinds
+(*i*)
+
+(*s Declaration functions. The following functions take ASTs,
+   transform them into [constr] and then call the corresponding
+   functions of [Declare]; they return an absolute reference to the
+   defined object *)
+
+val declare_definition : identifier -> definition_kind ->
+  local_binder list -> Tacred.red_expr option -> constr_expr ->
+    constr_expr option -> declaration_hook -> unit
+
+val syntax_definition : identifier -> constr_expr -> bool -> bool -> unit
+
+val declare_assumption : identifier located list ->
+  coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> unit
+
+val build_mutual : inductive_expr list -> bool -> unit
+
+val declare_mutual_with_eliminations :
+  bool -> Entries.mutual_inductive_entry -> mutual_inductive
+
+val build_recursive : (fixpoint_expr * decl_notation) list -> unit
+
+val build_corecursive : cofixpoint_expr list -> unit
+
+val build_scheme : (identifier located * bool * reference * rawsort) list -> unit
+
+val generalize_rawconstr : constr_expr -> local_binder list -> constr_expr
+
+val start_proof : identifier -> goal_kind -> constr ->
+  declaration_hook -> unit
+
+val start_proof_com : identifier option -> goal_kind -> 
+  (local_binder list * constr_expr) -> declaration_hook -> unit
+
+(*s [save_named b] saves the current completed proof under the name it
+was started; boolean [b] tells if the theorem is declared opaque; it
+fails if the proof is not completed *)
+
+val save_named : bool -> unit
+
+(* [save_anonymous b name] behaves as [save_named] but declares the theorem
+under the name [name] and respects the strength of the declaration *)
+
+val save_anonymous : bool -> identifier -> unit
+
+(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but
+   declares the theorem under the name [name] and gives it the
+   strength [strength] *)
+
+val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit
+
+(* [admit ()] aborts the current goal and save it as an assmumption *)
+
+val admit : unit -> unit
+
+(* [get_current_context ()] returns the evar context and env of the
+   current open proof if any, otherwise returns the empty evar context
+   and the current global env *)
+
+val get_current_context : unit -> Evd.evar_map * Environ.env
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
new file mode 100644
index 00000000..4a4f7828
--- /dev/null
+++ b/toplevel/coqinit.ml
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: coqinit.ml,v 1.30.2.1 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Pp
+open System
+open Toplevel
+
+let (/) = Filename.concat
+
+let set_debug () = Options.debug := true
+
+(* Loading of the ressource file.
+   rcfile is either $HOME/.coqrc.VERSION, or $HOME/.coqrc if the first one
+  does not exist. *)
+
+let rcfile = ref (home/".coqrc")
+let rcfile_specified = ref false
+let set_rcfile s = rcfile := s; rcfile_specified := true
+let set_rcuser s = rcfile := ("~"^s)/".coqrc"
+
+let load_rc = ref true
+let no_load_rc () = load_rc := false
+
+let load_rcfile() =
+  if !load_rc then
+    try
+      if !rcfile_specified then
+        if file_readable_p !rcfile then 
+          Vernac.load_vernac false !rcfile
+        else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
+      else if file_readable_p (!rcfile^"."^Coq_config.version) then
+        Vernac.load_vernac false (!rcfile^"."^Coq_config.version)
+      else if file_readable_p !rcfile then
+        Vernac.load_vernac false !rcfile
+      else ()
+	(*
+	Options.if_verbose
+	  mSGNL (str ("No .coqrc or .coqrc."^Coq_config.version^
+			 " found. Skipping rcfile loading."))
+	*)
+    with e ->
+      (msgnl (str"Load of rcfile failed.");
+       raise e)
+  else 
+    Options.if_verbose msgnl (str"Skipping rcfile loading.")
+
+let add_ml_include s =
+  Mltop.add_ml_dir s
+
+(* Puts dir in the path of ML and in the LoadPath *)
+let coq_add_path s = Mltop.add_path s (Names.make_dirpath [Nameops.coq_root])
+let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nameops.coq_root])
+
+(* By the option -include -I or -R of the command line *)
+let includes = ref []
+let push_include (s, alias) = includes := (s,alias,false) :: !includes
+let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
+
+(* Because find puts "./" and the loadpath is not nicely pretty-printed *)
+let hm2 s = 
+  let n = String.length s in
+  if n > 1 && s.[0] = '.' && s.[1] = '/' then String.sub s 2 (n-2) else s
+
+let getenv_else s dft = try Sys.getenv s with Not_found -> dft
+
+(* Initializes the LoadPath according to COQLIB and Coq_config *)
+let init_load_path () =
+  (* developper specific directories to open *)
+  let dev = if Coq_config.local then [ "dev" ] else [] in
+  let coqlib =
+    if Coq_config.local || !Options.boot then Coq_config.coqtop
+      (* variable COQLIB overrides the default library *)
+    else getenv_else "COQLIB" Coq_config.coqlib in
+  (* first user-contrib *)
+  let user_contrib = coqlib/"user-contrib" in
+  if Sys.file_exists user_contrib then 
+    Mltop.add_path user_contrib Nameops.default_root_prefix;
+  (* then standard library *)
+  let vdirs = 
+    if !Options.v7 then [ "theories7"; "contrib7" ]
+    else [ "theories"; "contrib" ] in
+  let dirs = 
+    (if !Options.v7 then "states7" else "states") :: dev @ vdirs in
+  List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
+  let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in
+  add_ml_include camlp4;
+  (* then current directory *)
+  Mltop.add_path "." Nameops.default_root_prefix;
+  (* additional loadpath, given with -I -include -R options *)
+  List.iter 
+    (fun (s,alias,reci) ->
+       if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias)
+    (List.rev !includes)
+let init_library_roots () =
+  includes := []
+
+(* Initialises the Ocaml toplevel before launching it, so that it can
+   find the "include" file in the *source* directory *)
+(* We only assume that the variable COQTOP is set *)
+let init_ocaml_path () =
+  let coqtop = getenv_else "COQTOP" Coq_config.coqtop in
+  let add_subdir dl = 
+    Mltop.add_ml_dir (List.fold_left (/) coqtop dl) 
+  in
+  List.iter add_subdir
+    [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; 
+      [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
+      [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ]
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
new file mode 100644
index 00000000..e029d8ac
--- /dev/null
+++ b/toplevel/coqinit.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: coqinit.mli,v 1.7.16.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(* Initialization. *)
+
+val set_debug : unit -> unit
+
+val set_rcfile : string -> unit
+val set_rcuser : string -> unit
+
+val no_load_rc : unit -> unit
+val load_rcfile : unit -> unit
+
+val push_include : string * Names.dir_path -> unit
+val push_rec_include : string * Names.dir_path -> unit
+
+val init_load_path : unit -> unit
+val init_library_roots : unit -> unit
+
+val init_ocaml_path : unit -> unit
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
new file mode 100644
index 00000000..aa765b16
--- /dev/null
+++ b/toplevel/coqtop.ml
@@ -0,0 +1,325 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: coqtop.ml,v 1.72.2.3 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Pp
+open Util
+open System
+open Options
+open Names
+open Libnames
+open Nameops
+open States
+open Toplevel
+open Coqinit
+
+let get_version_date () =
+  try
+    let ch = open_in (Coq_config.coqtop^"/make.result") in
+    let l = input_line ch in
+    let i = String.index l ' ' in
+    let j = String.index_from l (i+1) ' ' in
+    "checked out on "^(String.sub l (i+1) (j-i-1))
+  with _ -> Coq_config.date
+
+let print_header () =
+  Printf.printf "Welcome to Coq %s%s (%s)\n"
+    Coq_config.version 
+    (if !Options.v7 then " (V7 syntax)" else "")
+    (get_version_date ());
+  flush stdout
+
+let memory_stat = ref false
+
+let print_memory_stat () = 
+  if !memory_stat then
+    Format.printf "total heap size = %d kbytes\n" (heap_size_kb ())
+
+let _ = at_exit print_memory_stat
+
+let engagement = ref None
+let set_engagement c = engagement := Some c
+let engage () =
+  match !engagement with Some c -> Global.set_engagement c | None -> ()
+  
+let set_batch_mode () = batch_mode := true
+
+let toplevel_name = ref (make_dirpath [id_of_string "Top"])
+let set_toplevel_name dir = toplevel_name := dir
+
+let remove_top_ml () = Mltop.remove ()
+
+let inputstate = ref None
+let set_inputstate s = inputstate:= Some s
+let inputstate () =
+  match !inputstate with
+    | Some "" -> ()
+    | Some s -> intern_state s
+    | None -> intern_state "initial.coq"
+
+let outputstate = ref ""
+let set_outputstate s = outputstate:=s
+let outputstate () = if !outputstate <> "" then extern_state !outputstate
+
+let check_coq_overwriting p = 
+  if string_of_id (List.hd (repr_dirpath p)) = "Coq" then
+    error "The \"Coq\" logical root directory is reserved for the Coq library"
+
+let set_include d p = push_include (d,p)
+let set_rec_include d p = check_coq_overwriting p; push_rec_include (d,p)
+let set_default_include d = set_include d Nameops.default_root_prefix
+let set_default_rec_include d = set_rec_include d Nameops.default_root_prefix
+ 
+let load_vernacular_list = ref ([] : (string * bool) list)
+let add_load_vernacular verb s =
+  load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list
+let load_vernacular () =
+  List.iter
+    (fun (s,b) -> 
+      if Options.do_translate () then
+	with_option translate_file (Vernac.load_vernac b) s
+      else
+	Vernac.load_vernac b s)
+    (List.rev !load_vernacular_list)
+
+let load_vernacular_obj = ref ([] : string list)
+let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj
+let load_vernac_obj () = 
+  List.iter Library.read_library_from_file (List.rev !load_vernacular_obj)
+
+let require_list = ref ([] : string list)
+let add_require s = require_list := s :: !require_list
+let require () =
+  List.iter (fun s -> Library.require_library_from_file None None s false)
+    (List.rev !require_list)
+
+let compile_list = ref ([] : (bool * string) list)
+let add_compile verbose s =
+  set_batch_mode ();
+  Options.make_silent true; 
+  compile_list := (verbose,s) :: !compile_list
+let compile_files () =
+  let init_state = States.freeze() in
+  List.iter
+    (fun (v,f) ->
+      States.unfreeze init_state;
+      if Options.do_translate () then
+	with_option translate_file (Vernac.compile v) f
+      else
+	Vernac.compile v f)
+    (List.rev !compile_list)
+
+let re_exec_version = ref ""
+let set_byte () = re_exec_version := "byte"
+let set_opt () = re_exec_version := "opt"
+
+(* Re-exec Coq in bytecode or native code if necessary. [s] is either
+   ["byte"] or ["opt"]. Notice that this is possible since the nature of
+   the toplevel has already been set in [Mltop] by the main file created
+   by coqmktop (see scripts/coqmktop.ml). *)
+
+let re_exec is_ide =
+  let s = !re_exec_version in
+  let is_native = (Mltop.get()) = Mltop.Native in
+  let prog = Sys.argv.(0) in
+  let coq = Filename.basename prog in
+  if (is_native && s = "byte") || ((not is_native) && s = "opt")
+  then begin
+    let s = if s = "" then if is_native then "opt" else "byte" else s in
+    let newprog = 
+      let dir = Filename.dirname prog in
+      let coqtop = if is_ide then "coqide." else "coqtop." in
+      let com = coqtop ^ s ^ Coq_config.exec_extension in
+      if dir <> "." then Filename.concat dir com else com 
+    in
+    Sys.argv.(0) <- newprog;
+    Unix.handle_unix_error (Unix.execvp newprog) Sys.argv
+  end
+
+(*s Parsing of the command line.
+    We no longer use [Arg.parse], in order to use share [Usage.print_usage]
+    between coqtop and coqc. *)
+
+let usage () =
+  if !batch_mode then
+    Usage.print_usage_coqc ()
+  else
+    Usage.print_usage_coqtop () ;
+  flush stderr ;
+  exit 1
+
+let warning s = msg_warning (str s)
+
+let ide_args = ref []
+let parse_args is_ide =
+  let rec parse = function
+    | [] -> ()
+
+    | "-impredicative-set" :: rem -> 
+        set_engagement Environ.ImpredicativeSet; parse rem
+
+    | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem
+    | ("-I"|"-include") :: []       -> usage ()
+
+    | "-R" :: d :: p :: rem ->set_rec_include d (dirpath_of_string p);parse rem
+    | "-R" :: ([] | [_]) -> usage ()
+
+    | "-top" :: d :: rem -> set_toplevel_name (dirpath_of_string d); parse rem
+    | "-top" :: [] -> usage ()
+
+    | "-q" :: rem -> no_load_rc (); parse rem
+
+    | "-opt" :: rem -> set_opt(); parse rem
+    | "-byte" :: rem -> set_byte(); parse rem
+    | "-full" :: rem -> warning "option -full deprecated\n"; parse rem
+
+    | "-batch" :: rem -> set_batch_mode (); parse rem
+    | "-boot" :: rem -> boot := true; no_load_rc (); parse rem	     
+    | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem
+    | "-outputstate" :: s :: rem -> set_outputstate s; parse rem
+    | "-outputstate" :: []       -> usage ()
+
+    | "-nois" :: rem -> set_inputstate ""; parse rem
+	     
+    | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem
+    | ("-inputstate"|"-is") :: []       -> usage ()
+
+    | "-load-ml-object" :: f :: rem -> Mltop.dir_ml_load f; parse rem
+    | "-load-ml-object" :: []       -> usage ()
+
+    | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem
+    | "-load-ml-source" :: []       -> usage ()
+
+    | ("-load-vernac-source"|"-l") :: f :: rem -> 
+	add_load_vernacular false f; parse rem
+    | ("-load-vernac-source"|"-l") :: []       -> usage ()
+
+    | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> 
+	add_load_vernacular true f; parse rem
+    | ("-load-vernac-source-verbose"|"-lv") :: []       -> usage ()
+
+    | "-load-vernac-object" :: f :: rem -> add_vernac_obj f; parse rem
+    | "-load-vernac-object" :: []       -> usage ()
+
+    | "-dump-glob" :: f :: rem -> dump_into_file f; parse rem
+    | "-dump-glob" :: []       -> usage ()
+
+    | "-require" :: f :: rem -> add_require f; parse rem
+    | "-require" :: []       -> usage ()
+
+    | "-compile" :: f :: rem -> add_compile false f; parse rem
+    | "-compile" :: []       -> usage ()
+
+    | "-compile-verbose" :: f :: rem -> add_compile true f; parse rem
+    | "-compile-verbose" :: []       -> usage ()
+
+    | "-dont-load-proofs" :: rem -> Options.dont_load_proofs := true; parse rem
+
+    | "-translate" :: rem -> make_translate true; parse rem
+
+    | "-unsafe" :: f :: rem -> add_unsafe f; parse rem
+    | "-unsafe" :: []       -> usage ()
+
+    | "-debug" :: rem -> set_debug (); parse rem
+
+    | "-emacs" :: rem -> Options.print_emacs := true; parse rem
+	  
+    | "-where" :: _ -> print_endline Coq_config.coqlib; exit 0
+
+    | ("-quiet"|"-silent") :: rem -> Options.make_silent true; parse rem
+
+    | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
+
+    | ("-v"|"--version") :: _ -> Usage.version ()
+
+    | "-init-file" :: f :: rem -> set_rcfile f; parse rem
+    | "-init-file" :: []       -> usage ()
+
+    | "-user" :: u :: rem -> set_rcuser u; parse rem
+    | "-user" :: []       -> usage ()
+
+    | "-notactics" :: rem -> remove_top_ml (); parse rem
+
+    | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem
+
+    | ("-m" | "--memory") :: rem -> memory_stat := true; parse rem
+
+    | "-xml" :: rem -> Options.xml_export := true; parse rem
+
+    (* Scanned in Options! *)
+    | "-v7" :: rem -> (* Options.v7 := true; *) parse rem
+    | "-v8" :: rem -> (* Options.v7 := false; *) parse rem
+
+    (* Translator options *)
+    | "-strict-implicit" :: rem -> 
+	Options.translate_strict_impargs := false; parse rem
+
+    | s :: rem -> 
+	if is_ide then begin
+	  ide_args := s :: !ide_args;
+	  parse rem
+	end else begin
+	  prerr_endline ("Don't know what to do with " ^ s); usage ()
+	end
+  in
+  try
+    parse (List.tl (Array.to_list Sys.argv))
+  with 
+    | UserError(_,s) as e -> begin
+	try
+	  Stream.empty s; exit 1
+	with Stream.Failure ->
+	  msgnl (Cerrors.explain_exn e); exit 1
+      end
+    | e -> begin msgnl (Cerrors.explain_exn e); exit 1 end
+
+
+(* To prevent from doing the initialization twice *)
+let initialized = ref false
+
+let init is_ide =
+  if not !initialized then begin
+    initialized := true;
+    Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
+    Lib.init();
+    try
+      parse_args is_ide;
+      re_exec is_ide;
+      if_verbose print_header ();
+      init_load_path ();
+      inputstate ();
+      engage ();
+      if not !batch_mode then Declaremods.start_library !toplevel_name;
+      init_library_roots ();
+      load_vernac_obj ();
+      require ();
+      load_rcfile();
+      load_vernacular ();
+      compile_files ();
+      outputstate ();
+    with e ->
+      flush_all();
+      if not !batch_mode then message "Error during initialization :";
+      msgnl (Toplevel.print_toplevel_error e);
+      exit 1
+  end;
+  if !batch_mode then (flush_all(); Profile.print_profile (); exit 0);
+  Lib.declare_initial_state ()
+
+let init_ide () = init true; List.rev !ide_args
+
+let start () =
+  init false;
+  Toplevel.loop();
+  (* Initialise and launch the Ocaml toplevel *)
+  Coqinit.init_ocaml_path();
+  Mltop.ocaml_toploop();
+  exit 1
+
+(* [Coqtop.start] will be called by the code produced by coqmktop *)
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
new file mode 100644
index 00000000..ef8b4b37
--- /dev/null
+++ b/toplevel/coqtop.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: coqtop.mli,v 1.5.4.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(* The Coq main module. The following function [start] will parse the
+   command line, print the banner, initialize the load path, load the input 
+   state, load the files given on the command line, load the ressource file,
+   produce the output state if any, and finally will launch [Toplevel.loop]. *)
+
+val start : unit -> unit
+
+(* [init_ide] is to be used by the Coq IDE. 
+   It does everything [start] does, except launching the toplevel loop. 
+   It returns the list of Coq files given on the command line. *)
+
+val init_ide : unit -> string list
+
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
new file mode 100644
index 00000000..688885b1
--- /dev/null
+++ b/toplevel/discharge.ml
@@ -0,0 +1,328 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: discharge.ml,v 1.81.2.1 2004/07/16 19:31:48 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Sign
+open Term
+open Declarations
+open Entries
+open Inductive
+open Instantiate
+open Reduction
+open Cooking
+open Typeops
+open Libnames
+open Libobject
+open Lib
+open Nametab
+open Declare
+open Impargs
+open Classops
+open Class
+open Recordops
+open Library
+open Indtypes
+open Nametab
+open Decl_kinds
+
+let recalc_sp dir sp =
+  let (_,spid) = repr_path sp in Libnames.make_path dir spid
+
+let recalc_kn dir kn = 
+  let (mp,_,l) = Names.repr_kn kn in
+    Names.make_kn mp dir l
+
+let rec find_var id = function
+  | [] -> false
+  | (x,b,_)::l -> if x = id then b=None else find_var id l
+
+let build_abstract_list sec_sp hyps ids_to_discard =
+  let l1,l2 =
+   List.split
+    (List.fold_left
+      (fun vars id ->
+        if find_var id hyps then (mkVar id, Libnames.make_path sec_sp id)::vars
+        else vars)
+      [] ids_to_discard) in
+  Array.of_list l1, l2
+
+(* Discharge of inductives is done here (while discharge of constants 
+   is done by the kernel for efficiency). *)
+
+let abstract_inductive sec_sp ids_to_abs hyps inds =
+  let abstract_one_assum id t inds =
+    let ntyp = List.length inds in 
+    let new_refs =
+      list_tabulate (fun k -> applist(mkRel (k+2),[mkRel 1])) ntyp in
+    let inds' =
+      List.map
+      	(function (np,tname,arity,cnames,lc) -> 
+	   let arity' = mkNamedProd id t arity in
+	   let lc' =
+	     List.map (fun b -> mkNamedProd id t (substl new_refs b)) lc
+	   in
+           (np,tname,arity',cnames,lc'))
+      	inds
+    in 
+    inds' in
+  let abstract_one_def id c inds =
+    List.map
+      (function (np,tname,arity,cnames,lc) -> 
+	 let arity' = replace_vars [id, c] arity in
+	 let lc' = List.map (replace_vars [id, c]) lc in
+         (np,tname,arity',cnames,lc'))
+      inds in
+  let abstract_once ((hyps,inds,vars) as sofar) id =
+    match hyps with
+      | (hyp,None,t as d)::rest when id = hyp ->
+	  let inds' = abstract_one_assum hyp t inds in 
+	  (rest, inds', (mkVar id, Libnames.make_path sec_sp id)::vars)
+      | (hyp,Some b,t as d)::rest when id = hyp ->
+	  let inds' = abstract_one_def hyp b inds in 
+	  (rest, inds', vars)
+      | _ -> sofar in
+  let (_,inds',vars) =
+    List.fold_left abstract_once (hyps,inds,[]) ids_to_abs in
+  let inds'' =
+    List.map 
+      (fun (nparams,a,arity,c,lc) ->
+	 let nparams' = nparams + (List.length vars) in
+	 let params, short_arity = decompose_prod_n_assum nparams' arity in
+	 let shortlc =
+	   List.map (fun c -> snd (decompose_prod_n_assum nparams' c))lc in
+	 let params' =
+	   List.map 
+	     (function
+		| (Name id,None,p) -> id, Entries.LocalAssum p
+		| (Name id,Some p,_) -> id, Entries.LocalDef p
+		| (Anonymous,_,_) -> anomaly"Unnamed inductive local variable")
+	     params in
+	 { mind_entry_params = params';
+	   mind_entry_typename = a;
+	   mind_entry_arity = short_arity;
+	   mind_entry_consnames = c;
+	   mind_entry_lc = shortlc })
+      inds' in
+  let l1,l2 = List.split vars in
+   (inds'', Array.of_list l1, l2)
+
+let process_inductive sec_sp osecsp nsecsp oldenv (ids_to_discard,modlist) mib =
+  assert (Array.length mib.mind_packets > 0);
+  let finite = mib.mind_finite in
+  let inds = 
+    array_map_to_list
+      (fun mip ->
+	 let nparams = mip.mind_nparams in
+	 let arity = expmod_type modlist mip.mind_user_arity in
+	 let lc = Array.map (expmod_type modlist) mip.mind_user_lc in
+	 (nparams,
+	  mip.mind_typename,
+	  arity,
+	  Array.to_list mip.mind_consnames,
+	  Array.to_list lc))
+      mib.mind_packets
+  in
+  let hyps = mib.mind_hyps in
+  let hyps' =
+    Sign.fold_named_context
+      (fun (x,b,t) sgn ->
+        Sign.add_named_decl
+          (x, option_app (expmod_constr modlist) b,expmod_constr modlist t)
+          sgn)
+      mib.mind_hyps ~init:empty_named_context in
+  let (inds',abs_vars,discharged_hyps ) =
+   abstract_inductive sec_sp ids_to_discard hyps' inds in
+  let lmodif_one_mind i = 
+    let nbc = Array.length mib.mind_packets.(i).mind_consnames in 
+    (((osecsp,i), DO_ABSTRACT ((nsecsp,i),abs_vars)),
+     list_tabulate
+       (function j -> 
+	  let j' = j + 1 in
+	  (((osecsp,i),j'), DO_ABSTRACT (((nsecsp,i),j'),abs_vars)))
+      nbc)
+  in
+  let indmodifs,cstrmodifs =
+    List.split (list_tabulate lmodif_one_mind mib.mind_ntypes) in 
+  ({ mind_entry_finite = finite;
+     mind_entry_inds = inds' },
+   indmodifs,
+   List.flatten cstrmodifs,
+   discharged_hyps)
+
+(* Discharge messages. *)
+
+let constant_message id =
+  Options.if_verbose ppnl (pr_id id ++ str " is discharged.")
+
+let inductive_message inds =
+  Options.if_verbose 
+    ppnl
+      (hov 0 
+	 (match inds with
+	    | [] -> assert false
+	    | [ind] ->
+		(pr_id ind.mind_entry_typename ++ str " is discharged.")
+	    | l ->
+		(prlist_with_sep pr_coma 
+		     (fun ind -> pr_id ind.mind_entry_typename) l ++
+		   spc () ++ str "are discharged.")))
+
+(* Discharge operations for the various objects of the environment. *)
+
+type opacity = bool
+
+type discharge_operation = 
+  | Variable of identifier * section_variable_entry * local_kind * 
+      implicits_flags * Dischargedhypsmap.discharged_hyps
+  | Constant of identifier * recipe * global_kind * constant * 
+      implicits_flags * Dischargedhypsmap.discharged_hyps
+  | Inductive of mutual_inductive_entry * implicits_flags *
+      Dischargedhypsmap.discharged_hyps
+  | Class of cl_typ * cl_info_typ
+  | Struc of inductive * (unit -> struc_typ)
+  | Objdef of constant
+  | Coercion of coercion_entry
+  | Require of library_reference
+  | Constraints of Univ.constraints
+
+(* Main function to traverse the library segment and compute the various
+   discharge operations. *)
+
+let process_object oldenv olddir full_olddir newdir  
+(* {dir -> newdir} {sec_sp -> full_olddir, olddir} *)
+  (ops,ids_to_discard,(constl,indl,cstrl as work_alist)) ((sp,kn),lobj) =
+  let tag = object_tag lobj in 
+  match tag with
+    | "VARIABLE" ->
+	let ((id,c,t),cst) = get_variable_with_constraints (basename sp) in
+	(* VARIABLE means local (entry Variable/Hypothesis/Local and are *)
+	(* always discharged *)
+	(Constraints cst :: ops, id :: ids_to_discard, work_alist)
+
+    | "CONSTANT" ->
+	(* CONSTANT means never discharge (though visibility may vary) *)
+ 	let kind = constant_kind sp in
+	let kn = Nametab.locate_constant (qualid_of_sp sp) in
+	let lab = label kn in
+	let cb = Environ.lookup_constant kn oldenv in
+	let imp = is_implicit_constant kn in
+	let newkn = recalc_kn newdir kn in
+	let abs_vars,discharged_hyps0 =
+         build_abstract_list full_olddir cb.const_hyps ids_to_discard in
+        (* let's add the new discharged hypothesis to those already discharged*)
+        let discharged_hyps =
+         discharged_hyps0 @ Dischargedhypsmap.get_discharged_hyps sp in
+        let mods = [ (kn, DO_ABSTRACT(newkn,abs_vars)) ]
+	in
+	let r = { d_from = cb;
+	          d_modlist = work_alist;
+	          d_abstract = ids_to_discard } in
+	let op = Constant (id_of_label lab,r,kind,newkn,imp,discharged_hyps) in
+        (op :: ops, ids_to_discard, (mods@constl, indl, cstrl))
+  
+    | "INDUCTIVE" ->
+	let kn = Nametab.locate_mind (qualid_of_sp sp) in
+	let mib = Environ.lookup_mind kn oldenv in
+	let newkn = recalc_kn newdir kn in
+	let imp = is_implicit_inductive_definition kn in
+(*	let imp = is_implicit_args (* CHANGE *) in*)
+	let (mie,indmods,cstrmods,discharged_hyps0) = 
+	  process_inductive full_olddir kn newkn oldenv (ids_to_discard,work_alist) mib in
+        (* let's add the new discharged hypothesis to those already discharged*)
+        let discharged_hyps =
+         discharged_hyps0 @ Dischargedhypsmap.get_discharged_hyps sp in
+	((Inductive(mie,imp,discharged_hyps)) :: ops, ids_to_discard,
+	 (constl,indmods@indl,cstrmods@cstrl))
+
+    | "CLASS" -> 
+	let ((cl,clinfo) as x) = outClass lobj in
+	if clinfo.cl_strength = Local then 
+	  (ops,ids_to_discard,work_alist)
+	else
+	  let (y1,y2) = process_class olddir ids_to_discard x in
+          ((Class (y1,y2))::ops, ids_to_discard, work_alist)
+	  
+    | "COERCION" -> 
+	let (_,coeinfo,_,_ as x) = outCoercion lobj in
+	if coercion_strength coeinfo = Local then
+	  (ops,ids_to_discard,work_alist)
+        else
+	  let y = process_coercion olddir ids_to_discard x in
+          ((Coercion y)::ops, ids_to_discard, work_alist)
+                    
+    | "STRUCTURE" ->
+	let ((kn,i),info) = outStruc lobj in
+	let newkn = recalc_kn newdir kn in
+	let strobj () =
+	  let mib = Environ.lookup_mind newkn (Global.env ()) in
+	  { s_CONST = info.s_CONST;
+	    s_PARAM = mib.mind_packets.(0).mind_nparams;
+	    s_PROJ = List.map (option_app (fun kn -> recalc_kn newdir kn)) info.s_PROJ } in
+	((Struc ((newkn,i),strobj))::ops, ids_to_discard, work_alist)
+
+    | "OBJDEF1" -> 
+	let kn = outObjDef1 lobj in
+	let new_kn = recalc_kn newdir kn in
+        ((Objdef new_kn)::ops, ids_to_discard, work_alist)
+
+    | "REQUIRE" -> 
+	let c = out_require lobj in
+	((Require c)::ops, ids_to_discard, work_alist)
+
+    | _ -> (ops,ids_to_discard,work_alist)
+
+let process_item oldenv olddir full_olddir newdir acc = function
+  | (sp,Leaf lobj) -> 
+      process_object oldenv olddir full_olddir newdir  acc (sp,lobj)
+  | (_,_) -> acc
+
+let process_operation = function
+  | Variable (id,expmod_a,stre,imp,discharged_hyps) ->
+      (* Warning:parentheses needed to get a side-effect from with_implicits *)
+      with_implicits imp (redeclare_variable id discharged_hyps)
+        (Lib.cwd(),expmod_a,stre)
+  | Constant (id,r,stre,kn,imp,discharged_hyps) ->
+      with_implicits imp (redeclare_constant id discharged_hyps) (r,stre);
+      constant_message id
+  | Inductive (mie,imp,discharged_hyps) ->
+      let _ = with_implicits imp (redeclare_inductive discharged_hyps) mie in
+      inductive_message mie.mind_entry_inds
+  | Class (y1,y2) ->
+      Lib.add_anonymous_leaf (inClass (y1,y2))
+  | Struc (newsp,strobj) ->
+      Lib.add_anonymous_leaf (inStruc (newsp,strobj ()))
+  | Objdef newsp ->
+      begin try Recordobj.objdef_declare (ConstRef newsp) with _ -> () end
+  | Coercion y -> add_new_coercion y
+  | Require y -> reload_library y
+  | Constraints y -> Global.add_constraints y
+
+let catch_not_found f x =
+  try f x
+  with Not_found ->
+    error ("Something is missing; perhaps a reference to a"^
+    " module required inside the section")
+
+let close_section _ s = 
+  let oldenv = Global.env() in
+  let prefix,decls,fs = close_section false s in
+  let full_olddir, (_,olddir) = prefix in
+  let newdir = fst (split_dirpath olddir) in
+  let (ops,ids,_) = 
+    List.fold_left 
+      (process_item oldenv olddir full_olddir newdir) ([],[],([],[],[])) decls 
+  in
+  let ids = last_section_hyps olddir in
+  Summary.section_unfreeze_summaries fs;
+  catch_not_found (List.iter process_operation) (List.rev ops);
+  Nametab.push_dir (Until 1) full_olddir (DirClosedSection full_olddir)
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
new file mode 100644
index 00000000..c80b93ce
--- /dev/null
+++ b/toplevel/discharge.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: discharge.mli,v 1.6.16.1 2004/07/16 19:31:48 herbelin Exp $ i*)
+
+open Names
+
+(* This module implements the discharge mechanism. It provides a function to
+   close the last opened section. That function calls [Lib.close_section] and
+   then re-introduce all the discharged versions of the objects that were
+   defined in the section. *)
+
+val close_section : bool -> identifier -> unit
diff --git a/toplevel/doc.tex b/toplevel/doc.tex
new file mode 100644
index 00000000..f2550fda
--- /dev/null
+++ b/toplevel/doc.tex
@@ -0,0 +1,10 @@
+
+\newpage
+\section*{The Coq toplevel}
+
+\ocwsection \label{toplevel}
+This chapter describes the highest modules of the \Coq\ system.
+They are organized as follows:
+
+\bigskip
+\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center}
diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml
new file mode 100644
index 00000000..b5185cd3
--- /dev/null
+++ b/toplevel/fhimsg.ml
@@ -0,0 +1,362 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: fhimsg.ml,v 1.19.2.1 2004/07/16 19:31:48 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Type_errors
+open Reduction
+open G_minicoq
+
+module type Printer = sig
+  val pr_term : path_kind -> env -> constr -> std_ppcmds
+end
+
+module Make = functor (P : Printer) -> struct
+
+  let print_decl k env (s,typ) =
+    let ptyp = P.pr_term k env typ in 
+    (spc () ++ pr_id s ++ str" : " ++ ptyp)
+  
+  let print_binding k env = function
+    | Anonymous,ty -> 
+	(spc () ++ str"_" ++ str" : " ++ P.pr_term k env ty)
+    | Name id,ty -> 
+	(spc () ++ pr_id id ++ str" : " ++ P.pr_term k env ty)
+
+(****
+  let sign_it_with f sign e =
+    snd (fold_named_context
+	   (fun (id,v,t) (sign,e) -> (add_named_decl (id,v,t) sign, f id t sign e))
+           sign (empty_named_context,e))
+
+  let dbenv_it_with f env e =
+    snd (dbenv_it 
+	   (fun na t (env,e) -> (add_rel_decl (na,t) env, f na t env e))
+           env (gLOB(get_globals env),e))
+****)
+      
+  let pr_env k env =
+    let sign_env =
+      fold_named_context
+	(fun env (id,_,t) pps ->
+           let pidt =  print_decl k env (id,t) in (pps ++ fnl () ++ pidt))
+	env (mt ()) 
+    in
+    let db_env =
+      fold_rel_context
+	(fun env (na,_,t) pps ->
+           let pnat = print_binding k env (na,t) in (pps ++ fnl () ++ pnat))
+	env (mt ())
+    in 
+    (sign_env ++ db_env)
+    
+  let pr_ne_ctx header k env =
+    if rel_context env = [] && named_context env = [] then
+      (mt ())
+    else
+      (header ++ pr_env k env)
+
+
+let explain_unbound_rel k ctx n =
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  (str"Unbound reference: " ++ pe ++ fnl () ++
+     str"The reference " ++ int n ++ str" is free")
+
+let explain_not_type k ctx c =
+  let pe = pr_ne_ctx (str"In environment") k ctx in
+  let pc = P.pr_term k ctx c in
+  (pe ++ cut () ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++
+     str"should be typed by Set, Prop or Type.");;
+
+let explain_bad_assumption k ctx c =
+  let pc = P.pr_term k ctx c in
+  (str "Cannot declare a variable or hypothesis over the term" ++
+     brk(1,1) ++ pc ++ spc () ++ str "because this term is not a type.");;
+
+let explain_reference_variables id =
+  (str "the constant" ++ spc () ++ pr_id id ++ spc () ++ 
+     str "refers to variables which are not in the context")
+
+let msg_bad_elimination ctx k = function
+  | Some(ki,kp,explanation) ->
+      let pki = P.pr_term k ctx ki in
+      let pkp = P.pr_term k ctx kp in
+      (hov 0 
+         (fnl () ++ str "Elimination of an inductive object of sort : " ++
+            pki ++ brk(1,0) ++
+            str "is not allowed on a predicate in sort : " ++ pkp ++fnl () ++
+            str "because" ++ spc () ++ str explanation))
+  | None -> 
+      (mt ())
+
+let explain_elim_arity k ctx ind aritylst c pj okinds = 
+  let pi = P.pr_term k ctx ind in
+  let ppar = prlist_with_sep pr_coma (P.pr_term k ctx) aritylst in
+  let pc = P.pr_term k ctx c in
+  let pp = P.pr_term k ctx pj.uj_val in
+  let ppt = P.pr_term k ctx pj.uj_type in
+  (str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++
+     str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++
+     str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++
+     str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++
+     str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++
+     msg_bad_elimination ctx k okinds)
+
+let explain_case_not_inductive k ctx cj =
+  let pc = P.pr_term k ctx cj.uj_val in
+  let pct = P.pr_term k ctx cj.uj_type in
+  (str "In Cases expression" ++ brk(1,1) ++ pc ++ spc () ++ 
+     str "has type" ++ brk(1,1) ++ pct ++ spc () ++ 
+     str "which is not an inductive definition")
+  
+let explain_number_branches k ctx cj expn =
+  let pc = P.pr_term k ctx cj.uj_val in
+  let pct = P.pr_term k ctx cj.uj_val in
+  (str "Cases on term" ++ brk(1,1) ++ pc ++ spc () ++
+     str "of type" ++ brk(1,1) ++ pct ++ spc () ++
+     str "expects " ++  int expn ++ str " branches")
+
+let explain_ill_formed_branch k ctx c i actty expty =
+  let pc = P.pr_term k ctx c in
+  let pa = P.pr_term k ctx actty in
+  let pe = P.pr_term k ctx expty in
+  (str "In Cases expression on term" ++ brk(1,1) ++ pc ++
+     spc () ++ str "the branch " ++ int (i+1) ++
+     str " has type" ++ brk(1,1) ++ pa ++ spc () ++ 
+     str "which should be:" ++ brk(1,1) ++ pe)
+
+let explain_generalization k ctx (name,var) c =
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  let pv = P.pr_term k ctx var in
+  let pc = P.pr_term k (push_rel (name,None,var) ctx) c in
+  (str"Illegal generalization: " ++ pe ++ fnl () ++
+     str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
+     str"over" ++ brk(1,1) ++ pc ++ spc () ++
+     str"which should be typed by Set, Prop or Type.")
+
+let explain_actual_type k ctx c ct pt =
+  let pe = pr_ne_ctx (str"In environment") k ctx in
+  let pc = P.pr_term k ctx c in
+  let pct = P.pr_term k ctx ct in
+  let pt = P.pr_term k ctx pt in
+  (pe ++ fnl () ++
+     str"The term" ++ brk(1,1) ++ pc ++ spc () ++
+     str"does not have type" ++ brk(1,1) ++ pt ++ fnl () ++
+     str"Actually, it has type" ++ brk(1,1) ++ pct)
+
+let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl =
+  let ctx = make_all_name_different ctx in
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  let pr = pr_term k ctx rator.uj_val in
+  let prt = pr_term k ctx rator.uj_type in
+  let term_string = if List.length randl > 1 then "terms" else "term" in
+  let many = match n mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
+  let appl = prlist_with_sep pr_fnl 
+	       (fun c ->
+		  let pc = pr_term k ctx c.uj_val in
+		  let pct = pr_term k ctx c.uj_type in
+		  hov 2 (pc ++ spc () ++ str": " ++ pct)) randl
+  in
+  (str"Illegal application (Type Error): " ++ pe ++ fnl () ++
+     str"The term" ++ brk(1,1) ++ pr ++ spc () ++
+     str"of type" ++ brk(1,1) ++ prt ++ spc () ++
+     str("cannot be applied to the "^term_string) ++ fnl () ++ 
+     str" " ++ v 0 appl ++ fnl () ++
+     str"The " ++int n ++ str (many^" term of type ") ++
+     pr_term k ctx actualtyp ++
+     str" should be of type " ++ pr_term k ctx exptyp)
+
+let explain_cant_apply_not_functional k ctx rator randl =
+  let ctx = make_all_name_different ctx in
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  let pr = pr_term k ctx rator.uj_val in
+  let prt = pr_term k ctx rator.uj_type in
+  let term_string = if List.length randl > 1 then "terms" else "term" in
+  let appl = prlist_with_sep pr_fnl 
+	       (fun c ->
+		  let pc = pr_term k ctx c.uj_val in
+		  let pct = pr_term k ctx c.uj_type in
+		  hov 2 (pc ++ spc () ++ str": " ++ pct)) randl
+  in
+  (str"Illegal application (Non-functional construction): " ++ pe ++ fnl () ++
+     str"The term" ++ brk(1,1) ++ pr ++ spc () ++
+     str"of type" ++ brk(1,1) ++ prt ++ spc () ++
+     str("cannot be applied to the "^term_string) ++ fnl () ++ 
+     str" " ++ v 0 appl ++ fnl ())
+
+(* (co)fixpoints *)
+let explain_ill_formed_rec_body k ctx err names i vdefs =
+  let str = match err with
+
+  (* Fixpoint guard errors *)
+  | NotEnoughAbstractionInFixBody ->
+      (str "Not enough abstractions in the definition")
+  | RecursionNotOnInductiveType ->
+      (str "Recursive definition on a non inductive type")
+  | RecursionOnIllegalTerm ->
+      (str "Recursive call applied to an illegal term")
+  | NotEnoughArgumentsForFixCall ->
+      (str "Not enough arguments for the recursive call")
+
+  (* CoFixpoint guard errors *)
+  (* TODO : récupérer le contexte des termes pour pouvoir les afficher *)
+  | CodomainNotInductiveType c ->
+      (str "The codomain is" ++ spc () ++ P.pr_term k ctx c ++ spc () ++
+	 str "which should be a coinductive type")
+  | NestedRecursiveOccurrences ->
+      (str "Nested recursive occurrences")
+  | UnguardedRecursiveCall c ->
+      (str "Unguarded recursive call")
+  | RecCallInTypeOfAbstraction c ->
+      (str "Not allowed recursive call in the domain of an abstraction")
+  | RecCallInNonRecArgOfConstructor c ->
+      (str "Not allowed recursive call in a non-recursive argument of constructor")
+  | RecCallInTypeOfDef c ->
+      (str "Not allowed recursive call in the type of a recursive definition")
+  | RecCallInCaseFun c ->
+      (str "Not allowed recursive call in a branch of cases")
+  | RecCallInCaseArg c -> 
+      (str "Not allowed recursive call in the argument of cases")
+  | RecCallInCasePred c ->
+      (str "Not allowed recursive call in the type of cases in")
+  | NotGuardedForm c ->
+      str "Sub-expression " ++ prterm_env ctx c ++ spc() ++
+      str "not in guarded form (should be a constructor, Cases or CoFix)"
+in
+  let pvd = P.pr_term k ctx vdefs.(i) in
+  let s =
+    match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in
+  (str ++ fnl () ++ str"The " ++
+     if Array.length vdefs = 1 then (mt ()) else (int (i+1) ++ str "-th ") ++
+     str"recursive definition" ++ spc () ++ str s ++
+	 spc () ++ str":=" ++ spc () ++ pvd ++ spc () ++
+     str "is not well-formed")
+    
+let explain_ill_typed_rec_body k ctx i lna vdefj vargs =
+  let pvd = P.pr_term k ctx (vdefj.(i)).uj_val in
+  let pvdt = P.pr_term k ctx (vdefj.(i)).uj_type in
+  let pv = P.pr_term k ctx vargs.(i) in
+  (str"The " ++
+     if Array.length vdefj = 1 then (mt ()) else (int (i+1) ++ str "-th") ++
+     str"recursive definition" ++ spc () ++ pvd ++ spc () ++
+     str "has type" ++ spc () ++ pvdt ++spc () ++ str "it should be" ++ spc () ++ pv)
+
+let explain_not_inductive k ctx c =
+  let pc = P.pr_term k ctx c in
+  (str"The term" ++ brk(1,1) ++ pc ++ spc () ++
+     str "is not an inductive definition")
+
+let explain_ml_case k ctx mes c ct br brt =
+  let pc = P.pr_term k ctx c in
+  let pct = P.pr_term k ctx ct in
+  let expln =
+    match mes with
+      | "Inductive" -> (pct ++ str "is not an inductive definition")
+      | "Predicate" -> (str "ML case not allowed on a predicate")
+      | "Absurd" -> (str "Ill-formed case expression on an empty type")
+      | "Decomp" ->
+          let plf = P.pr_term k ctx br in
+          let pft = P.pr_term k ctx brt in
+          (str "The branch " ++ plf ++ ws 1 ++ cut () ++ str "has type " ++ pft ++
+             ws 1 ++ cut () ++
+             str "does not correspond to the inductive definition")
+      | "Dependent" ->
+          (str "ML case not allowed for a dependent case elimination")
+      | _ -> (mt ())
+  in
+  hov 0 (str "In ML case expression on " ++ pc ++ ws 1 ++ cut () ++
+           str "of type" ++  ws 1 ++ pct ++ ws 1 ++ cut () ++ 
+           str "which is an inductive predicate." ++ fnl () ++ expln)
+(*
+let explain_cant_find_case_type loc k ctx c =
+  let pe = P.pr_term k ctx c in
+  Ast.user_err_loc
+    (loc,"pretype",
+     hov 3 (str "Cannot infer type of whole Case expression on" ++ 
+	     ws 1 ++ pe))
+*)
+let explain_type_error k ctx = function
+  | UnboundRel n -> 
+      explain_unbound_rel k ctx n
+  | NotAType c -> 
+      explain_not_type k ctx c.uj_val
+  | BadAssumption c -> 
+      explain_bad_assumption k ctx c
+  | ReferenceVariables id -> 
+      explain_reference_variables id
+  | ElimArity (ind, aritylst, c, pj, okinds) ->
+      explain_elim_arity k ctx (mkMutInd ind) aritylst c pj okinds 
+  | CaseNotInductive cj -> 
+      explain_case_not_inductive k ctx cj
+  | NumberBranches (cj, n) -> 
+      explain_number_branches k ctx cj n
+  | IllFormedBranch (c, i, actty, expty) -> 
+      explain_ill_formed_branch k ctx c i actty expty 
+  | Generalization (nvar, c) ->
+      explain_generalization k ctx nvar c.uj_val
+  | ActualType (c, ct, pt) -> 
+      explain_actual_type k ctx c ct pt
+  | CantApplyBadType (s, rator, randl) ->
+      explain_cant_apply_bad_type k ctx s rator randl
+  | CantApplyNonFunctional (rator, randl) ->
+      explain_cant_apply_not_functional k ctx rator randl
+  | IllFormedRecBody (i, lna, vdefj, vargs) ->
+      explain_ill_formed_rec_body k ctx i lna vdefj vargs
+  | IllTypedRecBody (i, lna, vdefj, vargs) ->
+      explain_ill_typed_rec_body k ctx i lna vdefj vargs
+(*
+  | NotInductive c ->
+      explain_not_inductive k ctx c
+  | MLCase (mes,c,ct,br,brt) ->
+      explain_ml_case k ctx mes c ct br brt
+*)
+  | _ -> 
+      (str "Unknown type error (TODO)")
+
+let explain_refiner_bad_type k ctx arg ty conclty =
+  errorlabstrm "Logic.conv_leq_goal"
+    (str"refiner was given an argument" ++ brk(1,1) ++ 
+       P.pr_term k ctx arg ++ spc () ++
+       str"of type" ++ brk(1,1) ++ P.pr_term k ctx ty ++ spc () ++
+       str"instead of" ++ brk(1,1) ++ P.pr_term k ctx conclty)
+
+let explain_refiner_occur_meta k ctx t =
+  errorlabstrm "Logic.mk_refgoals"
+    (str"cannot refine with term" ++ brk(1,1) ++ P.pr_term k ctx t ++
+       spc () ++ str"because there are metavariables, and it is" ++
+       spc () ++ str"neither an application nor a Case")
+
+let explain_refiner_cannot_applt k ctx t harg =
+  errorlabstrm "Logic.mkARGGOALS"
+    (str"in refiner, a term of type " ++ brk(1,1) ++
+       P.pr_term k ctx t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++
+       P.pr_term k ctx harg)
+
+let explain_occur_check k ctx ev rhs =
+  let id = "?" ^ string_of_int ev in
+  let pt = P.pr_term k ctx rhs in
+  errorlabstrm "Trad.occur_check"
+    (str"Occur check failed: tried to define " ++ str id ++
+      str" with term" ++ brk(1,1) ++ pt)
+
+let explain_not_clean k ctx sp t =
+  let c = mkRel (Intset.choose (free_rels t)) in
+  let id = string_of_id (Names.basename sp) in
+  let var = P.pr_term k ctx c in
+  errorlabstrm "Trad.not_clean"
+    (str"Tried to define " ++ str id ++
+       str" with a term using variable " ++ var ++ spc () ++
+       str"which is not in its scope.")
+
+end
diff --git a/toplevel/fhimsg.mli b/toplevel/fhimsg.mli
new file mode 100644
index 00000000..10175e2a
--- /dev/null
+++ b/toplevel/fhimsg.mli
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: fhimsg.mli,v 1.8.16.1 2004/07/16 19:31:48 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Sign
+open Environ
+open Type_errors
+(*i*)
+
+(* This module provides functions to explain the various typing errors.
+   It is parameterized by a function to pretty-print a term in a given
+   context. *)
+
+module type Printer = sig
+  val pr_term : path_kind -> env -> constr -> std_ppcmds
+end
+
+(*s The result is a module which provides a function [explain_type_error]
+  to explain a type error for a given kind in a given env, which are 
+  usually the three arguments carried by the exception [TypeError] 
+  (see \refsec{typeerrors}). *)
+
+module Make (P : Printer) : sig
+
+val explain_type_error : path_kind -> env -> type_error -> std_ppcmds
+
+val pr_ne_ctx : std_ppcmds -> path_kind -> env -> std_ppcmds
+
+val explain_unbound_rel : path_kind -> env -> int -> std_ppcmds
+
+val explain_not_type : path_kind -> env -> constr -> std_ppcmds
+
+val explain_bad_assumption : path_kind -> env -> constr -> std_ppcmds
+ 
+val explain_reference_variables : identifier -> std_ppcmds
+
+val explain_elim_arity : 
+  path_kind -> env -> constr -> constr list -> constr 
+    -> unsafe_judgment -> (constr * constr * string) option -> std_ppcmds
+
+val explain_case_not_inductive : 
+  path_kind -> env -> unsafe_judgment -> std_ppcmds
+
+val explain_number_branches : 
+  path_kind -> env -> unsafe_judgment -> int -> std_ppcmds
+
+val explain_ill_formed_branch :
+  path_kind -> env -> constr -> int -> constr -> constr -> std_ppcmds
+
+val explain_generalization :
+  path_kind -> env -> name * types -> constr -> std_ppcmds
+
+val explain_actual_type :
+  path_kind -> env -> constr -> constr -> constr -> std_ppcmds
+
+val explain_ill_formed_rec_body :
+  path_kind -> env -> guard_error -> 
+    name array -> int -> constr array -> std_ppcmds
+
+val explain_ill_typed_rec_body  :
+  path_kind -> env -> int -> name list -> unsafe_judgment array 
+    -> types array -> std_ppcmds
+
+end
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
new file mode 100644
index 00000000..de341bd9
--- /dev/null
+++ b/toplevel/himsg.ml
@@ -0,0 +1,665 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: himsg.ml,v 1.86.2.2 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Names
+open Nameops
+open Term
+open Termops
+open Inductive
+open Indtypes
+open Sign
+open Environ
+open Pretype_errors
+open Type_errors
+open Reduction
+open Cases
+open Logic
+open Printer
+open Ast
+open Rawterm
+
+let quote s = if !Options.v7 then s else h 0 (str "\"" ++ s ++ str "\"")
+
+let prterm c = quote (prterm c)
+let prterm_env e c = quote (prterm_env e c)
+let prjudge_env e c = let v,t = prjudge_env e c in (quote v,quote t)
+
+let nth i =
+  let many = match i mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
+  int i ++ str many
+
+let pr_db ctx i =
+  try
+    match lookup_rel i ctx with
+        Name id, _, _ -> pr_id id
+      | Anonymous, _, _ -> str"<>"
+  with Not_found -> str"UNBOUND_REL_"++int i
+
+let explain_unbound_rel ctx n =
+  let pe = pr_ne_context_of (str "In environment") ctx in
+  str"Unbound reference: " ++ pe ++
+  str"The reference " ++ int n ++ str " is free"
+
+let explain_unbound_var ctx v =
+  let var = pr_id v in
+  str"No such section variable or assumption : " ++ var
+
+let explain_not_type ctx j =
+  let pe = pr_ne_context_of (str"In environment") ctx in
+  let pc,pt = prjudge_env ctx j in
+  pe ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++
+  str"has type" ++ spc () ++ pt ++ spc () ++ 
+  str"which should be Set, Prop or Type."
+
+let explain_bad_assumption ctx j =
+  let pe = pr_ne_context_of (str"In environment") ctx in
+  let pc,pt = prjudge_env ctx j in
+  pe ++ str "cannot declare a variable or hypothesis over the term" ++
+  brk(1,1) ++ pc ++ spc () ++ str"of type" ++ spc () ++ pt ++ spc () ++
+  str "because this term is not a type."
+
+let explain_reference_variables c =
+  let pc = prterm c in
+  str "the constant" ++ spc () ++ pc ++ spc () ++ 
+  str "refers to variables which are not in the context"
+
+let explain_elim_arity ctx ind aritylst c pj okinds = 
+  let ctx = make_all_name_different ctx in
+  let pi = pr_inductive ctx ind in
+  let ppar = prlist_with_sep pr_coma (prterm_env ctx) aritylst in
+  let pc = prterm_env ctx c in
+  let pp = prterm_env ctx pj.uj_val in
+  let ppt = prterm_env ctx pj.uj_type in
+  let msg = match okinds with
+  | Some(kp,ki,explanation) ->
+      let pki = prterm_env ctx ki in
+      let pkp = prterm_env ctx kp in
+      let explanation =	match explanation with
+	| NonInformativeToInformative ->
+	  "non-informative objects may not construct informative ones."
+	| StrongEliminationOnNonSmallType ->
+          "strong elimination on non-small inductive types leads to paradoxes."
+	| WrongArity ->
+	  "wrong arity" in
+	(hov 0 
+           (fnl () ++ str "Elimination of an inductive object of sort : " ++
+            pki ++ brk(1,0) ++
+            str "is not allowed on a predicate in sort : " ++ pkp  ++fnl () ++
+            str "because" ++ spc () ++ str explanation))
+  | None -> 
+      mt ()
+  in
+  str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++
+  str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++
+  str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++
+  str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++
+  str "It should be one of :" ++ brk(1,1)  ++ hov 0 ppar ++ fnl () ++
+  msg
+
+let explain_case_not_inductive ctx cj =
+  let ctx = make_all_name_different ctx in
+  let pc = prterm_env ctx cj.uj_val in
+  let pct = prterm_env ctx cj.uj_type in
+    match kind_of_term cj.uj_type with
+      | Evar _ -> 
+	  str "Cannot infer a type for this expression"
+      | _ ->
+	  str "The term" ++ brk(1,1) ++ pc ++ spc () ++ 
+	  str "has type" ++ brk(1,1) ++ pct ++ spc () ++ 
+	  str "which is not a (co-)inductive type"
+
+let explain_number_branches ctx cj expn =
+  let ctx = make_all_name_different ctx in
+  let pc = prterm_env ctx cj.uj_val in
+  let pct = prterm_env ctx cj.uj_type in
+  str "Matching on term" ++ brk(1,1) ++ pc ++ spc ()  ++
+  str "of type" ++ brk(1,1) ++ pct ++ spc () ++
+  str "expects " ++  int expn ++ str " branches"
+
+let explain_ill_formed_branch ctx c i actty expty =
+  let ctx = make_all_name_different ctx in
+  let pc = prterm_env ctx c in
+  let pa = prterm_env ctx actty in
+  let pe = prterm_env ctx expty in
+  str "In pattern-matching on term" ++ brk(1,1) ++ pc ++
+  spc () ++ str "the branch "  ++ int (i+1) ++
+  str " has type" ++ brk(1,1) ++ pa  ++ spc () ++ 
+  str "which should be" ++ brk(1,1) ++ pe
+
+let explain_generalization ctx (name,var) j =
+  let pe = pr_ne_context_of (str "In environment") ctx in
+  let pv = prtype_env ctx var in
+  let (pc,pt) = prjudge_env (push_rel_assum (name,var) ctx) j in
+  str"Illegal generalization: " ++ pe ++
+  str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
+  str"over" ++ brk(1,1) ++ pc ++ str"," ++ spc () ++ 
+  str"it has type" ++ spc () ++ pt ++ 
+  spc () ++ str"which should be Set, Prop or Type."
+
+let explain_actual_type ctx j pt =
+  let pe = pr_ne_context_of (str "In environment") ctx in
+  let (pc,pct) = prjudge_env ctx j in
+  let pt = prterm_env ctx pt in
+  pe ++
+  str "The term" ++ brk(1,1) ++ pc ++ spc ()  ++
+  str "has type"  ++ brk(1,1) ++ pct ++ brk(1,1) ++ 
+  str "while it is expected to have type" ++ brk(1,1) ++ pt
+
+let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl =
+  let randl = Array.to_list randl in
+(*  let pe = pr_ne_context_of (str"in environment") ctx in*)
+  let pr,prt = prjudge_env ctx rator in
+  let term_string1,term_string2 =
+    if List.length randl > 1 then
+      str "terms", (str"The "++nth n++str" term")
+    else
+      str "term", str "This term" in
+  let appl = prlist_with_sep pr_fnl 
+	       (fun c ->
+		  let pc,pct = prjudge_env ctx c in
+		  hov 2 (pc ++ spc () ++ str": "  ++ pct)) randl
+  in
+  str"Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++
+  str"The term" ++ brk(1,1) ++ pr ++ spc () ++
+  str"of type" ++ brk(1,1) ++ prt ++ spc ()  ++
+  str"cannot be applied to the " ++ term_string1 ++ fnl () ++ 
+  str" " ++ v 0 appl ++ fnl () ++ term_string2 ++ str" has type" ++
+  brk(1,1) ++ prterm_env ctx actualtyp ++ spc () ++
+  str"which should be coercible to" ++ brk(1,1) ++ prterm_env ctx exptyp
+
+let explain_cant_apply_not_functional ctx rator randl =
+  let randl = Array.to_list randl in
+(*  let pe = pr_ne_context_of (str"in environment") ctx in*)
+  let pr = prterm_env ctx rator.uj_val in
+  let prt = prterm_env ctx rator.uj_type in
+  let term_string = if List.length randl > 1 then "terms" else "term" in
+  let appl = prlist_with_sep pr_fnl 
+	       (fun c ->
+		  let pc = prterm_env ctx c.uj_val in
+		  let pct = prterm_env ctx c.uj_type in
+		  hov 2 (pc ++ spc () ++ str": "  ++ pct)) randl
+  in
+  str"Illegal application (Non-functional construction): " ++ 
+  (* pe ++ *) fnl () ++
+  str"The expression" ++ brk(1,1) ++ pr ++ spc () ++
+  str"of type" ++ brk(1,1) ++ prt ++ spc ()  ++
+  str("cannot be applied to the "^term_string) ++ fnl () ++ 
+  str" " ++ v 0 appl
+
+let explain_unexpected_type ctx actual_type expected_type =
+  let pract = prterm_env ctx actual_type in
+  let prexp = prterm_env ctx expected_type in
+  str"This type is" ++ spc () ++ pract ++ spc () ++ 
+  str "but is expected to be" ++
+  spc () ++ prexp
+
+let explain_not_product ctx c =
+  let pr = prterm_env ctx c in
+  str"The type of this term is a product," ++ spc () ++
+  str"but it is casted with type" ++
+  brk(1,1) ++ pr
+
+(* TODO: use the names *)
+(* (co)fixpoints *)
+let explain_ill_formed_rec_body ctx err names i =
+  let prt_name i =
+    match names.(i) with
+        Name id -> str "Recursive definition of " ++ pr_id id
+      | Anonymous -> str"The " ++ nth i ++ str" definition" in
+
+  let st = match err with
+
+  (* Fixpoint guard errors *)
+  | NotEnoughAbstractionInFixBody ->
+      str "Not enough abstractions in the definition"
+  | RecursionNotOnInductiveType ->
+      str "Recursive definition on a non inductive type"
+  | RecursionOnIllegalTerm(j,arg,le,lt) ->
+      let called =
+        match names.(j) with
+            Name id -> pr_id id
+          | Anonymous -> str"the " ++ nth i ++ str" definition" in
+      let vars =
+        match (lt,le) with
+            ([],[]) -> mt()
+          | ([],[x]) ->
+              str "a subterm of " ++ pr_db ctx x
+          | ([],_) ->
+              str "a subterm of the following variables: " ++
+              prlist_with_sep pr_spc (pr_db ctx) le
+          | ([x],_) -> pr_db ctx x
+          | _ ->
+              str "one of the following variables: " ++
+              prlist_with_sep pr_spc (pr_db ctx) lt in
+      str "Recursive call to " ++ called ++ spc() ++
+      str "has principal argument equal to" ++ spc() ++
+      prterm_env ctx arg ++ fnl() ++ str "instead of " ++ vars
+
+  | NotEnoughArgumentsForFixCall j ->
+      let called =
+        match names.(j) with
+            Name id -> pr_id id
+          | Anonymous -> str"the " ++ nth i ++ str" definition" in
+     str "Recursive call to " ++ called ++ str " had not enough arguments"
+
+  (* CoFixpoint guard errors *)
+  | CodomainNotInductiveType c ->
+      str "the codomain is" ++ spc () ++ prterm_env ctx c ++ spc () ++
+      str "which should be a coinductive type"
+  | NestedRecursiveOccurrences ->
+      str "nested recursive occurrences"
+  | UnguardedRecursiveCall c ->
+      str "unguarded recursive call in" ++ spc() ++ prterm_env ctx c
+  | RecCallInTypeOfAbstraction c ->
+      str "recursive call forbidden in the domain of an abstraction:" ++
+      spc() ++ prterm_env ctx c
+  | RecCallInNonRecArgOfConstructor c ->
+      str "recursive call on a non-recursive argument of constructor" ++
+      spc() ++ prterm_env ctx c
+  | RecCallInTypeOfDef c ->
+      str "recursive call forbidden in the type of a recursive definition" ++
+      spc() ++ prterm_env ctx c
+  | RecCallInCaseFun c ->
+      str "recursive call in a branch of" ++ spc() ++ prterm_env ctx c
+  | RecCallInCaseArg c -> 
+      str "recursive call in the argument of cases in" ++ spc() ++
+      prterm_env ctx c
+  | RecCallInCasePred c ->
+      str "recursive call in the type of cases in" ++  spc() ++
+      prterm_env ctx c
+  | NotGuardedForm c ->
+      str "sub-expression " ++ prterm_env ctx c ++ spc() ++
+      str "not in guarded form" ++ spc()++
+      str"(should be a constructor, an abstraction, a match, a cofix or a recursive call)"
+  in
+  prt_name i ++ str" is ill-formed." ++ fnl() ++
+  pr_ne_context_of (str "In environment") ctx ++
+  st
+
+let explain_ill_typed_rec_body ctx i names vdefj vargs =
+  let ctx = make_all_name_different ctx in
+  let pvd,pvdt = prjudge_env ctx (vdefj.(i)) in
+  let pv = prterm_env ctx vargs.(i) in
+  str"The "  ++
+  (if Array.length vdefj = 1 then mt () else int (i+1) ++ str "-th") ++
+  str"recursive definition"  ++ spc () ++ pvd ++ spc () ++
+  str "has type" ++ spc () ++ pvdt ++spc () ++ 
+  str "it should be" ++ spc () ++ pv 
+(*
+let explain_not_inductive ctx c =
+  let ctx = make_all_name_different ctx in
+  let pc = prterm_env ctx c in
+  str"The term" ++ brk(1,1) ++ pc ++ spc () ++
+  str "is not an inductive definition"
+*)
+let explain_cant_find_case_type ctx c =
+  let ctx = make_all_name_different ctx in
+  let pe = prterm_env ctx c in
+  hov 3 (str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe)
+
+let explain_occur_check ctx ev rhs =
+  let ctx = make_all_name_different ctx in
+  let id = Evd.string_of_existential ev in
+  let pt = prterm_env ctx rhs in
+  str"Occur check failed: tried to define " ++ str id ++
+  str" with term" ++ brk(1,1) ++ pt
+
+let explain_hole_kind env = function
+  | QuestionMark -> str "a term for this placeholder"
+  | CasesType ->
+      str "the type of this pattern-matching problem"
+  | BinderType (Name id) ->
+      str "a type for " ++ Nameops.pr_id id
+  | BinderType Anonymous ->
+      str "a type for this anonymous binder"
+  | ImplicitArg (c,n) ->
+      if !Options.v7 then
+	str "the " ++ pr_ord n ++
+	str " implicit argument of " ++ Nametab.pr_global_env Idset.empty c
+      else
+	let imps = Impargs.implicits_of_global c in
+	let id = Impargs.name_of_implicit (List.nth imps (n-1)) in
+	str "an instance for the implicit parameter " ++
+	pr_id id ++ spc () ++ str "of" ++
+	spc () ++ Nametab.pr_global_env Idset.empty c
+  | InternalHole ->
+      str "a term for an internal placeholder"
+  | TomatchTypeParameter (tyi,n) ->
+      str "the " ++ pr_ord n ++
+      str " argument of the inductive type (" ++ pr_inductive env tyi ++
+      str ") of this term"
+
+let explain_not_clean ctx ev t k =
+  let ctx = make_all_name_different ctx in
+  let c = mkRel (Intset.choose (free_rels t)) in
+  let id = Evd.string_of_existential ev in
+  let var = prterm_env ctx c in
+  str"Tried to define " ++ explain_hole_kind ctx k ++
+  str" (" ++ str id ++ str ")" ++ spc() ++
+  str"with a term using variable " ++ var ++ spc () ++
+  str"which is not in its scope."
+
+let explain_unsolvable_implicit env k =
+  str "Cannot infer " ++ explain_hole_kind env k
+
+
+let explain_var_not_found ctx id = 
+  str "The variable" ++ spc () ++ str (string_of_id id) ++
+  spc ()  ++ str "was not found" ++ 
+  spc ()  ++ str "in the current" ++ spc ()  ++ str "environment"
+
+let explain_wrong_case_info ctx ind ci =
+  let ctx = make_all_name_different ctx in
+  let pi = prterm (mkInd ind) in
+  if ci.ci_ind = ind then
+    str"Pattern-matching expression on an object of inductive" ++ spc () ++ pi ++
+    spc () ++ str"has invalid information"
+  else
+    let pc = prterm (mkInd ci.ci_ind) in
+    str"A term of inductive type" ++ spc () ++ pi ++ spc () ++
+    str"was given to a pattern-matching expression on the inductive type" ++
+    spc () ++ pc
+       
+
+let explain_type_error ctx err =
+  let ctx = make_all_name_different ctx in
+  match err with
+  | UnboundRel n -> 
+      explain_unbound_rel ctx n
+  | UnboundVar v -> 
+      explain_unbound_var ctx v
+  | NotAType j -> 
+      explain_not_type ctx j
+  | BadAssumption c -> 
+      explain_bad_assumption ctx c
+  | ReferenceVariables id -> 
+      explain_reference_variables id
+  | ElimArity (ind, aritylst, c, pj, okinds) ->
+      explain_elim_arity ctx ind aritylst c pj okinds 
+  | CaseNotInductive cj -> 
+      explain_case_not_inductive ctx cj
+  | NumberBranches (cj, n) -> 
+      explain_number_branches ctx cj n
+  | IllFormedBranch (c, i, actty, expty) -> 
+      explain_ill_formed_branch ctx c i actty expty 
+  | Generalization (nvar, c) ->
+      explain_generalization ctx nvar c
+  | ActualType (j, pt) -> 
+      explain_actual_type ctx j pt
+  | CantApplyBadType (t, rator, randl) ->
+      explain_cant_apply_bad_type ctx t rator randl
+  | CantApplyNonFunctional (rator, randl) ->
+      explain_cant_apply_not_functional ctx rator randl
+  | IllFormedRecBody (err, lna, i) ->
+      explain_ill_formed_rec_body ctx err lna i
+  | IllTypedRecBody (i, lna, vdefj, vargs) -> 
+     explain_ill_typed_rec_body ctx i lna vdefj vargs
+  | WrongCaseInfo (ind,ci) ->
+      explain_wrong_case_info ctx ind ci
+(*
+  | NotInductive c ->
+      explain_not_inductive ctx c
+*)
+let explain_pretype_error ctx err =
+  let ctx = make_all_name_different ctx in
+  match err with
+  | CantFindCaseType c ->
+      explain_cant_find_case_type ctx c
+  | OccurCheck (n,c) ->
+      explain_occur_check ctx n c
+  | NotClean (n,c,k) ->
+      explain_not_clean ctx n c k
+  | UnsolvableImplicit k ->
+      explain_unsolvable_implicit ctx k
+  | VarNotFound id ->
+      explain_var_not_found ctx id
+  | UnexpectedType (actual,expected) ->
+      explain_unexpected_type ctx actual expected
+  | NotProduct c ->
+      explain_not_product ctx c
+
+(* Refiner errors *)
+
+let explain_refiner_bad_type arg ty conclty =
+  str"refiner was given an argument" ++ brk(1,1) ++ 
+  prterm arg ++ spc () ++
+  str"of type" ++ brk(1,1) ++ prterm ty ++ spc () ++
+  str"instead of" ++ brk(1,1) ++ prterm conclty
+
+let explain_refiner_occur_meta t =
+  str"cannot refine with term" ++ brk(1,1) ++ prterm t ++
+  spc () ++ str"because there are metavariables, and it is" ++
+  spc () ++ str"neither an application nor a Case"
+
+let explain_refiner_occur_meta_goal t =
+  str"generated subgoal" ++ brk(1,1) ++ prterm t ++
+  spc () ++ str"has metavariables in it"
+
+let explain_refiner_cannot_applt t harg =
+  str"in refiner, a term of type " ++ brk(1,1) ++
+  prterm t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++
+  prterm harg
+
+let explain_cannot_unify m n =
+  let pm = prterm m in 
+  let pn = prterm n in
+  str"Impossible to unify" ++ brk(1,1)  ++ pm ++ spc ()  ++
+  str"with" ++ brk(1,1)  ++ pn
+
+let explain_cannot_unify_binding_type m n =
+  let pm = prterm m in 
+  let pn = prterm n in
+  str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ 
+  str "which should be unifiable with" ++ brk(1,1) ++ pn
+
+let explain_refiner_cannot_generalize ty =
+  str "Cannot find a well-typed generalisation of the goal with type : " ++ 
+  prterm ty
+
+let explain_refiner_not_well_typed c =
+  str"The term "  ++ prterm c  ++ str" is not well-typed"
+
+let explain_intro_needs_product () =
+  str "Introduction tactics needs products"
+
+let explain_does_not_occur_in c hyp =
+  str "The term" ++ spc () ++ prterm c ++ spc () ++ str "does not occur in" ++ 
+  spc () ++ pr_id hyp
+
+let explain_non_linear_proof c =
+  str "cannot refine with term" ++ brk(1,1) ++ prterm c ++
+  spc () ++ str"because a metavariable has several occurrences"
+
+let explain_no_occurrence_found c =
+  str "Found no subterm matching " ++ prterm c ++ str " in the current goal"
+
+let explain_refiner_error = function
+  | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
+  | OccurMeta t -> explain_refiner_occur_meta t
+  | OccurMetaGoal t -> explain_refiner_occur_meta_goal t
+  | CannotApply (t,harg) -> explain_refiner_cannot_applt t harg
+  | CannotUnify (m,n) -> explain_cannot_unify m n
+  | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type m n
+  | CannotGeneralize ty -> explain_refiner_cannot_generalize ty
+  | NotWellTyped c -> explain_refiner_not_well_typed c
+  | IntroNeedsProduct -> explain_intro_needs_product ()
+  | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp
+  | NonLinearProof c -> explain_non_linear_proof c
+  | NoOccurrenceFound c -> explain_no_occurrence_found c
+
+(* Inductive errors *)
+
+let error_non_strictly_positive env c v  =
+  let pc = prterm_env env c in
+  let pv = prterm_env env v in
+  str "Non strictly positive occurrence of " ++ pv ++ str " in" ++
+  brk(1,1) ++ pc
+
+let error_ill_formed_inductive env c v =
+  let pc = prterm_env env c in
+  let pv = prterm_env env v in
+  str "Not enough arguments applied to the " ++ pv ++
+  str " in" ++ brk(1,1) ++ pc
+
+let error_ill_formed_constructor env c v =
+  let pc = prterm_env env c in
+  let pv = prterm_env env v in
+  str "The conclusion of" ++ brk(1,1) ++ pc ++ brk(1,1) ++ 
+  str "is not valid;" ++ brk(1,1) ++ str "it must be built from " ++ pv
+
+let str_of_nth n =
+  (string_of_int n)^
+  (match n mod 10 with
+     | 1 -> "st"
+     | 2 -> "nd"
+     | 3 -> "rd"
+     | _ -> "th")
+
+let error_bad_ind_parameters env c n v1 v2  =
+  let pc = prterm_env_at_top env c in
+  let pv1 = prterm_env env v1 in
+  let pv2 = prterm_env env v2 in
+  str ("The "^(str_of_nth n)^" argument of ") ++ pv2 ++ brk(1,1) ++
+  str "must be " ++ pv1 ++ str " in" ++ brk(1,1) ++ pc
+
+let error_same_names_types id =
+  str "The name" ++ spc () ++ pr_id id ++ spc () ++ 
+  str "is used twice is the inductive types definition."
+
+let error_same_names_constructors id cid =
+  str "The constructor name" ++ spc () ++ pr_id cid ++ spc () ++ 
+  str "is used twice is the definition of type" ++ spc () ++
+  pr_id id
+
+let error_same_names_overlap idl = 
+  str "The following names" ++ spc () ++ 
+  str "are used both as type names and constructor names:" ++ spc () ++
+  prlist_with_sep pr_coma pr_id idl
+
+let error_not_an_arity id =
+  str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity."
+
+let error_bad_entry () =
+  str "Bad inductive definition."
+
+let error_not_allowed_case_analysis dep kind i =
+  str (if dep then "Dependent" else "Non Dependent") ++
+  str " case analysis on sort: " ++ print_sort kind ++ fnl () ++
+  str "is not allowed for inductive definition: " ++
+  pr_inductive (Global.env()) i
+
+let error_bad_induction dep indid kind =
+  str (if dep then "Dependent" else "Non dependent") ++
+  str " induction for type " ++ pr_id indid ++
+  str " and sort " ++ print_sort kind ++ spc () ++
+  str "is not allowed"
+
+let error_not_mutual_in_scheme () =
+ str "Induction schemes is concerned only with mutually inductive types"
+
+let explain_inductive_error = function
+  (* These are errors related to inductive constructions *)
+  | NonPos (env,c,v) -> error_non_strictly_positive env c v
+  | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v
+  | NotConstructor (env,c,v) -> error_ill_formed_constructor env c v
+  | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2
+  | SameNamesTypes id -> error_same_names_types id
+  | SameNamesConstructors (id,cid) -> error_same_names_constructors id cid
+  | SameNamesOverlap idl -> error_same_names_overlap idl
+  | NotAnArity id -> error_not_an_arity id
+  | BadEntry -> error_bad_entry ()
+  (* These are errors related to recursors *)
+  | NotAllowedCaseAnalysis (dep,k,i) ->
+      error_not_allowed_case_analysis dep k i
+  | BadInduction (dep,indid,kind) -> error_bad_induction dep indid kind
+  | NotMutualInScheme -> error_not_mutual_in_scheme ()
+
+(* Pattern-matching errors *)
+
+let explain_bad_pattern ctx cstr ty = 
+  let ctx = make_all_name_different ctx in
+  let pt = prterm_env ctx ty in
+  let pc = pr_constructor ctx cstr in
+  str "Found the constructor " ++ pc ++ brk(1,1) ++ 
+  str "while matching a term of type " ++ pt ++ brk(1,1) ++ 
+  str "which is not an inductive type"
+
+let explain_bad_constructor ctx cstr ind =
+  let pi = pr_inductive ctx ind in
+(*  let pc = pr_constructor ctx cstr in*)
+  let pt = pr_inductive ctx (inductive_of_constructor cstr) in
+  str "Found a constructor of inductive type " ++ pt ++ brk(1,1)  ++
+  str "while a constructor of "  ++ pi ++ brk(1,1)  ++
+  str "is expected"
+
+let explain_wrong_numarg_of_constructor ctx cstr n =
+  let pc = pr_constructor ctx cstr in
+  str "The constructor " ++ pc ++ str " expects "  ++
+  (if n = 0 then str "no argument." else if n = 1 then str "1 argument."
+   else (int n  ++ str " arguments."))
+
+let explain_wrong_predicate_arity ctx pred nondep_arity dep_arity=
+  let ctx = make_all_name_different ctx in
+  let pp = prterm_env ctx pred in
+  str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++
+  str "should be of arity"  ++ spc () ++
+  prterm_env ctx nondep_arity  ++ spc () ++ 
+  str "(for non dependent case) or"  ++
+  spc () ++ prterm_env ctx dep_arity  ++ spc () ++ str "(for dependent case)."
+
+let explain_needs_inversion ctx x t =
+  let ctx = make_all_name_different ctx in
+  let px = prterm_env ctx x in
+  let pt = prterm_env ctx t in
+  str "Sorry, I need inversion to compile pattern matching of term " ++
+  px  ++ str " of type: " ++ pt
+
+let explain_unused_clause env pats =
+  let s = if List.length pats > 1 then "s" else "" in
+(* Without localisation
+  (str ("Unused clause with pattern"^s) ++ spc () ++
+    hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")")
+*)
+  str "This clause is redundant"
+
+let explain_non_exhaustive env pats =
+  let s = if List.length pats > 1 then "s" else "" in
+  str ("Non exhaustive pattern-matching: no clause found for pattern"^s) ++
+  spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats)
+
+let explain_cannot_infer_predicate ctx typs =
+  let ctx = make_all_name_different ctx in
+  let pr_branch (cstr,typ) =
+    let cstr,_ = decompose_app cstr in
+    str "For " ++ prterm_env ctx cstr ++ str " : " ++ prterm_env ctx typ
+  in
+  str "Unable to unify the types found in the branches:" ++
+  spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs))
+
+let explain_pattern_matching_error env = function
+  | BadPattern (c,t) -> 
+      explain_bad_pattern env c t
+  | BadConstructor (c,ind) ->
+      explain_bad_constructor env c ind
+  | WrongNumargConstructor (c,n) ->
+      explain_wrong_numarg_of_constructor env c n
+  | WrongPredicateArity (pred,n,dep) ->
+      explain_wrong_predicate_arity env pred n dep
+  | NeedsInversion (x,t) ->
+      explain_needs_inversion env x t
+  | UnusedClause tms ->
+      explain_unused_clause env tms
+  | NonExhaustive tms ->
+      explain_non_exhaustive env tms
+  | CannotInferPredicate typs ->
+      explain_cannot_infer_predicate env typs
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
new file mode 100644
index 00000000..3e7ba575
--- /dev/null
+++ b/toplevel/himsg.mli
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: himsg.mli,v 1.13.14.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Indtypes
+open Environ
+open Type_errors
+open Pretype_errors
+open Cases
+open Logic
+(*i*)
+
+(* This module provides functions to explain the type errors. *)
+
+val explain_type_error : env -> type_error -> std_ppcmds
+
+val explain_pretype_error : env -> pretype_error -> std_ppcmds
+
+val explain_inductive_error : inductive_error -> std_ppcmds
+
+val explain_refiner_error : refiner_error -> std_ppcmds
+
+val explain_pattern_matching_error :
+  env -> pattern_matching_error -> std_ppcmds
diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml
new file mode 100644
index 00000000..81221196
--- /dev/null
+++ b/toplevel/line_oriented_parser.ml
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: line_oriented_parser.ml,v 1.2.16.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+let line_oriented_channel_to_option stop_string input_channel =
+  let count = ref 0 in
+  let buff = ref "" in
+  let current_length = ref 0 in
+  fun i -> 
+    if (i - !count) >= !current_length then begin
+      count := !count + !current_length + 1;
+      buff := input_line input_channel;
+      if !buff = stop_string then
+        None
+      else begin
+        current_length := String.length !buff;
+        Some '\n'
+      end
+    end else
+      Some (String.get !buff (i - !count))
+
+let flush_until_end_of_stream char_stream =
+  Stream.iter (function _ -> ()) char_stream
diff --git a/toplevel/line_oriented_parser.mli b/toplevel/line_oriented_parser.mli
new file mode 100644
index 00000000..13af0e06
--- /dev/null
+++ b/toplevel/line_oriented_parser.mli
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: line_oriented_parser.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+val line_oriented_channel_to_option: string -> in_channel -> int -> char option
+
+val flush_until_end_of_stream : 'a Stream.t -> unit
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
new file mode 100644
index 00000000..84bda0af
--- /dev/null
+++ b/toplevel/metasyntax.ml
@@ -0,0 +1,1428 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: metasyntax.ml,v 1.105.2.2 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Topconstr
+open Coqast
+open Ast
+open Ppextend
+open Extend
+open Esyntax
+open Libobject
+open Library
+open Summary
+open Constrintern
+open Vernacexpr
+open Pcoq
+open Rawterm
+open Libnames
+
+let interp_global_rawconstr_with_vars vars c =
+  interp_rawconstr_gen false Evd.empty (Global.env()) false (vars,[]) c
+
+(**********************************************************************)
+(* Parsing via ast (used in Zsyntax) *)
+
+(* This updates default parsers for Grammar actions and Syntax *)
+(* patterns by inserting globalization *)
+(* Done here to get parsing/g_*.ml4 non dependent from kernel *)
+let constr_to_ast a =
+  Termast.ast_of_rawconstr (interp_rawconstr Evd.empty (Global.env()) a)
+
+(* This installs default quotations parsers to escape the ast parser *)
+(* "constr" is used by default in quotations found in the ast parser *) 
+let constr_parser_with_glob = Pcoq.map_entry constr_to_ast Constr.constr
+
+let _ = define_ast_quotation true "constr" constr_parser_with_glob
+
+(**********************************************************************)
+(* Globalisation for constr_expr *)
+
+let globalize_ref vars ref =
+  match Constrintern.interp_reference (vars,[]) ref with
+  | RRef (loc,VarRef a) -> Ident (loc,a)
+  | RRef (loc,a) -> Qualid (loc,qualid_of_sp (Nametab.sp_of_global a))
+  | RVar (loc,x) -> Ident (loc,x)
+  | _ -> anomaly "globalize_ref: not a reference"
+
+let globalize_ref_term vars ref =
+  match Constrintern.interp_reference (vars,[]) ref with
+  | RRef (loc,VarRef a) -> CRef (Ident (loc,a))
+  | RRef (loc,a) -> CRef (Qualid (loc,qualid_of_sp (Nametab.sp_of_global a)))
+  | RVar (loc,x) -> CRef (Ident (loc,x))
+  | c -> Constrextern.extern_rawconstr Idset.empty c 
+
+let rec globalize_constr_expr vars = function
+  | CRef ref -> globalize_ref_term vars ref
+  | CAppExpl (_,(p,ref),l) ->
+      let f = 
+	map_constr_expr_with_binders globalize_constr_expr
+	  (fun x e -> e) vars
+      in
+      CAppExpl (dummy_loc,(p,globalize_ref vars ref), List.map f l)
+  | c ->
+      map_constr_expr_with_binders globalize_constr_expr (fun id e -> id::e)
+        vars c
+
+let without_translation f x =
+  let old = Options.do_translate () in
+  let oldv7 = !Options.v7 in
+  Options.make_translate false;
+  try let r = f x in Options.make_translate old; Options.v7:=oldv7; r
+  with e -> Options.make_translate old; Options.v7:=oldv7; raise e
+
+let _ = set_constr_globalizer
+  (fun vars e -> for_grammar (without_translation (globalize_constr_expr vars)) e)
+
+(**********************************************************************)
+(** For old ast printer *)
+
+(* Pretty-printer state summary *)
+let _ = 
+  declare_summary "syntax"
+    { freeze_function = Esyntax.freeze;
+      unfreeze_function = Esyntax.unfreeze;
+      init_function = Esyntax.init;
+      survive_module = false;
+      survive_section = false }
+
+(* Pretty-printing objects = syntax_entry *)
+let cache_syntax (_,ppobj) = Esyntax.add_ppobject ppobj
+
+let subst_syntax (_,subst,ppobj) = 
+  Extend.subst_syntax_command Ast.subst_astpat subst ppobj
+
+let (inPPSyntax,outPPSyntax) =
+  declare_object {(default_object "PPSYNTAX") with
+       open_function = (fun i o -> if i=1 then cache_syntax o);
+       cache_function = cache_syntax;
+       subst_function = subst_syntax;
+       classify_function = (fun (_,o) -> Substitute o);       
+       export_function = (fun x -> Some x) }
+
+(* Syntax extension functions (registered in the environnement) *)
+
+(* Checking the pretty-printing rules against free meta-variables.
+ * Note that object are checked before they are added in the environment.
+ * Syntax objects in compiled modules are not re-checked. *)
+
+let add_syntax_obj whatfor sel =
+(*  if not !Options.v7_only then*)
+  Lib.add_anonymous_leaf (inPPSyntax (interp_syntax_entry whatfor sel))
+
+(* Tokens *)
+
+let cache_token (_,s) = Pcoq.lexer.Token.using ("", s)
+
+let (inToken, outToken) =
+  declare_object {(default_object "TOKEN") with
+       open_function = (fun i o -> if i=1 then cache_token o);
+       cache_function = cache_token;
+       subst_function = Libobject.ident_subst_function;
+       classify_function = (fun (_,o) -> Substitute o);
+       export_function = (fun x -> Some x)}
+
+let add_token_obj s = Lib.add_anonymous_leaf (inToken s)
+
+(**********************************************************************)
+(* Grammars (especially Tactic Notation) *)
+
+let make_terminal_status = function
+  | VTerm s -> Some s
+  | VNonTerm _ -> None
+
+let qualified_nterm current_univ = function
+  | NtQual (univ, en) -> (univ, en)
+  | NtShort en -> (current_univ, en)
+
+let rec make_tags = function
+  | VTerm s :: l -> make_tags l
+  | VNonTerm (loc, nt, po) :: l ->
+      let (u,nt) = qualified_nterm "tactic" nt in
+      let (etyp, _) = Egrammar.interp_entry_name u nt in
+      etyp :: make_tags l
+  | [] -> []
+
+let declare_pprule = function
+  (* Pretty-printing rules only for Grammar (Tactic Notation) *)
+  | Egrammar.TacticGrammar gl ->
+      let f (s,(s',l),tac) =
+        let pp = (make_tags l, (s',List.map make_terminal_status l)) in
+        Pptactic.declare_extra_tactic_pprule true s pp;
+        Pptactic.declare_extra_tactic_pprule false s pp in
+      List.iter f gl
+  | _ -> ()
+
+let cache_grammar (_,a) =
+  Egrammar.extend_grammar a;
+  declare_pprule a
+
+let subst_grammar (_,subst,a) =
+  Egrammar.subst_all_grammar_command subst a
+
+let (inGrammar, outGrammar) =
+  declare_object {(default_object "GRAMMAR") with
+       open_function = (fun i o -> if i=1 then cache_grammar o);
+       cache_function = cache_grammar;
+       subst_function = subst_grammar;
+       classify_function = (fun (_,o) -> Substitute o);
+       export_function = (fun x -> Some x)}
+
+(**********************************************************************)
+(* V7 Grammar                                                         *)
+
+open Genarg
+
+let check_entry_type (u,n) =
+  if u = "tactic" or u = "vernac" then error "tactic and vernac not supported";
+  match entry_type (get_univ u) n with
+    | None -> Pcoq.create_entry_if_new (get_univ u) n ConstrArgType
+    | Some (ConstrArgType | IdentArgType | RefArgType) -> ()
+    | _ -> error "Cannot arbitrarily extend non constr/ident/ref entries"
+
+let add_grammar_obj univ entryl =
+  let u = create_univ_if_new univ in
+  let g = interp_grammar_command univ check_entry_type entryl in
+  Lib.add_anonymous_leaf (inGrammar (Egrammar.Grammar g))
+
+(**********************************************************************)
+(* V8 Grammar *)
+
+(* Tactic notations *)
+
+let locate_tactic_body dir (s,p,e) = (s,p,(dir,e))
+
+let add_tactic_grammar g =
+  let dir = Lib.cwd () in
+  let g = List.map (locate_tactic_body dir) g in
+  Lib.add_anonymous_leaf (inGrammar (Egrammar.TacticGrammar g))
+
+(* Printing grammar entries *)
+
+let print_grammar univ entry =
+  if !Options.v7 then
+    let u = get_univ univ in
+    let typ = explicitize_entry (fst u) entry in
+    let te,_,_ = get_constr_entry false typ in
+    Gram.Entry.print te
+  else
+    match entry with
+      | "constr" | "operconstr" | "binder_constr" ->
+	  msgnl (str "Entry constr is");
+	  Gram.Entry.print Pcoq.Constr.constr;
+	  msgnl (str "and lconstr is");
+	  Gram.Entry.print Pcoq.Constr.lconstr;
+	  msgnl (str "where binder_constr is");
+	  Gram.Entry.print Pcoq.Constr.binder_constr;
+	  msgnl (str "and operconstr is");
+	  Gram.Entry.print Pcoq.Constr.operconstr;
+      | "pattern" ->
+	  Gram.Entry.print Pcoq.Constr.pattern
+      | "tactic" -> 
+	  Gram.Entry.print Pcoq.Tactic.simple_tactic
+      | _ -> error "Unknown or unprintable grammar entry"
+
+(* Parse a format (every terminal starting with a letter or a single
+   quote (except a single quote alone) must be quoted) *)
+
+let parse_format (loc,str) =
+  let str = " "^str in
+  let l = String.length str in
+  let push_token a = function
+    | cur::l -> (a::cur)::l
+    | [] -> [[a]] in
+  let push_white n l =
+    if n = 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
+  let close_box i b = function
+    | a::(_::_ as l) -> push_token (UnpBox (b,a)) l
+    | _ -> error "Non terminated box in format" in
+  let close_quotation i =
+    if i < String.length str & str.[i] = '\'' & (i+1 = l or str.[i+1] = ' ')
+    then i+1
+    else error "Incorrectly terminated quoted expression" in
+  let rec spaces n i =
+    if i < String.length str & str.[i] = ' ' then spaces (n+1) (i+1)
+    else n in
+  let rec nonspaces quoted n i =
+    if i < String.length str & str.[i] <> ' ' then
+      if str.[i] = '\'' & quoted &
+        (i+1 >= String.length str or str.[i+1] = ' ')
+      then if n=0 then error "Empty quoted token" else n
+      else nonspaces quoted (n+1) (i+1)
+    else
+      if quoted then error "Spaces are not allowed in (quoted) symbols"
+      else n in
+  let rec parse_non_format i =
+    let n = nonspaces false 0 i in
+    push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n))
+  and parse_quoted n i =
+    if i < String.length str then match str.[i] with
+      (* Parse " // " *)
+      | '/' when i <= String.length str & str.[i+1] = '/' ->
+          (* We forget the useless n spaces... *)
+	  push_token (UnpCut PpFnl) 
+            (parse_token (close_quotation (i+2)))
+      (* Parse " .. / .. " *)
+      | '/' when i <= String.length str ->
+	  let p = spaces 0 (i+1) in
+	  push_token (UnpCut (PpBrk (n,p)))
+            (parse_token (close_quotation (i+p+1)))
+      | c ->
+      (* The spaces are real spaces *)
+      push_white n (match c with
+      | '[' ->
+	  if i <= String.length str then match str.[i+1] with
+	    (* Parse " [h .. ",  *)
+	    | 'h' when i+1 <= String.length str & str.[i+2] = 'v' ->
+		  (parse_box (fun n -> PpHVB n) (i+3))
+		(* Parse " [v .. ",  *)
+	    | 'v' ->
+		    parse_box (fun n -> PpVB n) (i+2)
+		(* Parse " [ .. ",  *)
+	    | ' ' | '\'' ->
+		parse_box (fun n -> PpHOVB n) (i+1)
+	    | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format"
+	  else error "\"v\", \"hv\" or \" \" expected after \"[\" in format"
+      (* Parse "]"  *)
+      | ']' ->
+	  ([] :: parse_token (close_quotation (i+1)))
+      (* Parse a non formatting token *)
+      | c ->
+	  let n = nonspaces true 0 i in
+	  push_token (UnpTerminal (String.sub str (i-1) (n+2)))
+	    (parse_token (close_quotation (i+n))))
+    else
+      if n = 0 then []
+      else error "Ending spaces non part of a format annotation"
+  and parse_box box i =
+    let n = spaces 0 i in
+    close_box i (box n) (parse_token (close_quotation (i+n)))
+  and parse_token i =
+    let n = spaces 0 i in
+    let i = i+n in
+    if i < l then match str.[i] with
+      (* Parse a ' *)
+      |	'\'' when i+1 >= String.length str or str.[i+1] = ' ' ->
+	  push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1)))
+      (* Parse the beginning of a quoted expression *)
+      |	'\'' ->
+          parse_quoted (n-1) (i+1)
+      (* Otherwise *)
+      | _ ->
+          push_white (n-1) (parse_non_format i)
+    else push_white n [[]]
+  in
+  try
+    if str <> "" then match parse_token 0 with
+      | [l] -> l
+      | _ -> error "Box closed without being opened in format"
+    else
+      error "Empty format"
+  with e ->
+    Stdpp.raise_with_loc loc e
+
+(***********************)
+(* Analysing notations *)
+
+open Symbols
+
+type symbol_token = WhiteSpace of int | String of string
+
+let split_notation_string str =
+  let push_token beg i l =
+    if beg = i then l else
+      let s = String.sub str beg (i - beg) in
+      String s :: l 
+  in
+  let push_whitespace beg i l =
+    if beg = i then l else WhiteSpace (i-beg) :: l 
+  in
+  let rec loop beg i =
+    if i < String.length str then
+      if str.[i] = ' ' then
+	push_token beg i (loop_on_whitespace (i+1) (i+1))
+      else
+	loop beg (i+1)
+    else
+      push_token beg i []
+  and loop_on_whitespace beg i =
+    if i < String.length str then
+      if str.[i] <> ' ' then
+	push_whitespace beg i (loop i (i+1))
+      else
+	loop_on_whitespace beg (i+1)
+    else
+      push_whitespace beg i []
+  in
+  loop 0 0
+
+let unquote_notation_token s =
+  let n = String.length s in
+  if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
+
+let is_normal_token str =
+  try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false
+
+(* To protect alphabetic tokens and quotes from being seen as variables *)
+let quote_notation_token x =
+  let n = String.length x in
+  let norm = is_normal_token x in
+  if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'"
+  else x
+
+let rec raw_analyse_notation_tokens = function
+  | []    -> [], []
+  | String ".." :: sl ->
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      (list_add_set ldots_var vars, NonTerminal ldots_var :: l)
+  | String x :: sl when is_normal_token x ->
+      Lexer.check_ident x;
+      let id = Names.id_of_string x in
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      if List.mem id vars then
+	error ("Variable "^x^" occurs more than once");
+      (id::vars, NonTerminal id :: l)
+  | String s :: sl ->
+      Lexer.check_keyword s;
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      (vars, Terminal (unquote_notation_token s) :: l)
+  | WhiteSpace n :: sl ->
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      (vars, Break n :: l)
+
+let rec find_pattern xl = function
+  | Break n as x :: l, Break n' :: l' when n=n' -> 
+      find_pattern (x::xl) (l,l')
+  | Terminal s as x :: l, Terminal s' :: l' when s = s' -> 
+      find_pattern (x::xl) (l,l')
+  | [NonTerminal x], NonTerminal x' :: l' ->
+      (x,x',xl),l'
+  | [NonTerminal _], Terminal s :: _ | Terminal s :: _, _ ->
+      error ("The token "^s^" occurs on one side of \"..\" but not on the other side")
+  | [NonTerminal _], Break s :: _ | Break s :: _, _ ->
+      error ("A break occurs on one side of \"..\" but not on the other side")
+  | ((SProdList _ | NonTerminal _) :: _ | []), _ -> 
+      error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\"")
+
+let rec interp_list_parser hd = function
+  | [] -> [], List.rev hd
+  | NonTerminal id :: tl when id = ldots_var ->
+      let ((x,y,sl),tl') = find_pattern [] (hd,tl) in
+      let yl,tl'' = interp_list_parser [] tl' in
+      (* We remember the second copy of each recursive part variable to *)
+      (* remove it afterwards *)
+      y::yl, SProdList (x,sl) :: tl''
+  | (Terminal _ | Break _) as s :: tl ->
+      if hd = [] then 
+        let yl,tl' = interp_list_parser [] tl in
+        yl, s :: tl'
+      else
+        interp_list_parser (s::hd) tl
+  | NonTerminal _ as x :: tl ->
+      let yl,tl' = interp_list_parser [x] tl in
+      yl, List.rev_append hd tl'
+  | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser"
+
+let analyse_notation_tokens l =
+  let vars,l = raw_analyse_notation_tokens l in
+  let recvars,l = interp_list_parser [] l in
+  ((if recvars = [] then [] else ldots_var::recvars), vars, l)
+
+let remove_vars = List.fold_right List.remove_assoc
+ 
+(* Build the syntax and grammar rules *)
+
+type printing_precedence = int * parenRelation
+type parsing_precedence = int option
+
+let prec_assoc = function
+  | Gramext.RightA -> (L,E)
+  | Gramext.LeftA -> (E,L)
+  | Gramext.NonA -> (L,L)
+
+(* For old ast printer *)
+let meta_pattern m = Pmeta(m,Tany)
+
+type white_status = Juxtapose | Separate of int | NextIsTerminal
+
+let precedence_of_entry_type from = function
+  | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n
+  | ETConstr (NumLevel n,BorderProd (left,Some a)) ->
+      n, let (lp,rp) = prec_assoc a in if left then lp else rp
+  | ETConstr (NumLevel n,InternalProd) -> n, Prec n
+  | ETConstr (NextLevel,_) -> from, L
+  | ETOther ("constr","annot") -> 10, Prec 10
+  | _ -> 0, E (* ?? *)
+
+(* Some breaking examples *)
+(* "x = y" : "x /1 = y" (breaks before any symbol) *)
+(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*)
+(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *)
+(* "x y" : "x spc y" *)
+(* "{ x } + { y }" : "{ x } / + { y }" *)
+(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *)
+
+let is_left_bracket s =
+  let l = String.length s in l <> 0 &
+  (s.[0] = '{' or s.[0] = '[' or s.[0] = '(')
+
+let is_right_bracket s =
+  let l = String.length s in l <> 0 &
+  (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')')
+
+let is_left_bracket_on_left s =
+  let l = String.length s in l <> 0 & s.[l-1] = '>'
+
+let is_right_bracket_on_right s =
+  let l = String.length s in l <> 0 & s.[0] = '<'
+
+let is_comma s =
+  let l = String.length s in l <> 0 &
+  (s.[0] = ',' or s.[0] = ';')
+
+let is_operator s =
+  let l = String.length s in l <> 0 &
+  (s.[0] = '+' or s.[0] = '*' or s.[0] = '=' or
+   s.[0] = '-' or s.[0] = '/' or s.[0] = '<' or s.[0] = '>' or
+   s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~')
+
+type previous_prod_status = NoBreak | CanBreak
+
+let rec is_non_terminal = function
+  | NonTerminal _ | SProdList _ -> true
+  | _ -> false
+
+let add_break n l = UNP_BRK (n,1) :: l
+
+(* For old ast printer *)
+let make_hunks_ast symbols etyps from =
+  let rec make ws = function
+    | NonTerminal m :: prods ->
+	let _,lp = precedence_of_entry_type from (List.assoc m etyps) in
+	let u = PH (meta_pattern (string_of_id m), None, lp) in
+	if prods <> [] && is_non_terminal (List.hd prods) then
+	  u :: add_break 1 (make CanBreak prods)
+	else
+	  u :: make CanBreak prods
+
+    | Terminal s :: prods when List.exists is_non_terminal prods ->
+	let protect =
+	  is_letter s.[0] ||
+	  (is_non_terminal (List.hd prods) &&
+	    (is_letter (s.[String.length s -1])) ||
+	    (is_digit (s.[String.length s -1]))) in
+	if is_comma s || is_right_bracket s then
+	  RO s :: add_break 0 (make NoBreak prods)
+	else if (is_operator s || is_left_bracket s) && ws = CanBreak then
+	  add_break (if protect then 1 else 0)
+	    (RO (if protect then s^" " else s) :: make CanBreak prods)
+	else
+          if protect then
+            (if ws = CanBreak then add_break 1 else (fun x -> x))
+	    (RO (s^" ") :: make CanBreak prods)
+          else
+	    RO s :: make CanBreak prods
+
+    | Terminal s :: prods ->
+	RO s :: make NoBreak prods
+
+    | Break n :: prods ->
+	add_break n (make NoBreak prods)
+
+    | SProdList _ :: _ ->
+        anomaly "Recursive notations not supported in old syntax"
+
+    | [] -> []
+
+  in make NoBreak symbols
+
+let add_break n l = UnpCut (PpBrk(n,0)) :: l
+
+let make_hunks etyps symbols from =
+  let vars,typs = List.split etyps in
+  let rec make ws = function
+    | NonTerminal m :: prods ->
+	let i = list_index m vars in
+	let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+	let u = UnpMetaVar (i ,prec) in
+	if prods <> [] && is_non_terminal (List.hd prods) then
+	  u :: add_break 1 (make CanBreak prods)
+	else
+	  u :: make CanBreak prods
+
+    | Terminal s :: prods when List.exists is_non_terminal prods ->
+        if is_comma s then
+	  UnpTerminal s :: add_break 1 (make NoBreak prods)
+	else if is_right_bracket s then
+	  UnpTerminal s :: add_break 0 (make NoBreak prods)
+	else if is_left_bracket s then
+          if ws = CanBreak then
+	    add_break 1 (UnpTerminal s :: make CanBreak prods)
+	  else
+	    UnpTerminal s :: make CanBreak prods
+	else if is_operator s then
+	  if ws = CanBreak then
+	    UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods)
+	  else 
+	    UnpTerminal s :: add_break 1 (make NoBreak prods)
+	else if is_ident_tail s.[String.length s - 1] then
+	  if ws = CanBreak then
+	    add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
+	  else
+	    UnpTerminal (s^" ") :: make CanBreak prods
+	else if ws = CanBreak then
+	  add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
+	else
+	  UnpTerminal s :: make CanBreak prods
+
+    | Terminal s :: prods ->
+	if is_right_bracket s then
+	  UnpTerminal s ::make NoBreak prods
+        else if ws = CanBreak then
+	  add_break 1 (UnpTerminal s :: make NoBreak prods)
+        else
+          UnpTerminal s :: make NoBreak prods
+
+    | Break n :: prods ->
+	add_break n (make NoBreak prods)
+
+    | SProdList (m,sl) :: prods ->
+	let i = list_index m vars in
+	let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+        (* We add NonTerminal for simulation but remove it afterwards *)
+        let _,sl' = list_sep_last (make NoBreak (sl@[NonTerminal m])) in
+	UnpListMetaVar (i,prec,sl') :: make CanBreak prods
+
+    | [] -> []
+
+  in make NoBreak symbols
+
+let hunks_of_format (from,(vars,typs) as vt) symfmt = 
+  let rec aux = function
+  | symbs, (UnpTerminal s' as u) :: fmt
+      when s' = String.make (String.length s') ' ' ->
+      let symbs, l = aux (symbs,fmt) in symbs, u :: l
+  | Terminal s :: symbs, (UnpTerminal s' as u) :: fmt
+      when s = unquote_notation_token s' ->
+      let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
+  | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' ->
+      let i = list_index s vars in
+      let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+      let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
+  | symbs, UnpBox (a,b) :: fmt -> 
+      let symbs', b' = aux (symbs,b) in
+      let symbs', l = aux (symbs',fmt) in
+      symbs', UnpBox (a,b') :: l
+  | symbs, (UnpCut _ as u) :: fmt ->
+      let symbs, l = aux (symbs,fmt) in symbs, u :: l
+  | symbs, [] -> symbs, []
+  | _, _ -> error "The format does not match the notation"
+  in
+  match aux symfmt with
+  | [], l -> l
+  | _ -> error "The format does not match the notation"
+
+let string_of_prec (n,p) =
+  (string_of_int n)^(match p with E -> "E" | L -> "L" | _ -> "")
+
+let assoc_of_type n (_,typ) = precedence_of_entry_type n typ
+
+let string_of_assoc = function
+  | Some(Gramext.RightA) -> "RIGHTA"
+  | Some(Gramext.LeftA) | None -> "LEFTA"
+  | Some(Gramext.NonA) -> "NONA"
+
+let is_not_small_constr = function
+    ETConstr _ -> true
+  | ETOther("constr","binder_constr") -> true
+  | _ -> false
+
+let rec define_keywords = function
+    NonTerm(_,Some(_,e)) as n1 :: Term("IDENT",k) :: l
+     when not !Options.v7 && is_not_small_constr e ->
+      prerr_endline ("Defining '"^k^"' as keyword");
+      Lexer.add_token("",k);
+      n1 :: Term("",k) :: define_keywords l
+  | n :: l -> n :: define_keywords l
+  | [] -> []
+
+let define_keywords = function
+    Term("IDENT",k)::l when not !Options.v7 ->
+      prerr_endline ("Defining '"^k^"' as keyword");
+      Lexer.add_token("",k);
+      Term("",k) :: define_keywords l
+  | l -> define_keywords l
+
+let make_production etyps symbols =
+  let prod =
+    List.fold_right
+      (fun t l -> match t with
+        | NonTerminal m ->
+	    let typ = List.assoc m etyps in
+	    NonTerm (typ, Some (m,typ)) :: l
+        | Terminal s ->
+	    Term (Extend.terminal s) :: l
+        | Break _ ->
+            l
+        | SProdList (x,sl) ->
+            let sl = List.flatten
+              (List.map (function Terminal s -> [Extend.terminal s] 
+                | Break _ -> []
+                | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in
+	    let y = match List.assoc x etyps with
+              | ETConstr x -> x
+              | _ ->
+                  error "Component of recursive patterns in notation must be constr" in
+            let typ = ETConstrList (y,sl) in
+            NonTerm (typ, Some (x,typ)) :: l)
+      symbols [] in
+  define_keywords prod
+
+let rec find_symbols c_current c_next c_last = function
+  | [] -> []
+  | NonTerminal id :: sl ->
+      let prec = if sl <> [] then c_current else c_last in
+      (id, prec) :: (find_symbols c_next c_next c_last sl)
+  | Terminal s :: sl -> find_symbols c_next c_next c_last sl
+  | Break n :: sl -> find_symbols c_current c_next c_last sl
+  | SProdList (x,_) :: sl' -> 
+      (x,c_next)::(find_symbols c_next c_next c_last sl')
+
+let border = function
+  | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a
+  | _ -> None
+
+let recompute_assoc typs =
+  match border typs, border (List.rev typs) with
+    | Some Gramext.LeftA, Some Gramext.RightA -> assert false
+    | Some Gramext.LeftA, _ -> Some Gramext.LeftA
+    | _, Some Gramext.RightA -> Some Gramext.RightA
+    | _ -> None
+
+let rec expand_squash = function
+  | Term ("","{") :: NonTerm (ETConstr _, n) :: Term ("","}") :: l ->
+      NonTerm (ETConstr (NextLevel,InternalProd),n)
+      :: expand_squash l
+  | a :: l -> a :: expand_squash l
+  | [] -> []
+
+let make_grammar_rule n typs symbols ntn perm =
+  let assoc = recompute_assoc typs in
+  let prod = make_production typs symbols in
+  (n,assoc,ntn,prod, perm)
+
+(* For old ast printer *)
+let metas_of sl =
+  List.fold_right
+    (fun it metatl -> match it with
+      | NonTerminal m -> m::metatl
+      | _ -> metatl)
+    sl []
+
+(* For old ast printer *)
+let make_pattern symbols ast =
+  let env = List.map (fun m -> (string_of_id m,ETast)) (metas_of symbols) in
+  fst (to_pat env ast)
+
+(* For old ast printer *)
+let make_syntax_rule n name symbols typs ast ntn sc =
+  [{syn_id = name;
+    syn_prec = n;
+    syn_astpat = make_pattern symbols ast;
+    syn_hunks =
+      [UNP_SYMBOLIC(sc,ntn,UNP_BOX (PpHOVB 1,make_hunks_ast symbols typs n))]}]
+
+let make_pp_rule (n,typs,symbols,fmt) =
+  match fmt with
+    | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
+    | Some fmt -> 
+	[UnpBox (PpHOVB 0, 
+	 hunks_of_format (n,List.split typs) (symbols,parse_format fmt))]
+
+(**************************************************************************)
+(* Syntax extenstion: common parsing/printing rules and no interpretation *)
+
+(* v7 and translator : prec is for v7 (None if V8Notation), prec8 is for v8 *)
+(* v8 : prec is for v8, prec8 is the same *)
+
+let pr_arg_level from = function
+  | (n,L) when n=from -> str "at next level"
+  | (n,E) -> str "at level " ++ int n
+  | (n,L) -> str "at level below " ++ int n
+  | (n,Prec m) when m=n -> str "at level " ++ int n
+  | (n,_) -> str "Unknown level"
+
+let pr_level ntn (from,args) =
+  let lopen = ntn.[0] = '_' and ropen = ntn.[String.length ntn - 1] = '_' in
+(*
+  let ppassoc, args = match args with
+    | [] -> mt (), []
+    | (nl,lpr)::l when nl=from & fst (list_last l)=from ->
+	let (_,rpr),l = list_sep_last l in
+	match lpr, snd (list_last l) with
+	  | L,E -> Gramext.RightA, l
+	  | E,L -> Gramext.LeftA, l
+	  | L,L -> Gramext.NoneA, l
+	  | _ -> args
+*)
+  str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
+  prlist_with_sep pr_coma (pr_arg_level from) args
+
+let cache_syntax_extension (_,(_,(prec,prec8),ntn,gr,se)) =
+  try 
+    let oldprec, oldprec8 = Symbols.level_of_notation ntn in
+    if prec8 <> oldprec8 & (Options.do_translate () or not !Options.v7) then
+      errorlabstrm ""
+	(str ((if Options.do_translate () then "For new syntax, notation "
+	else "Notation ")
+	^ntn^" is already defined") ++ spc() ++ pr_level ntn oldprec8 ++ 
+	spc() ++ str "while it is now required to be" ++ spc() ++ 
+	pr_level ntn prec8)
+    else
+      (* Inconsistent v8 notations but not while translating; forget... *)
+      ();
+    (* V8 notations are consistent (from both translator or v8) *)
+    if prec <> None & !Options.v7 then begin
+      (* Update the V7 parsing rule *)
+      if oldprec <> None & out_some oldprec <> out_some prec then
+	(* None of them is V8Notation and they are different: warn *)
+	Options.if_verbose
+	  warning ("Notation "^ntn^
+	  " was already assigned a different level or sublevels");
+      if oldprec = None or out_some oldprec <> out_some prec then
+        Egrammar.extend_grammar (Egrammar.Notation (out_some gr))
+    end
+  with Not_found ->
+    (* Reserve the notation level *)
+    Symbols.declare_notation_level ntn (prec,prec8);
+    (* Declare the parsing rule *)
+    option_iter (fun gr -> Egrammar.extend_grammar (Egrammar.Notation gr)) gr;
+    (* Declare the printing rule *)
+    Symbols.declare_notation_printing_rule ntn (se,fst prec8)
+
+let subst_notation_grammar subst x = x
+
+let subst_printing_rule subst x = x
+
+let subst_syntax_extension (_,subst,(local,prec,ntn,gr,se)) =
+  (local,prec,ntn,
+   option_app (subst_notation_grammar subst) gr,
+   subst_printing_rule subst se)
+
+let classify_syntax_definition (_,(local,_,_,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_syntax_definition (local,_,_,_,_ as o) =
+  if local then None else Some o
+
+let (inSyntaxExtension, outSyntaxExtension) =
+  declare_object {(default_object "SYNTAX-EXTENSION") with
+       open_function = (fun i o -> if i=1 then cache_syntax_extension o);
+       cache_function = cache_syntax_extension;
+       subst_function = subst_syntax_extension;
+       classify_function = classify_syntax_definition;
+       export_function = export_syntax_definition}
+
+let interp_modifiers =
+  let onlyparsing = ref false in
+  let rec interp assoc level etyps format = function
+    | [] ->
+	(assoc,level,etyps,!onlyparsing,format)
+    | SetEntryType (s,typ) :: l ->
+	let id = id_of_string s in
+	if List.mem_assoc id etyps then
+	  error (s^" is already assigned to an entry or constr level")
+	else interp assoc level ((id,typ)::etyps) format l
+    | SetItemLevel ([],n) :: l ->
+	interp assoc level etyps format l
+    | SetItemLevel (s::idl,n) :: l ->
+	let id = id_of_string s in
+	if List.mem_assoc id etyps then
+	  error (s^" is already assigned to an entry or constr level")
+	else
+	  let typ = ETConstr (n,()) in
+	  interp assoc level ((id,typ)::etyps) format (SetItemLevel (idl,n)::l)
+    | SetLevel n :: l ->
+	if level <> None then error "A level is given more than once"
+	else interp assoc (Some n) etyps format l
+    | SetAssoc a :: l ->
+	if assoc <> None then error "An associativity is given more than once"
+	else interp (Some a) level etyps format l
+    | SetOnlyParsing :: l ->
+	onlyparsing := true;
+	interp assoc level etyps format l
+    | SetFormat s :: l ->
+	if format <> None then error "A format is given more than once"
+	onlyparsing := true;
+	interp assoc level etyps (Some s) l
+  in interp None None [] None
+
+let merge_modifiers a n l =
+  (match a with None -> [] | Some a -> [SetAssoc a]) @
+  (match n with None -> [] | Some n -> [SetLevel n]) @ l
+
+let interp_infix_modifiers modl =
+  let (assoc,level,t,b,fmt) = interp_modifiers modl in
+  if t <> [] then
+    error "explicit entry level or type unexpected in infix notation";
+  (assoc,level,b,fmt)
+
+(* 2nd list of types has priority *)
+let rec merge_entry_types etyps' = function
+  | [] -> etyps'
+  | (x,_ as e)::etyps ->
+      e :: merge_entry_types (List.remove_assoc x etyps') etyps
+
+let set_entry_type etyps (x,typ) =
+  let typ = try 
+    match List.assoc x etyps, typ with
+      | ETConstr (n,()), (_,BorderProd (left,_)) ->
+          ETConstr (n,BorderProd (left,None))
+      | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd)
+      | (ETPattern | ETIdent | ETBigint | ETOther _ | ETReference as t), _ -> t
+      | (ETConstrList _, _) -> assert false
+    with Not_found -> ETConstr typ
+  in (x,typ)
+
+let check_rule_reversibility l = 
+  if List.for_all (function NonTerminal _ -> true | _ -> false) l then
+    error "A notation must include at least one symbol"
+
+let find_precedence_v7 lev etyps symbols =
+  (match symbols with
+    | NonTerminal x :: _ ->
+	(try match List.assoc x etyps with
+	  | ETConstr _ ->
+	      error "The level of the leftmost non-terminal cannot be changed"
+	  | _ -> ()
+	with Not_found -> ())
+    | _ -> ());
+  if lev = None then 1 else out_some lev
+
+let find_precedence lev etyps symbols =
+  match symbols with
+  | NonTerminal x :: _ ->
+      (try match List.assoc x etyps with
+	| ETConstr _ ->
+	    error "The level of the leftmost non-terminal cannot be changed"
+	| ETIdent | ETBigint | ETReference -> 
+	    if lev = None then 
+	      Options.if_verbose msgnl (str "Setting notation at level 0")
+	    else
+	    if lev <> Some 0 then
+	      error "A notation starting with an atomic expression must be at level 0";
+	    0
+	| ETPattern | ETOther _ -> (* Give a default ? *)
+	    if lev = None then
+	      error "Need an explicit level"
+	    else out_some lev
+        | ETConstrList _ -> assert false (* internally used in grammar only *)
+      with Not_found -> 
+	if lev = None then
+	  error "A left-recursive notation must have an explicit level"
+	else out_some lev)
+  | Terminal _ ::l when
+      (match list_last symbols with Terminal _ -> true |_ -> false)
+      -> 
+      if lev = None then
+	(Options.if_verbose msgnl (str "Setting notation at level 0"); 0)
+      else out_some lev
+  | _ ->
+      if lev = None then error "Cannot determine the level";
+      out_some lev
+
+let check_curly_brackets_notation_exists () =
+  try let _ = Symbols.level_of_notation "{ _ }" in ()
+  with Not_found -> 
+    error "Notations involving patterns of the form \"{ _ }\" are treated \n\
+specially and require that the notation \"{ _ }\" is already reserved"
+
+(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
+let remove_curly_brackets l = 
+  let rec next = function
+    | Break _ :: l -> next l
+    | l -> l in
+  let rec aux deb = function
+  | [] -> []
+  | Terminal "{" as t1 :: l -> 
+      (match next l with
+        | NonTerminal _ as x :: l' as l0 ->
+            (match next l' with
+              | Terminal "}" as t2 :: l'' as l1 ->
+                  if l <> l0 or l' <> l1 then
+                    warning "Skipping spaces inside curly brackets";
+                  if deb & l'' = [] then [t1;x;t2] else begin
+                    check_curly_brackets_notation_exists ();
+                    x :: aux false l''
+                  end
+              | l1 -> t1 :: x :: aux false l1)
+        | l0 -> t1 :: aux false l0)
+  | x :: l -> x :: aux false l
+  in aux true l
+
+let compute_syntax_data forv7 (df,modifiers) =
+  let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in
+  (* Notation defaults to NONA *)
+  let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
+  let toks = split_notation_string df in
+  let (recvars,vars,symbols) = analyse_notation_tokens toks in
+  let ntn_for_interp = make_notation_key symbols in
+  let symbols = remove_curly_brackets symbols in
+  let notation = make_notation_key symbols in
+  check_rule_reversibility symbols;
+  let n =
+    if !Options.v7 then find_precedence_v7 n etyps symbols
+    else find_precedence n etyps symbols in
+  let innerlevel = NumLevel (if forv7 then 10 else 200) in
+  let typs =
+    find_symbols
+      (NumLevel n,BorderProd(true,assoc))
+      (innerlevel,InternalProd)
+      (NumLevel n,BorderProd(false,assoc))
+      symbols in
+  (* To globalize... *)
+  let typs = List.map (set_entry_type etyps) typs in
+  let ppdata = (n,typs,symbols,fmt) in
+  let prec = (n,List.map (assoc_of_type n) typs) in
+  ((onlyparse,recvars,vars,
+    ntn_for_interp,notation),prec,ppdata,(Lib.library_dp(),df))
+
+let add_syntax_extension local mv mv8 =
+  let data8 = option_app (compute_syntax_data false) mv8 in
+  let data = option_app (compute_syntax_data !Options.v7) mv in
+  let prec,gram_rule = match data with
+  | None -> None, None
+  | Some ((_,_,_,_,notation),prec,(n,typs,symbols,_),_) -> 
+      Some prec, Some (make_grammar_rule n typs symbols notation None) in
+  match data, data8 with
+  | None, None -> (* Nothing to do: V8Notation while not translating *) () 
+  | _, Some d | Some d, None ->
+    let ((_,_,_,_,ntn),ppprec,ppdata,_) = d in
+    let ntn' = match data with Some ((_,_,_,_,ntn),_,_,_) -> ntn | _ -> ntn in
+    let pp_rule = make_pp_rule ppdata in
+    Lib.add_anonymous_leaf
+      (inSyntaxExtension (local,(prec,ppprec),ntn',gram_rule,pp_rule))
+	
+(**********************************************************************)
+(* Distfix, Infix, Symbols *)
+
+(* A notation comes with a grammar rule, a pretty-printing rule, an
+   identifiying pattern called notation and an associated scope *)
+let load_notation _ (_,(_,_,ntn,scope,pat,onlyparse,_,_)) =
+  option_iter Symbols.declare_scope scope
+
+let open_notation i (_,(_,oldse,ntn,scope,pat,onlyparse,pp8only,df)) =
+  if i=1 then begin
+    let b,oldpp8only = Symbols.exists_notation_in_scope scope ntn pat in
+    (* Declare the old printer rule and its interpretation *)
+    if (not b or oldpp8only) & oldse <> None then
+      Esyntax.add_ppobject {sc_univ="constr";sc_entries=out_some oldse};
+    (* Declare the interpretation *)
+    if not b then
+      Symbols.declare_notation_interpretation ntn scope pat df pp8only;
+    if oldpp8only & not pp8only then
+      Options.silently 
+	(Symbols.declare_notation_interpretation ntn scope pat df) pp8only;
+    if not b & not onlyparse then
+      Symbols.declare_uninterpretation (NotationRule (scope,ntn)) pat
+  end
+
+let cache_notation o =
+  load_notation 1 o;
+  open_notation 1 o
+
+let subst_notation (_,subst,(lc,oldse,ntn,scope,(metas,pat),b,b',df)) =
+  (lc,option_app
+    (list_smartmap (Extend.subst_syntax_entry Ast.subst_astpat subst)) oldse,
+   ntn,scope,
+   (metas,subst_aconstr subst pat), b, b', df)
+
+let classify_notation (_,(local,_,_,_,_,_,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_notation (local,_,_,_,_,_,_,_ as o) =
+  if local then None else Some o
+
+let (inNotation, outNotation) =
+  declare_object {(default_object "NOTATION") with
+       open_function = open_notation;
+       cache_function = cache_notation;
+       subst_function = subst_notation;
+       load_function = load_notation;
+       classify_function = classify_notation;
+       export_function = export_notation}
+
+(* For old ast printer *)
+let rec reify_meta_ast vars = function
+  | Smetalam (loc,s,body) -> Smetalam (loc,s,reify_meta_ast vars body)
+(*  | Node(loc,"META",[Num (_,n)]) -> Nmeta (loc,create_meta n)*)
+  | Node(loc,"ISEVAR",[]) -> Nmeta (loc,"$_")
+  | Node(loc,op,args) -> Node (loc,op, List.map (reify_meta_ast vars) args)
+  | Slam(loc,Some id,body) when List.mem id vars ->
+      Smetalam (loc,string_of_id id,reify_meta_ast vars body)
+  | Slam(loc,na,body) -> Slam(loc,na,reify_meta_ast vars body)
+  | Nvar (loc,id) when List.mem id vars -> Nmeta (loc,string_of_id id)
+  | Nmeta _ | Id _ | Nvar _ | Str _ | Num _ | Path _ as a -> a
+  | Dynamic _ as a -> (* Hum... what to do here *) a
+
+(* For old ast syntax *)
+let make_old_pp_rule n symbols typs r ntn scope vars =
+  let ast = Termast.ast_of_rawconstr r in
+  let ast = reify_meta_ast vars ast in
+  let scope_name = match scope with Some s -> s | None -> "core_scope" in
+  let rule_name = ntn^"_"^scope_name^"_notation" in
+  make_syntax_rule n rule_name symbols typs ast ntn scope
+
+(* maps positions in v8-notation into positions in v7-notation (used
+   for parsing).
+   For instance  Notation "x < y < z" := .. V8only "y < z < x"
+   yields [1; 2; 0] (y is the second arg in v7; z is 3rd; x is fst) *)
+let mk_permut vars7 vars8 =
+  if vars7=vars8 then None else
+    Some
+      (List.fold_right
+        (fun v8 subs -> list_index v8 vars7 - 1 :: subs)
+        vars8 [])
+
+let contract_notation ntn =
+  if ntn = "{ _ }" then ntn else
+  let rec aux ntn i =
+    if i <= String.length ntn - 5 then
+      let ntn' =
+        if String.sub ntn i 5 = "{ _ }" then
+          String.sub ntn 0 i ^ "_" ^ 
+          String.sub ntn (i+5) (String.length ntn -i-5)
+        else ntn in
+      aux ntn' (i+1) 
+    else ntn in
+  aux ntn 0
+
+let add_notation_in_scope local df c mods omodv8 scope toks =
+  let ((onlyparse,recs,vars,intnot,notation),prec,(n,typs,symbols,_ as ppdata),df')=
+    compute_syntax_data !Options.v7 (df,mods) in
+  (* Declare the parsing and printing rules if not already done *)
+    (* For both v7 and translate: parsing is as described for v7 in v7 file *)
+    (* For v8: parsing is as described in v8 file *)
+    (* For v7: printing is by the old printer - see below *)
+    (* For translate: printing is as described for v8 in v7 file *)
+    (* For v8: printing is as described in v8 file *)
+    (* In short: parsing does not depend on omodv8 *)
+    (* Printing depends on mv8 if defined, otherwise of mods (scaled by 10) *)
+    (* if in v7, or of mods without scaling if in v8 *)
+  let intnot,ntn,pprecvars,ppvars,ppprec,pp_rule =
+    match omodv8 with
+    | Some mv8 ->
+        let (_,recs8,vars8,intnot8,ntn8),p,d,_ = compute_syntax_data false mv8 in
+        intnot8,ntn8,recs8,vars8,p,make_pp_rule d
+    | None when not !Options.v7 -> 
+        intnot,notation,recs,vars,prec,make_pp_rule ppdata
+    | None ->
+	(* means the rule already exists: recover it *)
+        (* occurs only with V8only flag alone *)
+	try 
+          let ntn = contract_notation notation in
+	  let _, oldprec8 = Symbols.level_of_notation ntn in
+	  let rule,_ = Symbols.find_notation_printing_rule ntn in
+	  notation,ntn,recs,vars,oldprec8,rule
+	with Not_found -> error "No known parsing rule for this notation in V8"
+  in
+  let permut = mk_permut vars ppvars in
+  let gram_rule = make_grammar_rule n typs symbols ntn permut in
+  Lib.add_anonymous_leaf
+    (inSyntaxExtension
+      (local,(Some prec,ppprec),ntn,Some gram_rule,pp_rule));
+
+  (* Declare interpretation *)
+  let (acvars,ac) = interp_aconstr [] ppvars c in
+  let a = (remove_vars pprecvars acvars,ac) (* For recursive parts *) in
+  let old_pp_rule =
+    (* Used only by v7; disable if contains a recursive pattern *)
+    if onlyparse or pprecvars <> [] then None
+    else
+      let r = interp_global_rawconstr_with_vars vars c in
+      Some (make_old_pp_rule n symbols typs r intnot scope vars) in
+  let onlyparse = onlyparse or !Options.v7_only in
+  Lib.add_anonymous_leaf
+    (inNotation(local,old_pp_rule,intnot,scope,a,onlyparse,false,df'))
+
+let level_rule (n,p) = if p = E then n else max (n-1) 0
+
+let check_notation_existence notation =
+  try
+    let a,_ = Symbols.level_of_notation (contract_notation notation) in
+    if a = None then raise Not_found
+  with Not_found ->
+    error "Parsing rule for this notation has to be previously declared"
+
+let exists_notation_syntax ntn =
+  try fst (Symbols.level_of_notation (contract_notation ntn)) <> None
+  with Not_found -> false
+
+let set_data_for_v7_pp recs a vars =
+  if not !Options.v7 then None else
+    if recs=[] then Some (a,vars)
+    else (warning "No recursive notation in v7 syntax";None)
+
+let build_old_pp_rule notation scope symbs (r,vars) =
+  let prec = 
+    try
+      let a,_ = Symbols.level_of_notation (contract_notation notation) in
+      if a = None then raise Not_found else out_some a
+    with Not_found ->
+      error "Parsing rule for this notation has to be previously declared" in
+  let typs = List.map2 
+    (fun id n -> 
+      id,ETConstr (NumLevel (level_rule n),InternalProd)) vars (snd prec) in
+  make_old_pp_rule (fst prec) symbs typs r notation scope vars
+
+let add_notation_interpretation_core local symbs for_old df a scope onlyparse 
+  onlypp =
+  let notation = make_notation_key symbs in
+  let old_pp_rule = 
+    if !Options.v7 then 
+      option_app (build_old_pp_rule notation scope symbs) for_old
+    else None in
+  Lib.add_anonymous_leaf
+    (inNotation(local,old_pp_rule,notation,scope,a,onlyparse,onlypp,
+     (Lib.library_dp(),df)))
+
+let add_notation_interpretation df names c sc =
+  let (recs,vars,symbs) = analyse_notation_tokens (split_notation_string df) in
+  check_notation_existence (make_notation_key symbs);
+  let (acvars,ac) = interp_aconstr names vars c in
+  let a = (remove_vars recs acvars,ac) (* For recursive parts *) in
+  let a_for_old = interp_rawconstr_with_implicits Evd.empty (Global.env()) vars names c in
+  let for_oldpp = set_data_for_v7_pp recs a_for_old vars in
+  add_notation_interpretation_core false symbs for_oldpp df a sc false false
+
+let add_notation_in_scope_v8only local df c mv8 scope toks =
+  let (_,recs,vars,intnot,notation),prec,ppdata,df' = compute_syntax_data false (df,mv8) in
+  let pp_rule = make_pp_rule ppdata in
+  Lib.add_anonymous_leaf
+    (inSyntaxExtension(local,(None,prec),notation,None,pp_rule));
+  (* Declare the interpretation *)
+  let onlyparse = false in
+  let (acvars,ac) = interp_aconstr [] vars c in
+  let a = (remove_vars recs acvars,ac) (* For recursive parts *) in
+  Lib.add_anonymous_leaf
+    (inNotation(local,None,intnot,scope,a,onlyparse,true,df'))
+
+let add_notation_v8only local c (df,modifiers) sc =
+  let toks = split_notation_string df in
+  match toks with 
+    | [String x] when (modifiers = [] or modifiers = [SetOnlyParsing]) ->
+	(* This is a ident to be declared as a rule *)
+        add_notation_in_scope_v8only local df c (SetLevel 0::modifiers) sc toks
+    | _ ->
+	let (assoc,lev,typs,onlyparse,fmt) = interp_modifiers modifiers	in
+	match lev with
+	  | None->
+	      if modifiers <> [] & modifiers <> [SetOnlyParsing] then
+		error "Parsing rule for this notation includes no level"
+	      else
+	        (* Declare only interpretation *)
+		let (recs,vars,symbs) = analyse_notation_tokens toks in
+		let onlyparse = modifiers = [SetOnlyParsing] in
+                let (acvars,ac) = interp_aconstr [] vars c in
+                let a = (remove_vars recs acvars,ac) in
+		add_notation_interpretation_core local symbs None df a sc 
+		  onlyparse true
+	  | Some n ->
+	    (* Declare both syntax and interpretation *)
+	      let mods =
+		if List.for_all (function SetAssoc _ -> false | _ -> true)
+		  modifiers 
+		then SetAssoc Gramext.NonA :: modifiers else modifiers in
+	      add_notation_in_scope_v8only local df c mods sc toks
+
+let is_quoted_ident x =
+  let x' = unquote_notation_token x in
+  x <> x' & try Lexer.check_ident x'; true with _ -> false
+
+let add_notation local c dfmod mv8 sc =
+  match dfmod with
+  | None -> add_notation_v8only local c (out_some mv8) sc
+  | Some (df,modifiers) ->
+  let toks = split_notation_string df in
+  match toks with 
+    | [String x] when (modifiers = [] or modifiers = [SetOnlyParsing]) ->
+	(* This is a ident to be declared as a rule *)
+        add_notation_in_scope local df c (SetLevel 0::modifiers) mv8 sc toks
+    | _ ->
+	let (assoc,lev,typs,onlyparse,fmt) = interp_modifiers modifiers	in
+	match lev with
+	  | None->
+	      if modifiers <> [] & modifiers <> [SetOnlyParsing] then
+		error "Parsing rule for this notation includes no level"
+	      else
+	        (* Declare only interpretation *)
+		let (recs,vars,symbs) = analyse_notation_tokens toks in
+                if exists_notation_syntax (make_notation_key symbs) then
+		  let onlyparse = modifiers = [SetOnlyParsing] in
+                  let (acvars,ac) = interp_aconstr [] vars c in
+                  let a = (remove_vars recs acvars,ac) in
+		  let a_for_old = interp_global_rawconstr_with_vars vars c in
+                  let for_old = set_data_for_v7_pp recs a_for_old vars in
+		  add_notation_interpretation_core local symbs for_old df a
+		    sc onlyparse false
+                else
+                  add_notation_in_scope local df c modifiers mv8 sc toks
+	  | Some n ->
+	    (* Declare both syntax and interpretation *)
+	    let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
+            add_notation_in_scope local df c modifiers mv8 sc toks
+
+(* TODO add boxes information in the expression *)
+
+let inject_var x = CRef (Ident (dummy_loc, id_of_string x))
+
+let rec rename x vars n = function
+  | [] ->
+      (vars,[])
+  | String "_"::l ->
+      let (vars,l) = rename x vars (n+1) l in
+      let xn = x^(string_of_int n) in
+      ((inject_var xn)::vars,xn::l)
+  | String y::l ->
+      let (vars,l) = rename x vars n l in (vars,(quote_notation_token y)::l)
+  | WhiteSpace _::l ->
+      rename x vars n l
+
+let translate_distfix assoc df r = 
+  let (vars,l) = rename "x" [] 1 (split_notation_string df) in
+  let df = String.concat " " l in
+  let a = mkAppC (mkRefC r, vars) in
+  let assoc = match assoc with None -> Gramext.LeftA | Some a -> a in
+  (assoc,df,a)
+
+let add_distfix local assoc n df r sc =
+  (* "x" cannot clash since r is globalized (included section vars) *)
+  let (vars,l) = rename "x" [] 1 (split_notation_string df) in
+  let df = String.concat " " l in
+  let a = mkAppC (mkRefC r, vars) in
+  let assoc = match assoc with None -> Gramext.LeftA | Some a -> a in
+  add_notation_in_scope local df a [SetAssoc assoc;SetLevel n] None sc
+    (split_notation_string df)
+
+let make_infix_data n assoc modl mv8 =
+  (* Infix defaults to LEFTA in V7 (cf doc) *)
+  let mv = match n with None when !Options.v7 -> SetLevel 1 :: modl | _ -> modl in
+  let mv = match assoc with None when !Options.v7 -> SetAssoc Gramext.LeftA :: mv | _ -> mv in
+  let mv8 = match mv8 with
+      None -> None
+    | Some(s8,mv8) ->
+	if List.for_all (function SetLevel _ -> false | _ -> true) mv8 then
+	  error "Needs a level"
+	else Some (("x "^quote_notation_token s8^" y"),mv8) in
+  mv,mv8
+
+let add_infix local (inf,modl) pr mv8 sc =
+  if inf="" (* Code for V8Infix only *) then
+    let (p8,mv8) = out_some mv8 in
+    let (a8,n8,onlyparse,fmt) = interp_infix_modifiers mv8 in
+    let metas = [inject_var "x"; inject_var "y"] in
+    let a = mkAppC (mkRefC pr,metas) in
+    let df = "x "^(quote_notation_token p8)^" y" in
+    let toks = split_notation_string df in
+    if a8=None & n8=None & fmt=None then
+      (* Declare only interpretation *)
+      let (recs,vars,symbs) = analyse_notation_tokens toks in
+      let (acvars,ac) = interp_aconstr [] vars a in
+      let a' = (remove_vars recs acvars,ac) in
+      let a_for_old = interp_global_rawconstr_with_vars vars a in
+      add_notation_interpretation_core local symbs None df a' sc 
+	onlyparse true
+    else
+      if n8 = None then error "Needs a level" else
+      let mv8 = match a8 with None -> SetAssoc Gramext.NonA :: mv8 |_ -> mv8 in
+      add_notation_in_scope_v8only local df a mv8 sc toks
+  else begin
+  let (assoc,n,onlyparse,fmt) = interp_infix_modifiers modl in
+  (* check the precedence *)
+  if !Options.v7 & (n<> None & (out_some n < 1 or out_some n > 10)) then
+    errorlabstrm "Metasyntax.infix_grammar_entry"
+      (str"Precedence must be between 1 and 10.");
+  (*
+  if (assoc<>None) & (n<6 or n>9) then
+    errorlabstrm "Vernacentries.infix_grammar_entry"
+      (str"Associativity Precedence must be 6,7,8 or 9.");
+  *)
+  let metas = [inject_var "x"; inject_var "y"] in
+  let a = mkAppC (mkRefC pr,metas) in
+  let df = "x "^(quote_notation_token inf)^" y" in
+  let toks = split_notation_string df in
+  if not !Options.v7 & n=None & assoc=None then
+    (* En v8, une notation sans information de parsing signifie *)
+    (* de ne déclarer que l'interprétation *)
+    (* Declare only interpretation *)
+    let (recs,vars,symbs) = analyse_notation_tokens toks in
+    if exists_notation_syntax (make_notation_key symbs) then
+      let (acvars,ac) = interp_aconstr [] vars a in
+      let a' = (remove_vars recs acvars,ac) in
+      let a_for_old = interp_global_rawconstr_with_vars vars a in
+      let for_old = set_data_for_v7_pp recs a_for_old vars in
+      add_notation_interpretation_core local symbs for_old df a' sc 
+        onlyparse false
+    else
+      let mv,mv8 = make_infix_data n assoc modl mv8 in
+      add_notation_in_scope local df a mv mv8 sc toks
+  else
+    let mv,mv8 = make_infix_data n assoc modl mv8 in
+    add_notation_in_scope local df a mv mv8 sc toks
+  end
+
+let standardise_locatable_notation ntn =
+  let unquote = function
+    | String s -> [unquote_notation_token s]
+    | _ -> [] in
+  if String.contains ntn ' ' then
+    String.concat " " 
+      (List.flatten (List.map unquote (split_notation_string ntn)))
+  else
+    unquote_notation_token ntn
+
+(* Delimiters and classes bound to scopes *)
+type scope_command = ScopeDelim of string | ScopeClasses of Classops.cl_typ
+
+let load_scope_command _ (_,(scope,dlm)) =
+  Symbols.declare_scope scope
+
+let open_scope_command i (_,(scope,o)) =
+  if i=1 then
+    match o with
+    | ScopeDelim dlm -> Symbols.declare_delimiters scope dlm
+    | ScopeClasses cl -> Symbols.declare_class_scope scope cl
+
+let cache_scope_command o =
+  load_scope_command 1 o;
+  open_scope_command 1 o
+
+let subst_scope_command (_,subst,(scope,o as x)) = match o with
+  | ScopeClasses cl -> 
+      let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else
+      scope, ScopeClasses cl'
+  | _ -> x
+
+let (inScopeCommand,outScopeCommand) = 
+  declare_object {(default_object "DELIMITERS") with
+      cache_function = cache_scope_command;
+      open_function = open_scope_command;
+      load_function = load_scope_command;
+      subst_function = subst_scope_command;
+      classify_function = (fun (_,obj) -> Substitute obj);
+      export_function = (fun x -> Some x) }
+
+let add_delimiters scope key =
+  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key))
+
+let add_class_scope scope cl = 
+  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl))
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
new file mode 100644
index 00000000..be90cd7a
--- /dev/null
+++ b/toplevel/metasyntax.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: metasyntax.mli,v 1.26.2.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Libnames
+open Ppextend
+open Extend
+open Tacexpr
+open Vernacexpr
+open Symbols
+open Topconstr
+(*i*)
+
+(* Adding grammar and pretty-printing objects in the environment *)
+
+val add_syntax_obj : string -> raw_syntax_entry list -> unit
+
+val add_grammar_obj : string -> raw_grammar_entry list -> unit
+val add_token_obj : string -> unit
+val add_tactic_grammar :
+  (string * (string * grammar_production list) * raw_tactic_expr) list -> unit
+
+val add_infix : locality_flag -> (string * syntax_modifier list) ->
+  reference -> (string * syntax_modifier list) option ->
+    scope_name option -> unit
+val add_distfix : locality_flag ->
+  grammar_associativity -> precedence -> string -> reference
+    -> scope_name option -> unit
+val translate_distfix : grammar_associativity -> string -> reference ->
+  Gramext.g_assoc * string * constr_expr
+
+val add_delimiters : scope_name -> string -> unit
+val add_class_scope : scope_name -> Classops.cl_typ -> unit
+
+val add_notation : locality_flag -> constr_expr
+  -> (string * syntax_modifier list) option
+  -> (string * syntax_modifier list) option
+      -> scope_name option -> unit
+
+val add_notation_interpretation : string -> Constrintern.implicits_env
+  -> constr_expr -> scope_name option -> unit
+
+val add_syntax_extension : locality_flag
+  -> (string * syntax_modifier list) option
+  -> (string * syntax_modifier list) option -> unit
+
+val print_grammar : string -> string -> unit
+
+val merge_modifiers : Gramext.g_assoc option -> int option -> 
+  syntax_modifier list -> syntax_modifier list
+
+val interp_infix_modifiers : syntax_modifier list ->
+  Gramext.g_assoc option * precedence option * bool * string located option
+
+val standardise_locatable_notation : string -> string
diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml
new file mode 100644
index 00000000..dcf3e307
--- /dev/null
+++ b/toplevel/minicoq.ml
@@ -0,0 +1,149 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: minicoq.ml,v 1.28.14.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Declarations
+open Inductive
+open Type_errors
+open Safe_typing
+open G_minicoq
+
+let (env : safe_environment ref) = ref empty_environment
+
+let locals () =
+  List.map (fun (id,b,t) -> (id, make_path [] id CCI))
+    (named_context !env)
+
+let lookup_named id =
+  let rec look n = function
+    | [] -> mkVar id
+    | (Name id')::_ when id = id' -> mkRel n
+    | _::r -> look (succ n) r
+  in
+  look 1
+
+let args sign = Array.of_list (instance_from_section_context sign)
+
+let rec globalize bv c = match kind_of_term c with
+  | Var id -> lookup_named id bv
+  | Const (sp, _) ->
+      let cb = lookup_constant sp !env in mkConst (sp, args cb.const_hyps)
+  | Ind (sp,_ as spi, _) ->
+      let mib = lookup_mind sp !env in mkMutInd (spi, args mib.mind_hyps)
+  | Construct ((sp,_),_ as spc, _) ->
+      let mib = lookup_mind sp !env in mkMutConstruct (spc, args mib.mind_hyps)
+  | _ -> map_constr_with_named_binders (fun na l -> na::l) globalize bv c
+
+let check c = 
+  let c = globalize [] c in
+  let (j,u) = safe_infer !env c in
+  let ty = j_type j in
+  let pty = pr_term CCI (env_of_safe_env !env) ty in
+  mSGNL (hov 0 (str"  :" ++ spc () ++ hov 0 pty ++ fnl ()))
+
+let definition id ty c =
+  let c = globalize [] c in
+  let ty = option_app (globalize []) ty in
+  let ce = { const_entry_body = c; const_entry_type = ty } in
+  let sp = make_path [] id CCI in
+  env := add_constant sp ce (locals()) !env;
+  mSGNL (hov 0 (pr_id id ++ spc () ++ str"is defined" ++ fnl ()))
+
+let parameter id t =
+  let t = globalize [] t in
+  let sp = make_path [] id CCI in
+  env := add_parameter sp t (locals()) !env;
+  mSGNL (hov 0 (str"parameter" ++ spc () ++ pr_id id ++ 
+		  spc () ++ str"is declared" ++ fnl ()))
+
+let variable id t =
+  let t = globalize [] t in
+  env := push_named_assum (id,t) !env;
+  mSGNL (hov 0 (str"variable" ++ spc () ++ pr_id id ++ 
+		  spc () ++ str"is declared" ++ fnl ()))
+
+let inductive par inds =
+  let nparams = List.length par in
+  let bvpar = List.rev (List.map (fun (id,_) -> Name id) par) in
+  let name_inds = List.map (fun (id,_,_) -> Name id) inds in
+  let bv = bvpar @  List.rev name_inds in
+  let npar = List.map (fun (id,c) -> (Name id, globalize [] c)) par in
+  let one_inductive (id,ar,cl) =
+    let cv = List.map (fun (_,c) -> prod_it (globalize bv c) npar) cl in
+    { mind_entry_nparams = nparams;
+      mind_entry_params = List.map (fun (id,c) -> (id, LocalAssum c)) par;
+      mind_entry_typename = id;
+      mind_entry_arity = prod_it (globalize bvpar ar) npar;
+      mind_entry_consnames = List.map fst cl;
+      mind_entry_lc = cv }
+  in
+  let inds = List.map one_inductive inds in
+  let mie = { 
+    mind_entry_finite = true;
+    mind_entry_inds = inds }
+  in
+  let sp =
+    let mi1 = List.hd inds in
+    make_path [] mi1.mind_entry_typename CCI in
+  env := add_mind sp mie (locals()) !env;
+  mSGNL (hov 0 (str"inductive type(s) are declared" ++ fnl ()))
+
+
+let execute = function
+  | Check c -> check c
+  | Definition (id, ty, c) -> definition id ty c
+  | Parameter (id, t) -> parameter id t
+  | Variable (id, t) -> variable id t
+  | Inductive (par,inds) -> inductive par inds
+
+let parse_file f =
+  let c = open_in f in
+  let cs = Stream.of_channel c in
+  try
+    while true do
+      let c = Grammar.Entry.parse command cs in execute c
+    done
+  with 
+    | End_of_file | Stdpp.Exc_located (_, End_of_file) -> close_in c; exit 0
+    | exn -> close_in c; raise exn
+
+module Explain = Fhimsg.Make(struct let pr_term = pr_term end)
+
+let rec explain_exn = function
+  | TypeError (k,ctx,te) -> 
+      mSGNL (hov 0 (str "type error:" ++ spc () ++ 
+		      Explain.explain_type_error k ctx te ++ fnl ()))
+  | Stdpp.Exc_located (_,exn) -> 
+      explain_exn exn
+  | exn -> 
+      mSGNL (hov 0 (str"error: " ++ str (Printexc.to_string exn) ++ fnl ()))
+
+let top () =
+  let cs = Stream.of_channel stdin in
+  while true do
+    try
+      let c = Grammar.Entry.parse command cs in execute c
+    with 
+      | End_of_file | Stdpp.Exc_located (_, End_of_file) -> exit 0
+      | exn -> explain_exn exn
+  done
+
+let main () =
+  if Array.length Sys.argv = 1 then
+    parse_file "test"
+  else
+    if Sys.argv.(1) = "-top" then top () else parse_file (Sys.argv.(1))
+
+let _ = Printexc.print main ()
+
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
new file mode 100644
index 00000000..4da23d42
--- /dev/null
+++ b/toplevel/mltop.ml4
@@ -0,0 +1,296 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: mltop.ml4,v 1.29.2.3 2004/07/17 13:00:15 herbelin Exp $ *)
+
+open Util
+open Pp
+open Options
+open System
+open Libobject
+open Library
+open System
+open Vernacinterp
+
+(* Code to hook Coq into the ML toplevel -- depends on having the
+   objective-caml compiler mostly visible. The functions implemented here are:
+   \begin{itemize}
+   \item [dir_ml_load name]: Loads the ML module fname from the current ML 
+     path. 
+   \item [dir_ml_use]: Directive #use of Ocaml toplevel
+   \item [add_ml_dir]: Directive #directory of Ocaml toplevel
+   \end{itemize}
+ 
+   How to build an ML module interface with these functions.
+   The idea is that the ML directory path is like the Coq directory
+   path.  So we can maintain the two in parallel.
+   In the same way, we can use the "ml_env" as a kind of ML
+   environment, which we freeze, unfreeze, and add things to just like
+   to the other environments.
+   Finally, we can create an object which is an ML module, and require
+   that the "caching" of the ML module cause the loading of the
+   associated ML file, if that file has not been yet loaded.  Of
+   course, the problem is how to record dependencies between ML
+   modules.
+   (I do not know of a solution to this problem, other than to
+   put all the needed names into the ML Module object.) *)
+
+(* This path is where we look for .cmo *)
+let coq_mlpath_copy = ref ["."]
+let keep_copy_mlpath s = 
+  let dir = glob s in
+  coq_mlpath_copy := dir :: !coq_mlpath_copy
+
+(* If there is a toplevel under Coq *)
+type toplevel = { 
+  load_obj : string -> unit;
+  use_file : string -> unit;
+  add_dir  : string -> unit;
+  ml_loop  : unit -> unit }
+
+(* Determines the behaviour of Coq with respect to ML files (compiled 
+   or not) *)
+type kind_load =
+  | WithTop of toplevel
+  | WithoutTop
+  | Native
+
+(* Must be always initialized *)
+let load = ref Native
+
+(* Sets and initializes the kind of loading *)
+let set kload = load := kload
+let get () = !load
+
+(* Resets load *)
+let remove ()= load := Native
+
+(* Tests if an Ocaml toplevel runs under Coq *)
+let is_ocaml_top () =
+  match !load with
+    | WithTop _ -> true
+    |_ -> false
+
+(* Tests if we can load ML files *)
+let enable_load () =
+  match !load with
+    | WithTop _ | WithoutTop -> true
+    |_ -> false
+
+(* Runs the toplevel loop of Ocaml *)
+let ocaml_toploop () =
+  match !load with
+    | WithTop t -> Printexc.catch t.ml_loop ()
+    | _ -> ()
+
+(* Dynamic loading of .cmo/.cma *)
+let dir_ml_load s = 
+  match !load with
+    | WithTop t ->
+      (try t.load_obj s
+       with
+       | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u
+       | _ -> errorlabstrm "Mltop.load_object" [< str"Cannot link ml-object ";
+                str s; str" to Coq code." >])
+(* TO DO: .cma loading without toplevel *)
+    | WithoutTop ->
+      ifdef Byte then
+        let _,gname = where_in_path !coq_mlpath_copy s in
+        try
+          Dynlink.loadfile gname;
+	  Dynlink.add_interfaces 
+	    [(String.capitalize (Filename.chop_suffix
+				(Filename.basename gname) ".cmo"))] 
+	    [Filename.dirname gname]
+	with | Dynlink.Error a ->
+          errorlabstrm "Mltop.load_object" [< str (Dynlink.error_message a) >]
+      else () 
+    | Native ->
+	errorlabstrm "Mltop.no_load_object"
+          [< str"Loading of ML object file forbidden in a native Coq" >]
+
+(* Dynamic interpretation of .ml *)
+let dir_ml_use s =
+  match !load with
+    | WithTop t -> t.use_file s
+    | _ -> warning "Cannot access the ML compiler"
+
+(* Adds a path to the ML paths *)
+let add_ml_dir s =
+  match !load with
+    | WithTop t -> t.add_dir s; keep_copy_mlpath s
+    | WithoutTop -> keep_copy_mlpath s
+    | _ -> ()
+
+(* For Rec Add ML Path *)
+let add_rec_ml_dir dir = 
+  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir)
+
+(* Adding files to Coq and ML loadpath *)
+
+let add_path ~unix_path:dir ~coq_root:coq_dirpath =
+  if exists_dir dir then
+    begin
+      add_ml_dir dir;
+      Library.add_load_path_entry (dir,coq_dirpath)
+    end
+  else
+    msg_warning [< str ("Cannot open " ^ dir) >]
+
+let convert_string d =
+  try Names.id_of_string d
+  with _ -> 
+    if_verbose warning 
+      ("Directory "^d^" cannot be used as a Coq identifier (skipped)");
+    flush_all ();
+    failwith "caught"
+
+let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
+  let dirs = all_subdirs dir in
+  let prefix = Names.repr_dirpath coq_dirpath in
+  if dirs <> [] then
+    let convert_dirs (lp,cp) =
+      (lp,Names.make_dirpath
+            ((List.map convert_string (List.rev cp))@prefix)) in
+    let dirs = map_succeed convert_dirs dirs in
+    begin
+      List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs;
+      List.iter Library.add_load_path_entry dirs
+    end
+  else
+    msg_warning [< str ("Cannot open " ^ dir) >]
+
+(* convertit un nom quelconque en nom de fichier ou de module *) 
+let mod_of_name name =
+  let base =
+    if Filename.check_suffix name ".cmo" then
+      Filename.chop_suffix name ".cmo"
+    else 
+      name
+  in 
+  String.capitalize base
+
+let file_of_name name =
+  let bname = String.uncapitalize name in
+  let fname = make_suffix bname ".cmo" in
+  if (is_in_path !coq_mlpath_copy fname) then fname
+  else let fname=make_suffix bname ".cma" in
+  if (is_in_path !coq_mlpath_copy fname) then fname
+  else
+    errorlabstrm "Mltop.load_object"
+      [< str"File not found on loadpath : "; str (bname^".cm[oa]") >]
+
+(* TODO: supprimer ce hack, si possible *)
+(* Initialisation of ML modules that need the state (ex: tactics like
+ * natural, omega ...)
+ * Each module may add some inits (function of type unit -> unit).
+ * These inits are executed right after the initial state loading if the
+ * module is statically linked, or after the loading if it is required. *)
+
+let init_list = ref ([] : (unit -> unit) list)
+
+let add_init_with_state init_fun =
+  init_list := init_fun :: !init_list
+
+let init_with_state () =
+  List.iter (fun f -> f()) (List.rev !init_list); init_list := []
+
+
+(* [known_loaded_module] contains the names of the loaded ML modules
+ * (linked or loaded with load_object). It is used not to load a 
+ * module twice. It is NOT the list of ML modules Coq knows. *)
+
+type ml_module_object = { mnames : string list }
+
+let known_loaded_modules = ref Stringset.empty
+
+let add_known_module mname =
+  known_loaded_modules := Stringset.add mname !known_loaded_modules
+
+let module_is_known mname = Stringset.mem mname !known_loaded_modules
+
+let load_object mname fname=
+  dir_ml_load fname;
+  init_with_state();
+  add_known_module mname
+
+(* Summary of declared ML Modules *)
+
+(* List and not Stringset because order is important *)
+let loaded_modules = ref []
+let get_loaded_modules () = !loaded_modules
+let add_loaded_module md = loaded_modules := md :: !loaded_modules
+
+let orig_loaded_modules = ref !loaded_modules
+let init_ml_modules () = loaded_modules := !orig_loaded_modules
+
+let unfreeze_ml_modules x =
+  loaded_modules := [];
+  List.iter
+    (fun name ->
+       let mname = mod_of_name name in
+       if not (module_is_known mname) then
+         if enable_load() then
+           let fname = file_of_name mname in
+           load_object mname fname
+         else 
+	   errorlabstrm "Mltop.unfreeze_ml_modules"
+             [< str"Loading of ML object file forbidden in a native Coq" >];
+       add_loaded_module mname)
+    x
+
+let _ = 
+  Summary.declare_summary "ML-MODULES"
+    { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules()));
+      Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x);
+      Summary.init_function = (fun () -> init_ml_modules ());
+      Summary.survive_module = false;
+      Summary.survive_section = true }
+
+(* Same as restore_ml_modules, but verbosely *)
+
+let cache_ml_module_object (_,{mnames=mnames}) =
+  List.iter
+    (fun name ->
+       let mname = mod_of_name name in
+       if not (module_is_known mname) then
+         let fname = file_of_name mname in
+         begin 
+	   try 
+	     if_verbose 
+	       msg [< str"[Loading ML file "; str fname; str" ..." >];
+             load_object mname fname;
+             if_verbose msgnl [< str"done]" >]
+           with e -> 
+	     if_verbose msgnl [< str"failed]" >]; 
+	     raise e
+	 end;
+         add_loaded_module mname)
+    mnames
+
+let export_ml_module_object x = Some x
+					 
+let (inMLModule,outMLModule) =
+  declare_object {(default_object "ML-MODULE") with
+                    load_function = (fun _ -> cache_ml_module_object);
+                    cache_function = cache_ml_module_object;
+                    export_function = export_ml_module_object }
+
+let declare_ml_modules l =
+  Lib.add_anonymous_leaf (inMLModule {mnames=l})
+    
+let print_ml_path () =
+  let l = !coq_mlpath_copy in
+  ppnl [< str"ML Load Path:"; fnl (); str"  ";
+          hv 0 (prlist_with_sep pr_fnl pr_str l) >]
+
+	  (* Printing of loaded ML modules *)
+	  
+let print_ml_modules () =
+  let l = get_loaded_modules () in
+  pp [< str"Loaded ML Modules: " ; pr_vertical_list pr_str l >]
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
new file mode 100644
index 00000000..6ba8cd76
--- /dev/null
+++ b/toplevel/mltop.mli
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: mltop.mli,v 1.8.14.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(* If there is a toplevel under Coq, it is described by the following 
+   record. *)
+type toplevel = { 
+  load_obj : string -> unit;
+  use_file : string -> unit;
+  add_dir  : string -> unit;
+  ml_loop  : unit -> unit }
+
+(* Determines the behaviour of Coq with respect to ML files (compiled 
+   or not) *) 
+type kind_load=
+  | WithTop of toplevel
+  | WithoutTop
+  | Native
+
+(* Sets and initializes the kind of loading *)
+val set : kind_load -> unit
+val get : unit -> kind_load
+
+(* Resets the kind of loading *)
+val remove : unit -> unit
+
+(* Tests if an Ocaml toplevel runs under Coq *)
+val is_ocaml_top : unit -> bool
+
+(* Tests if we can load ML files *)
+val enable_load : unit -> bool
+
+(* Starts the Ocaml toplevel loop *)
+val ocaml_toploop : unit -> unit
+
+(* Dynamic loading of .cmo *)
+val dir_ml_load : string -> unit
+
+(* Dynamic interpretation of .ml *)
+val dir_ml_use : string -> unit
+
+(* Adds a path to the ML paths *)
+val add_ml_dir : string -> unit
+val add_rec_ml_dir : string -> unit
+
+(* Adds a path to the Coq and ML paths *)
+val add_path : unix_path:string -> coq_root:Names.dir_path -> unit
+val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit
+
+val add_init_with_state : (unit -> unit) -> unit
+val init_with_state : unit -> unit
+
+(* List of modules linked to the toplevel *)
+val add_known_module : string -> unit
+val module_is_known : string -> bool
+val load_object : string -> string -> unit
+
+(* Summary of Declared ML Modules *)
+val get_loaded_modules : unit -> string list
+val add_loaded_module : string -> unit
+val init_ml_modules : unit -> unit
+val unfreeze_ml_modules : string list -> unit
+
+type ml_module_object = { mnames: string list }
+val inMLModule : ml_module_object -> Libobject.obj
+val outMLModule : Libobject.obj -> ml_module_object
+
+val declare_ml_modules : string list -> unit
+val print_ml_path : unit -> unit
+
+val print_ml_modules : unit -> unit
diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml
new file mode 100644
index 00000000..c748a12d
--- /dev/null
+++ b/toplevel/protectedtoplevel.ml
@@ -0,0 +1,173 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: protectedtoplevel.ml,v 1.9.10.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Line_oriented_parser
+open Vernac
+
+(* The toplevel parsing loop we propose here is more robust to printing
+   errors.  The philosophy is that all commands should be individually wrapped
+   in predefined markers.  If there is a parsing error, everything down to
+   the closing marker will be discarded.  Also there is always an aknowledge
+   message associated to a wrapped command. *)
+
+
+(* It is also possible to have break signals sent by other programs.  However,
+   there are some operations that should not be interrupted, especially, those
+   operations that are outputing data.
+*)
+
+let break_happened = ref false
+
+(* Before outputing any data, output_results makes sure that no interrupt 
+   is going to disturb the process. *)
+let output_results_nl stream =
+    let _ = Sys.signal Sys.sigint
+       (Sys.Signal_handle(fun i -> break_happened := true;()))
+  in
+  msgnl stream
+
+let rearm_break () =
+  let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in 
+    ()
+
+let check_break () =
+  if !break_happened then begin
+    break_happened := false;
+    raise Sys.Break
+  end
+
+(* All commands are acknowledged. *)
+
+let global_request_id = ref 013
+
+let acknowledge_command_ref =
+   ref(fun request_id command_count opt_exn
+      -> (fnl () ++ str "acknowledge command number " ++
+           int request_id ++ fnl () ++ 
+         str "successfully executed " ++ int command_count ++ fnl () ++
+           str "error message" ++ fnl () ++
+         (match opt_exn with
+           Some e -> Cerrors.explain_exn e
+         | None -> (mt ())) ++ fnl () ++
+         str "E-n-d---M-e-s-s-a-g-e" ++ fnl ()))
+
+let set_acknowledge_command f =
+  acknowledge_command_ref := f
+
+let acknowledge_command request_id = !acknowledge_command_ref request_id
+
+(* The markers are chosen to be likely to be different from any existing text. *)
+
+let start_marker = ref "protected_loop_start_command"
+let end_marker = ref "protected_loop_end_command"
+let start_length = ref (String.length !start_marker)
+let start_marker_buffer = ref (String.make !start_length ' ')
+
+let set_start_marker s =
+  start_marker := s;
+  start_length := String.length s;
+  start_marker_buffer := String.make !start_length ' '
+    
+let set_end_marker s =
+  end_marker := s
+
+exception E_with_rank of int * exn
+
+let rec parse_one_command_group input_channel =
+  let count = ref 0 in
+  let this_line = input_line input_channel in
+  if (String.length this_line) >= !start_length then begin
+    String.blit this_line 0 !start_marker_buffer 0 !start_length;
+    if !start_marker_buffer = !start_marker then
+      let req_id_line = input_line input_channel in
+      	begin 
+	  (try
+            global_request_id := int_of_string req_id_line
+	  with
+            | e -> failwith ("could not parse the request identifier |"^
+                             req_id_line ^ "|")) ;
+	  let count_line = input_line input_channel in
+	    begin
+	      (try
+		count := int_of_string count_line
+	      with
+		| e -> failwith("could not parse the count|" ^ count_line
+				^ "|"));
+	      let stream_tail =
+	      	Stream.from
+		  (line_oriented_channel_to_option
+		     !end_marker input_channel) in
+	      	begin
+		  check_break();
+		  rearm_break();
+		  let rec execute_n_commands rank =
+		    if rank = !count then
+		      None
+		    else
+		      let first_cmd_status =
+                      	try 
+			  raw_do_vernac
+			    (Pcoq.Gram.parsable stream_tail);
+		      	None
+		      	with e -> Some(rank,e) in
+		      	match first_cmd_status with
+			    None ->
+			      execute_n_commands (rank + 1)
+			  | v -> v in
+		  let r = execute_n_commands 0 in
+		    (match r with
+			 None ->
+			   output_results_nl 
+			     (acknowledge_command
+			      	!global_request_id !count None)
+		       | Some(rank, e) ->
+			   (match e with 
+                    	      	DuringCommandInterp(a,e1) ->
+				  output_results_nl
+				    (acknowledge_command
+				       !global_request_id rank (Some e1))
+			      | e -> 
+				  output_results_nl
+				    (acknowledge_command
+				       !global_request_id rank (Some e))));
+		    rearm_break();
+		    flush_until_end_of_stream stream_tail
+	      	end
+	    end
+	end
+    else
+      parse_one_command_group input_channel
+  end else
+    parse_one_command_group input_channel
+
+let protected_loop input_chan =
+  let rec explain_and_restart e =
+    begin
+      output_results_nl(Cerrors.explain_exn e);
+      rearm_break();
+      looprec input_chan;
+    end
+  and looprec input_chan =
+    try 
+      while true do parse_one_command_group input_chan done
+    with
+      | Vernacexpr.Drop -> raise Vernacexpr.Drop
+      | Vernacexpr.Quit -> exit 0
+      | End_of_file -> exit 0
+      | DuringCommandInterp(loc, Vernacexpr.Quit) -> raise Vernacexpr.Quit
+      | DuringCommandInterp(loc, Vernacexpr.Drop) -> raise Vernacexpr.Drop
+      | DuringCommandInterp(loc, e) ->
+	  explain_and_restart e
+      | e -> explain_and_restart e in
+    begin
+      msgnl (str "Starting Centaur Specialized loop");
+      looprec input_chan
+    end
diff --git a/toplevel/protectedtoplevel.mli b/toplevel/protectedtoplevel.mli
new file mode 100644
index 00000000..b31afbf6
--- /dev/null
+++ b/toplevel/protectedtoplevel.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: protectedtoplevel.mli,v 1.5.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+(*i*)
+
+(* A protected toplevel (used in Pcoq). *)
+
+val break_happened : bool ref
+val global_request_id : int ref
+val output_results_nl : std_ppcmds -> unit
+val rearm_break : unit -> unit
+val check_break : unit -> unit
+val set_acknowledge_command : (int -> int -> exn option -> std_ppcmds) -> unit
+val set_start_marker : string -> unit
+val set_end_marker : string -> unit
+val parse_one_command_group : in_channel -> unit
+val protected_loop : in_channel -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
new file mode 100644
index 00000000..f703c067
--- /dev/null
+++ b/toplevel/record.ml
@@ -0,0 +1,236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: record.ml,v 1.52.2.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Termops
+open Environ
+open Declarations
+open Entries
+open Declare
+open Nametab
+open Coqast
+open Constrintern
+open Command
+open Inductive
+open Safe_typing
+open Decl_kinds
+open Indtypes
+open Type_errors
+open Topconstr
+
+(********** definition d'un record (structure) **************)
+
+let interp_decl sigma env = function
+  | Vernacexpr.AssumExpr((_,id),t) -> (id,None,interp_type Evd.empty env t)
+  | Vernacexpr.DefExpr((_,id),c,t) ->
+      let c = match t with
+	| None -> c
+	| Some t -> mkCastC (c,t)
+      in
+      let j = judgment_of_rawconstr Evd.empty env c in
+      (id,Some j.uj_val, j.uj_type)
+
+let typecheck_params_and_fields ps fs =
+  let env0 = Global.env () in
+  let env1,newps =
+    List.fold_left
+      (fun (env,newps) d -> match d with
+	| LocalRawAssum ([_,na],(CHole _ as t)) ->
+	    let t = interp_binder Evd.empty env na t in
+	    let d = (na,None,t) in
+	    (push_rel d env, d::newps)
+	| LocalRawAssum (nal,t) ->
+	    let t = interp_type Evd.empty env t in
+	    let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
+	    let ctx = List.rev ctx in
+	    (push_rel_context ctx env, ctx@newps)
+	| LocalRawDef ((_,na),c) ->
+	    let c = judgment_of_rawconstr Evd.empty env c in
+	    let d = (na, Some c.uj_val, c.uj_type) in
+	    (push_rel d env, d::newps))
+      (env0,[]) ps
+  in
+  let env2,newfs =
+    List.fold_left
+      (fun (env,newfs) d ->
+         let decl = interp_decl Evd.empty env d in
+         (push_rel decl env, decl::newfs))
+      (env1,[]) fs
+  in
+  newps, newfs
+
+let degenerate_decl (na,b,t) =
+  let id = match na with
+    | Name id -> id
+    | Anonymous -> anomaly "Unnamed record variable" in 
+  match b with
+    | None -> (id, Entries.LocalAssum t)
+    | Some b -> (id, Entries.LocalDef b)
+
+type record_error =
+  | MissingProj of identifier * identifier list
+  | BadTypedProj of identifier * env * Type_errors.type_error
+
+let warning_or_error coe indsp err =
+  let st = match err with
+    | MissingProj (fi,projs) ->
+	let s,have = if List.length projs > 1 then "s","have" else "","has" in
+        (str(string_of_id fi) ++
+	   str" cannot be defined because the projection" ++ str s ++ spc () ++
+           prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ str "n't.")
+    | BadTypedProj (fi,ctx,te) ->
+	match te with
+	  | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) ->
+              (str (string_of_id fi) ++ 
+		str" cannot be defined because it is informative and " ++
+		Printer.pr_inductive (Global.env()) indsp ++
+		str " is not.")   
+	  | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) ->
+	      (str (string_of_id fi) ++ 
+		str" cannot be defined because it is large and " ++
+		Printer.pr_inductive (Global.env()) indsp ++
+		str " is not.")
+	  | _ -> 
+	      (str " cannot be defined because it is not typable")
+  in
+  if coe then errorlabstrm "structure" st;
+  Options.if_verbose ppnl (hov 0 (str"Warning: " ++ st))
+
+type field_status =
+  | NoProjection of name
+  | Projection of constr
+
+exception NotDefinable of record_error
+
+(* This replaces previous projection bodies in current projection *)
+(* Undefined projs are collected and, at least one undefined proj occurs *)
+(* in the body of current projection then the latter can not be defined *)
+(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *)
+(* [[fields]] defined in ctxt [[params;x:ind]] *)
+let subst_projection fid l c =
+  let lv = List.length l in
+  let bad_projs = ref [] in
+  let rec substrec depth c = match kind_of_term c with
+    | Rel k ->
+	(* We are in context [[params;fields;x:ind;...depth...]] *)
+        if k <= depth+1 then 
+	  c
+        else if k-depth-1 <= lv then
+	  match List.nth l (k-depth-2) with
+	    | Projection t -> lift depth t
+	    | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k
+	    | NoProjection Anonymous -> assert false
+        else 
+	  mkRel (k-lv)
+    | _ -> map_constr_with_binders succ substrec depth c
+  in
+  let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *)
+  let c'' = substrec 0 c' in
+  if !bad_projs <> [] then 
+    raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
+  c''
+
+(* We build projections *)
+let declare_projections indsp coers fields =
+  let env = Global.env() in
+  let (mib,mip) = Global.lookup_inductive indsp in
+  let paramdecls = mip.mind_params_ctxt in
+  let r = mkInd indsp in
+  let rp = applist (r, extended_rel_list 0 paramdecls) in
+  let paramargs = extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*)
+  let x = Termops.named_hd (Global.env()) r Anonymous in
+  let lifted_fields = lift_rel_context 1 fields in
+  let (_,sp_projs,_) =
+    List.fold_left2
+      (fun (nfi,sp_projs,subst) coe (fi,optci,ti) ->
+	match fi with
+	| Anonymous ->
+	    (nfi-1, None::sp_projs,NoProjection fi::subst)
+	| Name fid ->
+            try
+              let ccl = subst_projection fid subst ti in
+	      let body = match optci with
+              | Some ci -> subst_projection fid subst ci
+              | None ->
+	        (* [ccl] is defined in context [params;x:rp] *)
+		(* [ccl'] is defined in context [params;x:rp;x:rp] *)
+		let ccl' = liftn 1 2 ccl in
+		let p = mkLambda (x, lift 1 rp, ccl') in
+		let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in
+		let ci = Inductiveops.make_case_info env indsp
+		  LetStyle [| RegularPat |] in
+		mkCase (ci, p, mkRel 1, [|branch|]) in
+	      let proj =
+	        it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in
+              let projtyp =
+                it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in
+	      let (sp,kn) =
+	        try
+		  let cie = {
+		    const_entry_body = proj;
+                    const_entry_type = Some projtyp;
+                    const_entry_opaque = false } in
+		  let k = (DefinitionEntry cie,IsDefinition) in
+		  let sp = declare_internal_constant fid k in
+		  Options.if_verbose message (string_of_id fid ^" is defined");
+		  sp
+                with Type_errors.TypeError (ctx,te) ->
+                  raise (NotDefinable (BadTypedProj (fid,ctx,te))) in
+	      let refi = ConstRef kn in
+	      let constr_fi = mkConst kn in
+	      if coe then begin
+	        let cl = Class.class_of_ref (IndRef indsp) in
+	        Class.try_add_new_coercion_with_source refi Global cl
+	      end;
+	      let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
+	      let constr_fip = applist (constr_fi,proj_args) in
+	      (nfi-1, (Some kn)::sp_projs, Projection constr_fip::subst)
+            with NotDefinable why ->
+	      warning_or_error coe indsp why;
+	      (nfi-1, None::sp_projs,NoProjection fi::subst))
+      (List.length fields,[],[]) coers (List.rev fields)
+  in sp_projs
+
+(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean 
+   list telling if the corresponding fields must me declared as coercion *)
+let definition_structure ((is_coe,(_,idstruc)),ps,cfs,idbuild,s) =
+  let coers,fs = List.split cfs in
+  let nparams = local_binders_length ps in
+  let extract_name acc = function
+      Vernacexpr.AssumExpr((_,Name id),_) -> id::acc
+    | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc
+    | _ -> acc in
+  let allnames =  idstruc::(List.fold_left extract_name [] fs) in
+  if not (list_distinct allnames) then error "Two objects have the same name";
+  (* Now, younger decl in params and fields is on top *)
+  let params,fields = typecheck_params_and_fields ps fs in
+  let args = extended_rel_list (List.length fields) params in
+  let ind = applist (mkRel (1+List.length params+List.length fields), args) in
+  let type_constructor = it_mkProd_or_LetIn ind fields in
+  let mie_ind =
+    { mind_entry_params = List.map degenerate_decl params;
+      mind_entry_typename = idstruc;
+      mind_entry_arity = mkSort s;
+      mind_entry_consnames = [idbuild];
+      mind_entry_lc = [type_constructor] } in
+  let mie =
+    { mind_entry_finite = true;
+      mind_entry_inds = [mie_ind] } in
+  let sp = declare_mutual_with_eliminations true mie in
+  let rsp = (sp,0) in (* This is ind path of idstruc *)
+  let sp_projs = declare_projections rsp coers fields in
+  let build = ConstructRef (rsp,1) in (* This is construct path of idbuild *)
+  if is_coe then Class.try_add_new_coercion build Global;
+  Recordops.add_new_struc (rsp,idbuild,nparams,List.rev sp_projs)
diff --git a/toplevel/record.mli b/toplevel/record.mli
new file mode 100644
index 00000000..8eff2ed5
--- /dev/null
+++ b/toplevel/record.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: record.mli,v 1.16.2.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Vernacexpr
+open Topconstr
+(*i*)
+
+(* [declare_projections ref coers params fields] declare projections of
+   record [ref] (if allowed), and put them as coercions accordingly to
+   [coers]; it returns the absolute names of projections *)
+
+val declare_projections :
+  inductive -> bool list -> rel_context -> constant option list
+
+val definition_structure :
+  lident with_coercion * local_binder list *
+  (local_decl_expr with_coercion) list * identifier * sorts -> unit
diff --git a/toplevel/recordobj.ml b/toplevel/recordobj.ml
new file mode 100755
index 00000000..d2a1e36e
--- /dev/null
+++ b/toplevel/recordobj.ml
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: recordobj.ml,v 1.12.2.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Libnames
+open Nameops
+open Term
+open Instantiate
+open Lib
+open Declare
+open Recordops
+open Classops
+open Nametab
+
+(*****  object definition ******)
+ 
+let typ_lams_of t = 
+  let rec aux acc c = match kind_of_term c with
+    | Lambda (x,c1,c2) -> aux (c1::acc) c2
+    | Cast (c,_) -> aux acc c
+    | t -> acc,t
+  in aux [] t
+
+let objdef_err ref =
+  errorlabstrm "object_declare"
+    (pr_id (id_of_global ref) ++
+       str" is not a structure object")
+
+let objdef_declare ref =
+  let sp = match ref with ConstRef sp -> sp | _ -> objdef_err ref in
+  let env = Global.env () in
+  let v = constr_of_reference ref in
+  let vc = match Environ.constant_opt_value env sp with
+    | Some vc -> vc
+    | None -> objdef_err ref in
+  let lt,t = decompose_lam vc in
+  let lt = List.rev (List.map snd lt) in
+  let f,args = match kind_of_term t with
+    | App (f,args) -> f,args 
+    | _ -> objdef_err ref in
+  let { s_PARAM = p; s_PROJ = lpj } = 
+    try (find_structure
+	   (match kind_of_term f with
+              | Construct (indsp,1) -> indsp
+	      | _ -> objdef_err ref))
+    with Not_found -> objdef_err ref in
+  let params, projs =
+    try list_chop p (Array.to_list args)
+    with _ -> objdef_err ref in
+  let lps = 
+    try List.combine lpj projs 
+    with _ -> objdef_err ref in
+  let comp =
+    List.fold_left
+      (fun l (spopt,t) -> (* comp=components *)
+	 match spopt with
+	   | None -> l
+           | Some proji_sp ->
+	       let c, args = decompose_app t in
+	       try (ConstRef proji_sp, reference_of_constr c, args) :: l
+               with Not_found -> l)
+      [] lps in
+  add_anonymous_leaf (inObjDef1 sp);
+  List.iter
+    (fun (refi,c,argj) -> add_new_objdef ((refi,c),v,lt,params,argj))
+    comp
+
+let add_object_hook _ = objdef_declare
diff --git a/toplevel/recordobj.mli b/toplevel/recordobj.mli
new file mode 100755
index 00000000..8ea39767
--- /dev/null
+++ b/toplevel/recordobj.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: recordobj.mli,v 1.7.6.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+val objdef_declare : Libnames.global_reference -> unit
+val add_object_hook : Tacexpr.declaration_hook
diff --git a/toplevel/searchisos.mli b/toplevel/searchisos.mli
new file mode 100644
index 00000000..f1ad7d5a
--- /dev/null
+++ b/toplevel/searchisos.mli
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: searchisos.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+val search_in_lib : bool ref
+val type_search : Term.constr -> unit
+val require_module2 : bool option -> string -> string option -> bool -> unit
+val upd_tbl_ind_one : unit -> unit
+val seetime : bool ref
+val load_leaf_entry : string -> Names.section_path * Libobject.obj -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
new file mode 100644
index 00000000..7fa80bcb
--- /dev/null
+++ b/toplevel/toplevel.ml
@@ -0,0 +1,326 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: toplevel.ml,v 1.22.2.2 2004/07/16 20:48:17 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Cerrors
+open Vernac
+open Pcoq
+open Protectedtoplevel
+
+(* A buffer for the character read from a channel. We store the command
+ * entered to be able to report errors without pretty-printing. *)
+
+type input_buffer = { 
+  mutable prompt : unit -> string;
+  mutable str : string; (* buffer of already read characters *)
+  mutable len : int;    (* number of chars in the buffer *)
+  mutable bols : int list; (* offsets in str of begining of lines *)
+  mutable tokens : Gram.parsable; (* stream of tokens *)
+  mutable start : int } (* stream count of the first char of the buffer *)
+
+(* Double the size of the buffer. *)
+
+let resize_buffer ibuf =
+  let nstr = String.create (2 * String.length ibuf.str + 1) in
+  String.blit ibuf.str 0 nstr 0 (String.length ibuf.str);
+  ibuf.str <- nstr
+
+(* Delete all irrelevent lines of the input buffer. Keep the last line
+   in the buffer (useful when there are several commands on the same line. *)
+
+let resynch_buffer ibuf =
+  match ibuf.bols with
+    | ll::_ ->
+        let new_len = ibuf.len - ll in
+        String.blit ibuf.str ll ibuf.str 0 new_len;
+        ibuf.len <- new_len;
+        ibuf.bols <- [];
+        ibuf.start <- ibuf.start + ll
+    | _ -> ()
+
+(* Read a char in an input channel, displaying a prompt at every
+   beginning of line. *)
+
+let prompt_char ic ibuf count =
+  let bol = match ibuf.bols with
+    | ll::_ -> ibuf.len == ll
+    | [] -> ibuf.len == 0
+  in
+  if bol && not !print_emacs then msgerr (str (ibuf.prompt()));
+  try
+    let c = input_char ic in
+    if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols;
+    if ibuf.len == String.length ibuf.str then resize_buffer ibuf;
+    ibuf.str.[ibuf.len] <- c;
+    ibuf.len <- ibuf.len + 1;
+    Some c
+  with End_of_file -> 
+    None
+
+(* Reinitialize the char stream (after a Drop) *)
+
+let reset_input_buffer ic ibuf =
+  ibuf.str <- "";
+  ibuf.len <- 0;
+  ibuf.bols <- [];
+  ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf));
+  ibuf.start <- 0
+
+(* Functions to print underlined locations from an input buffer. *)
+
+(* Given a location, returns the list of locations of each line. The last
+   line is returned separately. It also checks the location bounds. *)
+
+let get_bols_of_loc ibuf (bp,ep) =
+  let add_line (b,e) lines =
+    if b < 0 or e < b then anomaly "Bad location";
+    match lines with
+      | ([],None) -> ([], Some (b,e))
+      | (fl,oe) -> ((b,e)::fl, oe) 
+  in
+  let rec lines_rec ba after = function
+    | []                  -> add_line (0,ba) after
+    | ll::_ when ll <= bp -> add_line (ll,ba) after
+    | ll::fl              ->
+        let nafter = if ll < ep then add_line (ll,ba) after else after in
+        lines_rec ll nafter fl 
+  in
+  let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in
+  (fl,out_some ll)
+
+let dotted_location (b,e) =
+  if e-b < 3 then 
+    ("", String.make (e-b) ' ')
+  else 
+    (String.make (e-b-1) '.', " ")
+
+let print_highlight_location ib loc =
+  let (bp,ep) = unloc loc in
+  let bp = bp - ib.start 
+  and ep = ep - ib.start in
+  let highlight_lines =
+    match get_bols_of_loc ib (bp,ep) with
+      | ([],(bl,el)) ->  
+	  (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++
+             str"> " ++ str(String.make (bp-bl) ' ') ++
+             str(String.make (ep-bp) '^'))
+      | ((b1,e1)::ml,(bn,en)) ->
+          let (d1,s1) = dotted_location (b1,bp) in
+          let (dn,sn) = dotted_location (ep,en) in
+          let l1 = (str"> " ++ str d1 ++ str s1 ++
+                      str(String.sub ib.str bp (e1-bp))) in
+          let li =
+            prlist (fun (bi,ei) ->
+                      (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in
+          let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++
+                      str sn ++ str dn) in 
+	  (l1 ++ li ++ ln)
+  in 
+  (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ fnl () ++
+     highlight_lines ++ fnl ())
+
+(* Functions to report located errors in a file. *)
+
+let print_location_in_file s inlibrary fname (bp,ep) =
+  let errstrm = (str"Error while reading " ++ str s ++ str" :" ++ fnl ()) in
+  if (bp,ep) = dummy_loc then 
+    (errstrm ++ str", unknown location." ++ fnl ())
+  else
+    if inlibrary then
+      (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++
+       str" characters " ++ Cerrors.print_loc (bp,ep) ++ fnl ())
+    else
+    let (bp,ep) = unloc (bp,ep) in
+    let ic = open_in fname in
+    let rec line_of_pos lin bol cnt =
+      if cnt < bp then
+        if input_char ic == '\n'
+        then line_of_pos (lin + 1) (cnt +1) (cnt+1)
+        else line_of_pos lin bol (cnt+1)
+      else (lin, bol)
+    in
+    try
+      let (line, bol) = line_of_pos 1 0 0 in
+      close_in ic;
+      (errstrm  ++ str"File " ++ str ("\""^fname^"\"") ++
+         str", line " ++ int line ++
+         str", characters " ++ Cerrors.print_loc (make_loc (bp-bol,ep-bol)) ++ fnl ())
+    with e -> (close_in ic; (errstrm ++ str", invalid location." ++ fnl ()))
+	
+let print_command_location ib dloc =
+  match dloc with
+    | Some (bp,ep) ->
+        (str"Error during interpretation of command:" ++ fnl () ++
+           str(String.sub ib.str (bp-ib.start) (ep-bp)) ++ fnl ())
+    | None -> (mt ())
+
+let valid_loc dloc (b,e) =
+  (b,e) <> dummy_loc
+  & match dloc with
+    | Some (bd,ed) -> bd<=b & e<=ed
+    | _ -> true
+	  
+let valid_buffer_loc ib dloc (b,e) =
+  valid_loc dloc (b,e) & 
+  let (b,e) = unloc (b,e) in b-ib.start >= 0 & e-ib.start < ib.len & b<=e 
+
+(*s The Coq prompt is the name of the focused proof, if any, and "Coq"
+    otherwise. We trap all exceptions to prevent the error message printing
+    from cycling. *)
+let make_prompt () =
+  try
+    (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < "
+  with _ -> 
+    "Coq < "
+
+(* A buffer to store the current command read on stdin. It is
+ * initialized when a vernac command is immediately followed by "\n",
+ * or after a Drop. *)
+let top_buffer =
+  let pr() = (make_prompt())^(emacs_str (String.make 1 (Char.chr 249)))
+  in
+  { prompt = pr;
+    str = "";
+    len = 0;
+    bols = [];
+    tokens = Gram.parsable (Stream.of_list []);
+    start = 0 }
+
+let set_prompt prompt =
+  top_buffer.prompt
+  <- (fun () -> (prompt ()) ^ (emacs_str (String.make 1 (Char.chr 249))))
+
+(* Removes and prints the location of the error. The following exceptions
+   need not be located. *)
+let rec is_pervasive_exn = function
+  | Out_of_memory | Stack_overflow | Sys.Break -> true
+  | Error_in_file (_,_,e) -> is_pervasive_exn e
+  | Stdpp.Exc_located (_,e) -> is_pervasive_exn e
+  | DuringCommandInterp (_,e) -> is_pervasive_exn e
+  | _ -> false
+
+(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
+   May raise only the following exceptions: Drop and End_of_input,
+   meaning we get out of the Coq loop *)
+let print_toplevel_error exc =
+  let (dloc,exc) =
+    match exc with
+      | DuringCommandInterp (loc,ie) ->
+          if loc = dummy_loc then (None,ie) else (Some loc, ie)
+      | _ -> (None, exc) 
+  in
+  let (locstrm,exc) =
+    match exc with
+      | Stdpp.Exc_located (loc, ie) ->
+          if valid_buffer_loc top_buffer dloc loc then
+            (print_highlight_location top_buffer loc, ie)
+          else 
+	    ((mt ()) (* print_command_location top_buffer dloc *), ie)
+      | Error_in_file (s, (inlibrary, fname, loc), ie) ->
+          (print_location_in_file s inlibrary fname loc, ie)
+      | _ -> 
+	  ((mt ()) (* print_command_location top_buffer dloc *), exc)
+  in
+  match exc with
+    | End_of_input -> 
+	msgerrnl (mt ()); pp_flush(); exit 0
+    | Vernacexpr.Drop ->  (* Last chance *)
+        if Mltop.is_ocaml_top() then raise Vernacexpr.Drop;
+        (str"Error: There is no ML toplevel." ++ fnl ())
+    | Vernacexpr.ProtectedLoop ->
+	raise Vernacexpr.ProtectedLoop
+    | Vernacexpr.Quit -> 
+	raise Vernacexpr.Quit
+    | _ -> 
+	(if is_pervasive_exn exc then (mt ()) else locstrm) ++
+        Cerrors.explain_exn exc
+
+(* Read the input stream until a dot is encountered *)
+let parse_to_dot =
+  let rec dot st = match Stream.next st with
+    | ("", ".") -> ()
+    | ("EOI", "") -> raise End_of_input
+    | _ -> dot st
+  in 
+  Gram.Entry.of_parser "Coqtoplevel.dot" dot
+    
+(* We assume that when a lexer error occurs, at least one char was eaten *)
+let rec discard_to_dot () =
+  try 
+    Gram.Entry.parse parse_to_dot top_buffer.tokens
+  with Stdpp.Exc_located(_,Token.Error _) -> 
+    discard_to_dot()
+
+
+(* If the error occured while parsing, we read the input until a dot token
+ * in encountered. *)
+
+let process_error = function
+  | DuringCommandInterp _ as e -> e
+  | e ->
+      if is_pervasive_exn e then 
+	e
+      else 
+        try 
+	  discard_to_dot (); e 
+	with
+          | End_of_input -> End_of_input
+          | de -> if is_pervasive_exn de then de else e
+
+(* do_vernac reads and executes a toplevel phrase, and print error
+   messages when an exception is raised, except for the following:
+     Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists.
+           Otherwise, exit.
+     End_of_input: Ctrl-D was typed in, we will quit *)
+let do_vernac () =
+  msgerrnl (mt ());
+  if !print_emacs then msgerr (str (top_buffer.prompt()));
+  resynch_buffer top_buffer;
+  begin 
+    try 
+      raw_do_vernac top_buffer.tokens
+    with e -> 
+      msgnl (print_toplevel_error (process_error e)) 
+  end;
+  flush_all()
+
+(* coq and go read vernacular expressions until Drop is entered.
+ * Ctrl-C will raise the exception Break instead of aborting Coq.
+ * Here we catch the exceptions terminating the Coq loop, and decide
+ * if we really must quit.
+ * The boolean value is used to choose between a protected loop, which
+ * we think is more suited for communication with other programs, or
+ * plain communication. *)
+
+let rec coq_switch b =
+  Sys.catch_break true;
+  (* ensure we have a command separator object (DOT) so that the first
+     command can be reseted. *)
+  Lib.mark_end_of_command();
+  try
+    if b then begin
+      reset_input_buffer stdin top_buffer;
+      while true do do_vernac() done
+    end else
+      protected_loop stdin
+  with
+    | Vernacexpr.Drop -> ()
+    | Vernacexpr.ProtectedLoop -> 
+	Lib.declare_initial_state();
+	coq_switch false
+    | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0
+    | Vernacexpr.Quit -> exit 0
+    | e ->
+	msgerrnl (str"Anomaly. Please report.");
+	coq_switch b
+
+let loop () = coq_switch true
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
new file mode 100644
index 00000000..1b6b48d4
--- /dev/null
+++ b/toplevel/toplevel.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: toplevel.mli,v 1.6.10.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Pcoq
+(*i*)
+
+(* The Coq toplevel loop. *)
+
+(* A buffer for the character read from a channel. We store the command
+ * entered to be able to report errors without pretty-printing. *)
+
+type input_buffer = { 
+  mutable prompt : unit -> string;
+  mutable str : string; (* buffer of already read characters *)
+  mutable len : int;    (* number of chars in the buffer *)
+  mutable bols : int list; (* offsets in str of begining of lines *)
+  mutable tokens : Pcoq.Gram.parsable; (* stream of tokens *)
+  mutable start : int } (* stream count of the first char of the buffer *)
+
+(* The input buffer of stdin. *)
+
+val top_buffer : input_buffer
+val set_prompt : (unit -> string) -> unit
+
+(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
+  May raise only the following exceptions: [Drop] and [End_of_input],
+  meaning we get out of the Coq loop. *)
+
+val print_toplevel_error : exn -> std_ppcmds
+
+(* Parse and execute a vernac command. *)
+
+val do_vernac : unit -> unit
+
+(* Main entry point of Coq: read and execute vernac commands. *)
+
+val loop : unit -> unit
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
new file mode 100644
index 00000000..9fe8b280
--- /dev/null
+++ b/toplevel/usage.ml
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: usage.ml,v 1.15.2.1 2004/07/16 19:31:50 herbelin Exp $ *)
+
+let version () =
+  Printf.printf "The Coq Proof Assistant, version %s (%s)\n"
+    Coq_config.version Coq_config.date;
+  Printf.printf "compiled on %s\n" Coq_config.compile_date;
+  exit 0
+
+(* print the usage of coqtop (or coqc) on channel co *)
+
+let print_usage_channel co command =
+  output_string co command;
+  output_string co "Coq options are:\n";
+  output_string co
+"  -I dir                 add directory dir in the include path
+  -include dir           (idem)
+  -R dir coqdir          recursively map physical dir to logical coqdir 
+  -src                   add source directories in the include path
+
+  -inputstate f          read state from file f.coq
+  -is f                  (idem)
+  -nois                  start with an empty state
+  -outputstate f         write state in file f.coq
+
+  -load-ml-object f      load ML object file f 
+  -load-ml-source f      load ML file f 
+  -load-vernac-source f  load Coq file f.v (Load f.)
+  -l f                   (idem) 
+  -load-vernac-source-verbose f  load Coq file f.v (Load Verbose f.)
+  -lv f			(idem)
+  -load-vernac-object f  load Coq object file f.vo
+  -require f             load Coq object file f.vo and import it (Require f.)
+  -compile f             compile Coq file f.v (implies -batch)
+  -compile-verbose f     verbosely compile Coq file f.v (implies -batch)
+
+  -opt                   run the native-code version of Coq or Coq_SearchIsos
+  -byte                  run the bytecode version of Coq or Coq_SearchIsos
+
+  -where                 print Coq's standard library location and exit
+  -v                     print Coq version and exit
+
+  -q                     skip loading of rcfile
+  -init-file f           set the rcfile to f
+  -user u                use the rcfile of user u
+  -batch                 batch mode (exits just after arguments parsing)
+  -boot                  boot mode (implies -q and -batch)
+  -emacs                 tells Coq it is executed under Emacs
+  -dump-glob f           dump globalizations in file f (to be used by coqdoc)
+  -impredicative-set     set sort Set impredicative
+  -dont-load-proofs      don't load opaque proofs in memory
+  -xml                   export XML files either to the hierarchy rooted in
+                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to
+                         stdout (if unset)
+"
+
+(* print the usage on standard error *)
+
+let print_usage = print_usage_channel stderr
+
+let print_usage_coqtop () =
+  print_usage "Usage: coqtop <options>\n\n"
+
+let print_usage_coqc () =
+  print_usage "Usage: coqc <options> <Coq options> file...\n
+options are:
+  -verbose  compile verbosely
+  -image f  specify an alternative executable for Coq
+  -t        keep temporary files\n\n"
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
new file mode 100644
index 00000000..16929d68
--- /dev/null
+++ b/toplevel/usage.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: usage.mli,v 1.5.16.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*s Prints the version number on the standard output and exits (with 0). *)
+
+val version : unit -> 'a
+
+(*s Prints the usage on the error output, preceeded by a user-provided message. *)
+val print_usage : string -> unit
+
+(*s Prints the usage on the error output. *)
+val print_usage_coqtop : unit -> unit
+val print_usage_coqc : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
new file mode 100644
index 00000000..a5716619
--- /dev/null
+++ b/toplevel/vernac.ml
@@ -0,0 +1,301 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: vernac.ml,v 1.59.2.3 2004/07/16 20:48:17 herbelin Exp $ *)
+
+(* Parsing of vernacular. *)
+
+open Pp
+open Lexer
+open Util
+open Options
+open System
+open Coqast
+open Vernacexpr
+open Vernacinterp
+open Ppvernacnew
+
+(* The functions in this module may raise (unexplainable!) exceptions.
+   Use the module Coqtoplevel, which catches these exceptions
+   (the exceptions are explained only at the toplevel). *)
+
+exception DuringCommandInterp of Util.loc * exn
+
+(* Specifies which file is read. The intermediate file names are
+   discarded here. The Drop exception becomes an error. We forget
+   if the error ocurred during interpretation or not *)
+
+let raise_with_file file exc =
+  let (cmdloc,re) =
+    match exc with
+      | DuringCommandInterp(loc,e) -> (loc,e)
+      | e -> (dummy_loc,e) 
+  in
+  let (inner,inex) =
+    match re with
+      | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc ->
+          ((b, f, loc), e)
+      | Stdpp.Exc_located (loc, e) when loc <> dummy_loc ->
+          ((false,file, loc), e)
+      | _ -> ((false,file,cmdloc), re)
+  in 
+  raise (Error_in_file (file, inner, disable_drop inex))
+
+let real_error = function
+  | Stdpp.Exc_located (_, e) -> e
+  | Error_in_file (_, _, e) -> e
+  | e -> e
+
+(* Opening and closing a channel. Open it twice when verbose: the first
+   channel is used to read the commands, and the second one to print them.
+   Note: we could use only one thanks to seek_in, but seeking on and on in
+   the file we parse seems a bit risky to me.  B.B.  *)
+
+let open_file_twice_if verbosely fname =
+  let _,longfname = find_file_in_path (Library.get_load_path ()) fname in
+  let in_chan = open_in longfname in
+  let verb_ch = if verbosely then Some (open_in longfname) else None in
+  let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in
+  (in_chan, longfname, (po, verb_ch))
+
+let close_input in_chan (_,verb) =
+  try 
+    close_in in_chan;
+    match verb with
+      | Some verb_ch -> close_in verb_ch
+      | _ -> ()
+  with _ -> ()
+
+let verbose_phrase verbch loc =
+  let loc = unloc loc in
+  match verbch with
+    | Some ch ->
+	let len = snd loc - fst loc in
+	let s = String.create len in
+        seek_in ch (fst loc);
+        really_input ch s 0 len;
+        message s;
+        pp_flush()
+    | _ -> ()
+
+exception End_of_input
+  
+let parse_phrase (po, verbch) =
+  match Pcoq.Gram.Entry.parse Pcoq.main_entry po with
+    | Some (loc,_ as com) -> verbose_phrase verbch loc; com
+    | None -> raise End_of_input
+
+(* vernac parses the given stream, executes interpfun on the syntax tree it
+ * parses, and is verbose on "primitives" commands if verbosely is true *)
+
+let just_parsing = ref false
+let chan_translate = ref stdout
+let last_char = ref '\000'
+
+(* postprocessor to avoid lexical icompatibilities between V7 and V8.
+   Ex: auto.(* comment *)  or  simpl.auto
+ *)
+let set_formatter_translator() =
+  let ch = !chan_translate in
+  let out s b e =
+    let n = e-b in
+    if n > 0 then begin
+      (match !last_char with
+          '.' -> 
+            (match s.[b] with
+                '('|'a'..'z'|'A'..'Z' -> output ch " " 0 1 
+              | _ -> ())
+        | _ -> ());
+      last_char := s.[e-1]
+    end;
+    output ch s b e
+  in
+  Format.set_formatter_output_functions out (fun () -> flush ch);
+  Format.set_max_boxes max_int
+
+let pre_printing = function
+  | VernacSolve (i,tac,deftac) when Options.do_translate () ->
+      (try
+        let (_,env) = Pfedit.get_goal_context i in
+        let t = Options.with_option Options.translate_syntax
+	  (Tacinterp.glob_tactic_env [] env) tac in
+        let pfts = Pfedit.get_pftreestate () in
+        let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in
+        Some (env,t,Pfedit.focus(),List.length gls)
+      with UserError _|Stdpp.Exc_located _ -> None)
+  | _ -> None
+
+let post_printing loc (env,t,f,n) = function
+  | VernacSolve (i,_,deftac) ->
+      let loc = unloc loc in
+      set_formatter_translator();
+      let pp = Ppvernacnew.pr_vernac_solve (i,env,t,deftac) ++ sep_end () in
+      (if !translate_file then begin
+	msg (hov 0 (comment (fst loc) ++ pp ++ comment (snd loc - 1)));
+      end
+      else
+	msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ pp)));
+      Format.set_formatter_out_channel stdout
+  | _ -> ()
+
+let pr_new_syntax loc ocom =
+  let loc = unloc loc in
+  if !translate_file then set_formatter_translator();
+  let fs = States.freeze () in
+  let com = match ocom with
+    | Some (VernacV7only _) ->
+        Options.v7_only := true;
+        mt()
+    | Some VernacNop -> mt()
+    | Some com -> pr_vernac com
+    | None -> mt() in
+  if !translate_file then
+    msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc)))
+  else
+    msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
+  States.unfreeze fs;
+  Constrintern.set_temporary_implicits_in [];
+  Constrextern.set_temporary_implicits_out [];
+  Format.set_formatter_out_channel stdout
+
+let rec vernac_com interpfun (loc,com) =
+  let rec interp = function
+    | VernacLoad (verbosely, fname) ->
+        (* translator state *)
+        let ch = !chan_translate in
+        let cs = Lexer.com_state() in
+        let cl = !Pp.comments in
+        (* end translator state *)
+        (* coqdoc state *)
+        let cds = Constrintern.coqdoc_freeze() in
+        if !Options.translate_file then begin
+          let _,f = find_file_in_path (Library.get_load_path ())
+            (make_suffix fname ".v") in
+          chan_translate := open_out (f^"8");
+          Pp.comments := []
+        end;
+        begin try
+          read_vernac_file verbosely (make_suffix fname ".v");
+          if !Options.translate_file then close_out !chan_translate;
+          chan_translate := ch;
+          Lexer.restore_com_state cs;
+          Pp.comments := cl;
+          Constrintern.coqdoc_unfreeze cds;
+        with e ->
+          if !Options.translate_file then close_out !chan_translate;
+          chan_translate := ch;
+          Lexer.restore_com_state cs;
+          Pp.comments := cl;
+          Constrintern.coqdoc_unfreeze cds;
+          raise e end;
+
+    | VernacList l -> List.iter (fun (_,v) -> interp v) l
+
+    | VernacTime v ->
+	let tstart = System.get_time() in
+        if not !just_parsing then interp v;
+	let tend = System.get_time() in
+        msgnl (str"Finished transaction in " ++
+                 System.fmt_time_difference tstart tend)
+
+    (* To be interpreted in v7 or translator input only *)
+    | VernacV7only v ->
+        Options.v7_only := true;
+        if !Options.v7 || Options.do_translate() then interp v;
+        Options.v7_only := false
+
+    (* To be interpreted in translator output only *)
+    | VernacV8only v -> 
+        if not !Options.v7 && not (do_translate()) then
+          interp v
+
+    | v -> if not !just_parsing then interpfun v
+
+  in 
+  try
+    Options.v7_only := false;
+    if do_translate () then
+      match pre_printing com with
+          None ->
+            pr_new_syntax loc (Some com);
+            interp com
+        | Some state ->
+            (try
+              interp com;
+              post_printing loc state com
+            with e ->
+              post_printing loc state com;
+              raise e)
+    else
+      interp com
+  with e -> 
+    Format.set_formatter_out_channel stdout;
+    Options.v7_only := false;
+    raise (DuringCommandInterp (loc, e))
+
+and vernac interpfun input =
+  vernac_com interpfun (parse_phrase input)
+
+and read_vernac_file verbosely s =
+  let interpfun =
+    if verbosely then 
+      Vernacentries.interp
+    else 
+      Options.silently Vernacentries.interp 
+  in
+  let (in_chan, fname, input) = open_file_twice_if verbosely s in
+  try
+    (* we go out of the following infinite loop when a End_of_input is
+     * raised, which means that we raised the end of the file being loaded *)
+    while true do vernac interpfun input; pp_flush () done
+  with e ->   (* whatever the exception *)
+    Format.set_formatter_out_channel stdout;
+    close_input in_chan input;    (* we must close the file first *)
+    match real_error e with
+      | End_of_input ->
+          if do_translate () then pr_new_syntax (make_loc (max_int,max_int)) None
+      | _ -> raise_with_file fname e
+
+(* raw_do_vernac : char Stream.t -> unit
+ * parses and executes one command of the vernacular char stream.
+ * Marks the end of the command in the lib_stk to make vernac undoing
+ * easier. *)
+
+let raw_do_vernac po =
+  vernac (States.with_heavy_rollback Vernacentries.interp) (po,None);
+  Lib.mark_end_of_command()
+
+(* XML output hooks *)
+let xml_start_library = ref (fun _ -> ())
+let xml_end_library = ref (fun _ -> ())
+
+let set_xml_start_library f = xml_start_library := f
+let set_xml_end_library f = xml_end_library := f
+
+(* Load a vernac file. Errors are annotated with file and location *)
+let load_vernac verb file =
+  chan_translate :=
+    if !Options.translate_file then open_out (file^"8") else stdout;
+  try 
+    read_vernac_file verb file;
+    if !Options.translate_file then close_out !chan_translate;
+  with e -> 
+    if !Options.translate_file then close_out !chan_translate;
+    raise_with_file file e
+
+(* Compile a vernac file (f is assumed without .v suffix) *)
+let compile verbosely f =
+  let ldir,long_f_dot_v = Library.start_library f in
+  if !dump then dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n");
+  if !Options.xml_export then !xml_start_library ();
+  let _ = load_vernac verbosely long_f_dot_v in
+  if Pfedit.get_all_proof_names () <> [] then
+    (message "Error: There are pending proofs"; exit 1);
+  if !Options.xml_export then !xml_end_library ();
+  Library.save_library_to ldir (long_f_dot_v ^ "o")
+
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
new file mode 100644
index 00000000..d8f4b247
--- /dev/null
+++ b/toplevel/vernac.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: vernac.mli,v 1.10.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(* Parsing of vernacular. *)
+
+(* Read a vernac command on the specified input (parse only).
+   Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
+
+val parse_phrase : Pcoq.Gram.parsable * in_channel option ->
+  Util.loc * Vernacexpr.vernac_expr
+
+(* Reads and executes vernac commands from a stream.
+   The boolean [just_parsing] disables interpretation of commands. *)
+
+exception DuringCommandInterp of Util.loc * exn
+exception End_of_input
+
+val just_parsing : bool ref
+val raw_do_vernac : Pcoq.Gram.parsable -> unit
+
+(* Set XML hooks *)
+val set_xml_start_library : (unit -> unit) -> unit
+val set_xml_end_library   : (unit -> unit) -> unit
+
+(* Load a vernac file, verbosely or not. Errors are annotated with file
+   and location *)
+
+val load_vernac : bool -> string -> unit
+
+
+(* Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
+
+val compile : bool -> string -> unit
+
+(* Interpret a vernac AST *)
+
+val vernac_com : 
+  (Vernacexpr.vernac_expr -> unit) ->
+  Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
new file mode 100644
index 00000000..1c6ad9a6
--- /dev/null
+++ b/toplevel/vernacentries.ml
@@ -0,0 +1,1240 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: vernacentries.ml,v 1.195.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(* Concrete syntax of the mathematical vernacular MV V2.6 *)
+
+open Pp
+open Util
+open Options
+open Names
+open Entries
+open Nameops
+open Term
+open Pfedit
+open Tacmach
+open Proof_trees
+open Constrintern
+open Prettyp
+open Printer
+open Tacinterp
+open Command
+open Goptions
+open Libnames
+open Nametab
+open Vernacexpr
+open Decl_kinds
+open Topconstr
+open Pretyping
+
+(* Pcoq hooks *)
+
+type pcoq_hook = {
+  start_proof : unit -> unit;
+  solve : int -> unit;
+  abort : string -> unit;
+  search : searchable -> dir_path list * bool -> unit;
+  print_name : reference -> unit;
+  print_check : Environ.unsafe_judgment -> unit;
+  print_eval : (constr -> constr) -> Environ.env -> constr_expr -> 
+    Environ.unsafe_judgment -> unit;
+  show_goal : int option -> unit
+}
+
+let pcoq = ref None
+let set_pcoq_hook f = pcoq := Some f
+
+(* Misc *)
+
+let cl_of_qualid = function
+  | FunClass -> Classops.CL_FUN
+  | SortClass -> Classops.CL_SORT
+  | RefClass r -> Class.class_of_ref (Nametab.global r)
+
+(*******************)
+(* "Show" commands *)
+
+let show_proof () =
+  let pts = get_pftreestate () in
+  let pf = proof_of_pftreestate pts in
+  let cursor = cursor_of_pftreestate pts in
+  let evc = evc_of_pftreestate pts in
+  let (pfterm,meta_types) = extract_open_pftreestate pts in
+  msgnl (str"LOC: " ++
+    prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++
+    str"Subgoals" ++ fnl () ++
+    prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ 
+      prtype ty ++ fnl ())
+      meta_types
+    ++ str"Proof: " ++ prterm (Evarutil.nf_evar evc pfterm))
+
+let show_node () =
+  let pts = get_pftreestate () in
+  let pf = proof_of_pftreestate pts
+  and cursor = cursor_of_pftreestate pts in
+  msgnl (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++
+         prgl (goal_of_proof pf) ++ fnl () ++
+         (match pf.Proof_type.ref with
+            | None -> (str"BY <rule>")
+            | Some(r,spfl) ->
+		(str"BY " ++ Refiner.pr_rule r ++ fnl () ++
+		 str"  " ++
+		   hov 0 (prlist_with_sep pr_fnl prgl
+			    (List.map goal_of_proof spfl)))))
+    
+let show_script () =
+  let pts = get_pftreestate () in
+  let pf = proof_of_pftreestate pts
+  and evc = evc_of_pftreestate pts in
+  msgnl (Refiner.print_treescript true evc (Global.named_context()) pf)
+
+let show_top_evars () =
+  let pfts = get_pftreestate () in 
+  let gls = top_goal_of_pftreestate pfts in 
+  let sigma = project gls in 
+  msg (pr_evars_int 1 (Evd.non_instantiated sigma))
+
+let show_prooftree () =
+  let pts = get_pftreestate () in
+  let pf = proof_of_pftreestate pts
+  and evc = evc_of_pftreestate pts in
+  msg (Refiner.print_proof evc (Global.named_context()) pf)
+
+let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) ()
+
+  (* Simulate the Intro(s) tactic *)
+
+let fresh_id_of_name avoid gl = function
+    Anonymous -> Tactics.fresh_id avoid (id_of_string "H") gl
+  | Name id   -> id
+
+let rec do_renum avoid gl = function
+    [] -> mt ()
+  | [n] -> pr_id (fresh_id_of_name avoid gl n)
+  | n :: l ->
+      let id = fresh_id_of_name avoid gl n in
+      pr_id id ++ spc () ++ do_renum (id :: avoid) gl l
+
+let show_intro all =
+  let pf = get_pftreestate() in
+  let gl = nth_goal_of_pftreestate 1 pf in
+  let l,_= decompose_prod (strip_outer_cast (pf_concl gl)) in
+  let nl = List.rev_map fst l in
+  if all then
+    msgnl (do_renum [] gl nl)
+  else
+    try 
+      let n = List.hd nl in
+      msgnl (pr_id (fresh_id_of_name [] gl n))
+    with Failure "hd" -> message "" 
+
+(********************)
+(* "Print" commands *)
+
+let print_path_entry (s,l) =
+  (str s ++ str " " ++ tbrk (0,2) ++ str (string_of_dirpath l))
+
+let print_loadpath () =
+  let l = Library.get_full_load_path () in
+  msgnl (Pp.t (str "Physical path:                                 " ++
+		 tab () ++ str "Logical Path:" ++ fnl () ++ 
+		 prlist_with_sep pr_fnl print_path_entry l))
+
+let print_modules () =
+  let opened = Library.opened_libraries ()
+  and loaded = Library.loaded_libraries () in
+  let loaded_opened = list_intersect loaded opened
+  and only_loaded = list_subtract loaded opened in
+  str"Loaded and imported library files: " ++ 
+  pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++
+  str"Loaded and not imported library files: " ++
+  pr_vertical_list pr_dirpath only_loaded
+
+
+let print_module r =
+  let (loc,qid) = qualid_of_reference r in
+  try
+    let globdir = Nametab.locate_dir qid in
+      match globdir with
+	  DirModule (dirpath,(mp,_)) ->
+	    msgnl (Printmod.print_module (Printmod.printable_body dirpath) mp)
+	| _ -> raise Not_found
+  with
+      Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid)
+
+let print_modtype r = 
+  let (loc,qid) = qualid_of_reference r in
+  try
+    let kn = Nametab.locate_modtype qid in
+      msgnl (Printmod.print_modtype kn)
+  with
+      Not_found -> msgnl (str"Unknown Module Type " ++ pr_qualid qid)
+
+let dump_universes s =
+  let output = open_out s in
+  try
+    Univ.dump_universes output (Global.universes ());
+    close_out output;
+    msgnl (str ("Universes written to file \""^s^"\".")) 
+  with
+      e -> close_out output; raise e
+
+(*********************)
+(* "Locate" commands *)
+
+let locate_file f =
+  try
+    let _,file =
+      System.where_in_path (Library.get_load_path()) f in
+    msgnl (str file)
+  with Not_found -> 
+    msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++
+		  str"on loadpath"))
+
+let msg_found_library = function
+  | Library.LibLoaded, fulldir, file ->
+      msgnl(pr_dirpath fulldir ++ str " has been loaded from file" ++ fnl () ++
+      str file)
+  | Library.LibInPath, fulldir, file ->
+      msgnl(pr_dirpath fulldir ++ str " is bound to file " ++ str file)
+let msg_notfound_library loc qid = function
+  | Library.LibUnmappedDir ->
+      let dir = fst (repr_qualid qid) in
+      user_err_loc (loc,"locate_library",
+        str "Cannot find a physical path bound to logical path " ++
+           pr_dirpath dir ++ fnl ())
+  | Library.LibNotFound ->
+      msgnl (hov 0 
+	(str"Unable to locate library" ++ spc () ++ pr_qualid qid))
+  | e -> assert false
+
+let print_located_library r =
+  let (loc,qid) = qualid_of_reference r in
+  try msg_found_library (Library.locate_qualified_library qid)
+  with e -> msg_notfound_library loc qid e
+
+(**********)
+(* Syntax *)
+
+let vernac_syntax = Metasyntax.add_syntax_obj
+
+let vernac_grammar = Metasyntax.add_grammar_obj
+
+let vernac_syntax_extension = Metasyntax.add_syntax_extension
+
+let vernac_delimiters = Metasyntax.add_delimiters
+
+let vernac_bind_scope sc cll = 
+  List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll
+
+let vernac_open_close_scope = Symbols.open_close_scope
+
+let vernac_arguments_scope qid scl =
+  Symbols.declare_arguments_scope (global qid) scl
+
+let vernac_infix = Metasyntax.add_infix
+
+let vernac_distfix = Metasyntax.add_distfix
+
+let vernac_notation = Metasyntax.add_notation
+
+(***********)
+(* Gallina *)
+
+let start_proof_and_print idopt k t hook =
+  start_proof_com idopt k t hook;
+  print_subgoals ();
+  if !pcoq <> None then (out_some !pcoq).start_proof ()
+
+let vernac_definition (local,_ as k) id def hook =
+  match def with
+  | ProveBody (bl,t) ->   (* local binders, typ *)
+      if Lib.is_modtype () then
+	errorlabstrm "Vernacentries.VernacDefinition"
+	  (str "Proof editing mode not supported in module types")
+      else
+	let hook _ _ = () in
+        let kind = if local=Local then IsLocal else IsGlobal DefinitionBody in
+	  start_proof_and_print (Some id) kind (bl,t) hook
+  | DefineBody (bl,red_option,c,typ_opt) ->
+      let red_option = match red_option with
+        | None -> None
+        | Some r -> 
+	    let (evc,env)= Command.get_current_context () in
+	    Some (interp_redexp env evc r) in
+      declare_definition id k bl red_option c typ_opt hook
+
+let vernac_start_proof kind sopt (bl,t) lettop hook =
+  if not(refining ()) then
+    if lettop then
+      errorlabstrm "Vernacentries.StartProof"
+	(str "Let declarations can only be used in proof editing mode");
+  if Lib.is_modtype () then
+    errorlabstrm "Vernacentries.StartProof"
+      (str "Proof editing mode not supported in module types");
+  start_proof_and_print sopt (IsGlobal (Proof kind)) (bl,t) hook
+
+let vernac_end_proof = function
+  | Admitted -> admit ()
+  | Proved (is_opaque,idopt) ->
+    if_verbose show_script ();
+    match idopt with
+    | None -> save_named is_opaque
+    | Some ((_,id),None) -> save_anonymous is_opaque id
+    | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id
+
+  (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
+     the theories [??] *)
+
+let vernac_exact_proof c =
+  by (Tactics.exact_proof c); 
+  save_named true
+
+let vernac_assumption kind l =
+  List.iter (fun (is_coe,(idl,c)) -> declare_assumption idl is_coe kind [] c) l
+
+let vernac_inductive f indl = build_mutual indl f
+
+let vernac_fixpoint = build_recursive
+
+let vernac_cofixpoint = build_corecursive
+
+let vernac_scheme = build_scheme
+
+(**********************)
+(* Modules            *)
+
+let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o = 
+  (* We check the state of the system (in section, in module type)
+     and what module information is supplied *)
+  if Lib.sections_are_opened () then
+    error "Modules and Module Types are not allowed inside sections";
+
+  if not (Lib.is_modtype ()) then
+    error "Declare Module allowed in module types only";
+
+  let constrain_mty = match mty_ast_o with
+      Some (_,true) -> true
+    | _ -> false
+  in
+
+  match mty_ast_o, constrain_mty, mexpr_ast_o with
+    | _, false, None ->  (* no ident, no/soft type *)
+	Declaremods.start_module Modintern.interp_modtype
+	  id binders_ast mty_ast_o;
+	if_verbose message 
+	  ("Interactive Declaration of Module "^ string_of_id id ^" started")
+	  
+    | Some _, true, None           (* no ident, hard type *)
+    | _, false, Some (CMEident _) ->  (* ident, no/soft type *)
+	Declaremods.declare_module 
+	  Modintern.interp_modtype Modintern.interp_modexpr
+	  id binders_ast mty_ast_o mexpr_ast_o;
+	if_verbose message 
+	  ("Module "^ string_of_id id ^" is declared")
+
+    | _, true, Some (CMEident _) -> (* ident, hard type *)
+	error "You cannot declare an equality and a type in module declaration"
+
+    | _, _, Some _ ->    (* not ident *)
+	error "Only simple modules allowed in module declarations"
+
+    | None,true,None -> assert false  (* 1st None ==> false *)
+
+let vernac_define_module id binders_ast mty_ast_o mexpr_ast_o = 
+  (* We check the state of the system (in section, in module type)
+     and what module information is supplied *)
+  if Lib.sections_are_opened () then
+    error "Modules and Module Types are not allowed inside sections";
+ 
+  if Lib.is_modtype () then
+    error "Module definitions not allowed in module types. Use Declare Module instead";
+
+  match mexpr_ast_o with
+    | None ->
+	Declaremods.start_module Modintern.interp_modtype
+	  id binders_ast mty_ast_o;
+	if_verbose message 
+	  ("Interactive Module "^ string_of_id id ^" started")
+	  
+    | Some _ ->
+	Declaremods.declare_module 
+	  Modintern.interp_modtype Modintern.interp_modexpr
+	  id binders_ast mty_ast_o mexpr_ast_o;
+	if_verbose message 
+	  ("Module "^ string_of_id id ^" is defined")
+
+(* let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o =  *)
+(*   (\* We check the state of the system (in section, in module type) *)
+(*      and what module information is supplied *\) *)
+(*   if Lib.sections_are_opened () then *)
+(*     error "Modules and Module Types are not allowed inside sections"; *)
+ 
+(*   let constrain_mty = match mty_ast_o with *)
+(*       Some (_,true) -> true *)
+(*     | _ -> false *)
+(*   in *)
+
+(*   match Lib.is_modtype (), mty_ast_o, constrain_mty, mexpr_ast_o with *)
+(*     | _, None, _, None  *)
+(*     | true, Some _, false, None *)
+(*     | false, _, _, None -> *)
+(* 	Declaremods.start_module Modintern.interp_modtype *)
+(* 	  id binders_ast mty_ast_o; *)
+(* 	if_verbose message  *)
+(* 	  ("Interactive Module "^ string_of_id id ^" started") *)
+	  
+(*     | true, Some _, true, None *)
+(*     | true, _, false, Some (CMEident _) *)
+(*     | false, _, _, Some _ -> *)
+(* 	Declaremods.declare_module  *)
+(* 	  Modintern.interp_modtype Modintern.interp_modexpr *)
+(* 	  id binders_ast mty_ast_o mexpr_ast_o; *)
+(* 	if_verbose message  *)
+(* 	  ("Module "^ string_of_id id ^" is defined") *)
+
+(*     | true, _, _, _ -> *)
+(* 	error "Module definition not allowed in a Module Type" *)
+
+let vernac_end_module id =
+  Declaremods.end_module id;
+  if_verbose message 
+    (if Lib.is_modtype () then 
+       "Module "^ string_of_id id ^" is declared"
+     else
+       "Module "^ string_of_id id ^" is defined")
+
+  
+
+
+let vernac_declare_module_type id binders_ast mty_ast_o =
+  if Lib.sections_are_opened () then
+    error "Modules and Module Types are not allowed inside sections";
+  
+  match mty_ast_o with
+    | None ->
+	Declaremods.start_modtype Modintern.interp_modtype id binders_ast;
+	if_verbose message 
+	  ("Interactive Module Type "^ string_of_id id ^" started")
+	  
+    | Some base_mty ->
+	Declaremods.declare_modtype Modintern.interp_modtype 
+	  id binders_ast base_mty;
+	if_verbose message 
+	  ("Module Type "^ string_of_id id ^" is defined")
+
+
+let vernac_end_modtype id =
+  Declaremods.end_modtype id;
+  if_verbose message 
+    ("Module Type "^ string_of_id id ^" is defined")
+
+
+(**********************)
+(* Gallina extensions *)
+
+let vernac_record struc binders sort nameopt cfs =
+  let const = match nameopt with 
+    | None -> add_prefix "Build_" (snd (snd struc))
+    | Some (_,id) -> id in
+  let sigma = Evd.empty in
+  let env = Global.env() in
+  let s = interp_constr sigma env sort in
+  let s = Reductionops.whd_betadeltaiota env sigma s in
+  let s = match kind_of_term s with
+    | Sort s -> s
+    | _ -> user_err_loc
+        (constr_loc sort,"definition_structure", str "Sort expected") in
+  Record.definition_structure (struc,binders,cfs,const,s)
+
+  (* Sections *)
+
+let vernac_begin_section id = let _ = Lib.open_section id in ()
+
+let vernac_end_section id =
+  Discharge.close_section (is_verbose ()) id
+
+
+let vernac_end_segment id =
+  check_no_pending_proofs ();
+  try
+    match Lib.what_is_opened () with
+      | _,Lib.OpenedModule _ -> vernac_end_module id
+      | _,Lib.OpenedModtype _ -> vernac_end_modtype id
+      | _,Lib.OpenedSection _ -> vernac_end_section id
+      | _ -> anomaly "No more opened things"
+  with
+      Not_found -> error "There is nothing to end."
+
+let is_obsolete_module (_,qid) =
+  match repr_qualid qid with
+  | dir, id when dir = empty_dirpath ->
+      (match string_of_id id with
+	| ("Refine" | "Inv" | "Equality" | "EAuto" | "AutoRewrite"
+	  | "EqDecide" | "Xml" |  "Extraction" | "Tauto" | "Setoid_replace"
+          | "Elimdep" 
+	  | "DatatypesSyntax" | "LogicSyntax" | "Logic_TypeSyntax"
+	  | "SpecifSyntax" | "PeanoSyntax" | "TypeSyntax" | "PolyListSyntax")
+	  -> true
+	| _ -> false)
+  | _ -> false
+
+let test_renamed_module (_,qid) =
+  match repr_qualid qid with
+  | dir, id when dir = empty_dirpath ->
+      (match string_of_id id with
+	| "List" -> warning "List has been renamed into MonoList"
+        | "PolyList" -> warning "PolyList has been renamed into List and old List into MonoList"
+        | _ -> ())
+  | _ -> ()
+
+let vernac_require import _ qidl =
+  let qidl = List.map qualid_of_reference qidl in
+  try
+    match import with
+      | None -> List.iter Library.read_library qidl
+      | Some b -> Library.require_library None qidl b
+  with e ->
+  (* Compatibility message *)
+    let qidl' = List.filter is_obsolete_module qidl in
+    if qidl' = qidl then
+      List.iter
+	(fun (_,qid) ->
+	  warning ("Module "^(string_of_qualid qid)^
+	  " is now built-in and shouldn't be required")) qidl
+    else
+      (if not !Options.v7 then List.iter test_renamed_module qidl;
+       raise e)
+      
+let vernac_import export refl =
+  let import_one ref = 
+    let qid = qualid_of_reference ref in
+      Library.import_library export qid
+  in
+    List.iter import_one refl;
+    Lib.add_frozen_state ()
+
+(*  else
+    let import (loc,qid) = 
+      try
+	let mp = Nametab.locate_module qid in
+	  Declaremods.import_module mp
+      with Not_found ->
+	user_err_loc
+        (loc,"vernac_import",
+	 str ((string_of_qualid qid)^" is not a module"))
+    in
+      List.iter import qidl;
+*)
+
+let vernac_canonical locqid =
+  Recordobj.objdef_declare (Nametab.global locqid)
+
+let locate_reference ref =
+  let (loc,qid) = qualid_of_reference ref in
+  try match Nametab.extended_locate qid with
+    | TrueGlobal ref -> ref
+    | SyntacticDef kn -> 
+	match Syntax_def.search_syntactic_definition loc kn with
+	  | Rawterm.RRef (_,ref) -> ref
+	  | _ -> raise Not_found
+  with Not_found ->
+    error_global_not_found_loc loc qid
+
+let vernac_coercion stre ref qids qidt =
+  let target = cl_of_qualid qidt in
+  let source = cl_of_qualid qids in
+  let ref' = locate_reference ref in
+  Class.try_add_new_coercion_with_target ref' stre source target;
+  if_verbose message ((string_of_reference ref) ^ " is now a coercion")
+
+let vernac_identity_coercion stre id qids qidt =
+  let target = cl_of_qualid qidt in
+  let source = cl_of_qualid qids in
+  Class.try_add_new_identity_coercion id stre source target
+
+
+(***********)
+(* Solving *)
+let vernac_solve n tcom b =
+  if not (refining ()) then
+    error "Unknown command of the non proof-editing mode";
+  begin
+    if b then 
+      solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ()))
+    else solve_nth n (Tacinterp.hide_interp tcom None)
+  end;
+  (* in case a strict subtree was completed, 
+     go back to the top of the prooftree *) 
+  if subtree_solved () then begin
+    Options.if_verbose msgnl (str "Subgoal proved");
+    make_focus 0;
+    reset_top_of_tree ()
+  end;
+  print_subgoals();
+  if !pcoq <> None then (out_some !pcoq).solve n
+
+  (* A command which should be a tactic. It has been
+     added by Christine to patch an error in the design of the proof
+     machine, and enables to instantiate existential variables when
+     there are no more goals to solve. It cannot be a tactic since 
+     all tactics fail if there are no further goals to prove. *)
+  
+let vernac_solve_existential = instantiate_nth_evar_com
+
+let vernac_set_end_tac tac =
+  if not (refining ()) then
+    error "Unknown command of the non proof-editing mode";
+  if tac <> (Tacexpr.TacId "") then set_end_tac (Tacinterp.interp tac)
+(* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
+ 
+   
+(*****************************)
+(* Auxiliary file management *)
+
+let vernac_require_from export spec filename =
+  match export with
+      Some exp ->
+        Library.require_library_from_file spec None filename exp
+    | None -> Library.read_library_from_file filename
+
+let vernac_add_loadpath isrec pdir ldiropt =
+  let alias = match ldiropt with
+    | None -> Nameops.default_root_prefix
+    | Some ldir -> ldir in
+  (if isrec then Mltop.add_rec_path else Mltop.add_path) pdir alias
+
+let vernac_remove_loadpath = Library.remove_path
+
+  (* Coq syntax for ML or system commands *)
+
+let vernac_add_ml_path isrec s =
+  (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (System.glob s)
+
+let vernac_declare_ml_module l = Mltop.declare_ml_modules l
+
+let vernac_chdir = function
+  | None -> message (Sys.getcwd())
+  | Some s ->
+      begin
+	try Sys.chdir (System.glob s)
+	with Sys_error str -> warning ("Cd failed: " ^ str)
+      end;
+      if_verbose message (Sys.getcwd())
+
+
+(********************)
+(* State management *)
+
+let abort_refine f x =
+  if Pfedit.refining() then delete_all_proofs ();
+  f x
+  (* used to be: error "Must save or abort current goal first" *)
+
+let vernac_write_state file = abort_refine States.extern_state file
+
+let vernac_restore_state file = abort_refine States.intern_state file
+
+
+(*************)
+(* Resetting *)
+
+let vernac_reset_name id = abort_refine Lib.reset_name id
+
+let vernac_reset_initial () = abort_refine Lib.reset_initial ()
+
+let vernac_back n = Lib.back n
+
+
+(************)
+(* Commands *)
+
+let vernac_declare_tactic_definition = Tacinterp.add_tacdef
+
+let vernac_hints = Auto.add_hints
+
+let vernac_syntactic_definition = Command.syntax_definition 
+
+let vernac_declare_implicits locqid = function
+  | Some imps -> Impargs.declare_manual_implicits (Nametab.global locqid) imps
+  | None -> Impargs.declare_implicits (Nametab.global locqid)
+
+let vernac_reserve idl c =
+  let t = Constrintern.interp_type Evd.empty (Global.env()) c in
+  let t = Detyping.detype (false,Global.env()) [] [] t in
+  List.iter (fun id -> Reserve.declare_reserved_type id t) idl
+
+let make_silent_if_not_pcoq b =
+  if !pcoq <> None then 
+    error "Turning on/off silent flag is not supported in Centaur mode"
+  else make_silent b
+
+let _ =
+  declare_bool_option 
+    { optsync  = false;
+      optname  = "silent";
+      optkey   = (PrimaryTable "Silent");
+      optread  = is_silent;
+      optwrite = make_silent_if_not_pcoq }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "implicit arguments";
+      optkey   = (SecondaryTable ("Implicit","Arguments"));
+      optread  = Impargs.is_implicit_args;
+      optwrite = Impargs.make_implicit_args }
+
+let impargs = if !Options.v7 then "Implicits" else "Implicit"
+
+let _ =
+  declare_bool_option 
+    { optsync  = false; (* synchronisation is in Impargs *)
+      optname  = "strict implicit arguments";
+      optkey   = (SecondaryTable ("Strict",impargs));
+      optread  = Impargs.is_strict_implicit_args;
+      optwrite = Impargs.make_strict_implicit_args }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "contextual implicit arguments";
+      optkey   = (SecondaryTable ("Contextual",impargs));
+      optread  = Impargs.is_contextual_implicit_args;
+      optwrite = Impargs.make_contextual_implicit_args }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "coercion printing";
+      optkey   = (SecondaryTable ("Printing","Coercions"));
+      optread  = (fun () -> !Constrextern.print_coercions);
+      optwrite = (fun b ->  Constrextern.print_coercions := b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "implicit arguments printing";
+      optkey   = (SecondaryTable ("Printing",impargs));
+      optread  = (fun () -> !Constrextern.print_implicits);
+      optwrite = (fun b ->  Constrextern.print_implicits := b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "projection printing using dot notation";
+      optkey   = (SecondaryTable ("Printing","Projections"));
+      optread  = (fun () -> !Constrextern.print_projections);
+      optwrite = (fun b ->  Constrextern.print_projections := b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "notations printing";
+      optkey   = (SecondaryTable ("Printing",if !Options.v7 then "Symbols" else "Notations"));
+      optread  = (fun () -> not !Constrextern.print_no_symbol);
+      optwrite = (fun b ->  Constrextern.print_no_symbol := not b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "raw printing";
+      optkey   = (SecondaryTable ("Printing","All"));
+      optread  = (fun () -> !Options.raw_print);
+      optwrite = (fun b -> Options.raw_print := b) }
+
+let _ =
+  declare_int_option
+    { optsync=false;
+      optkey=PrimaryTable("Undo");
+      optname="the undo limit";
+      optread=Pfedit.get_undo;
+      optwrite=Pfedit.set_undo }
+
+let _ =
+  declare_int_option
+    { optsync=false;
+      optkey=SecondaryTable("Hyps","Limit");
+      optname="the hypotheses limit";
+      optread=Options.print_hyps_limit;
+      optwrite=Options.set_print_hyps_limit }
+
+let _ =
+  declare_int_option
+    { optsync=true;
+      optkey=SecondaryTable("Printing","Depth");
+      optname="the printing depth";
+      optread=Pp_control.get_depth_boxes;
+      optwrite=Pp_control.set_depth_boxes }
+
+let _ =
+  declare_int_option
+    { optsync=true;
+      optkey=SecondaryTable("Printing","Width");
+      optname="the printing width";
+      optread=Pp_control.get_margin;
+      optwrite=Pp_control.set_margin }
+
+let vernac_set_opacity opaq locqid =
+  match Nametab.global locqid with
+    | ConstRef sp ->
+	if opaq then Tacred.set_opaque_const sp
+	else Tacred.set_transparent_const sp
+    | VarRef id ->
+	if opaq then Tacred.set_opaque_var id
+	else Tacred.set_transparent_var id
+    | _ -> error "cannot set an inductive type or a constructor as transparent"
+
+let vernac_set_option key = function
+  | StringValue s -> set_string_option_value key s
+  | IntValue n -> set_int_option_value key (Some n)
+  | BoolValue b -> set_bool_option_value key b
+
+let vernac_unset_option key =
+  try set_bool_option_value key false
+  with _ ->
+  set_int_option_value key None
+
+let vernac_add_option key lv =
+  let f = function
+    | StringRefValue s -> (get_string_table key)#add s
+    | QualidRefValue locqid -> (get_ref_table key)#add locqid
+  in
+  try List.iter f lv with Not_found -> error_undeclared_key key
+
+let vernac_remove_option key lv =
+  let f = function
+  | StringRefValue s -> (get_string_table key)#remove s
+  | QualidRefValue locqid -> (get_ref_table key)#remove locqid
+  in
+  try List.iter f lv with Not_found -> error_undeclared_key key
+
+let vernac_mem_option key lv =
+  let f = function
+  | StringRefValue s -> (get_string_table key)#mem s
+  | QualidRefValue locqid -> (get_ref_table key)#mem locqid
+  in
+  try List.iter f lv with Not_found -> error_undeclared_key key
+
+let vernac_print_option key =
+  try (get_ref_table key)#print
+  with Not_found ->
+  try (get_string_table key)#print
+  with Not_found ->
+  try print_option_value key
+  with Not_found -> error_undeclared_key key
+
+let get_current_context_of_args = function
+  | Some n -> get_goal_context n
+  | None -> get_current_context ()
+
+let vernac_check_may_eval redexp glopt rc =
+  let (evmap,env) = get_current_context_of_args glopt in
+  let c = interp_constr evmap env rc in
+  let j = Typeops.typing env c in
+  match redexp with
+    | None ->
+	if !pcoq <> None then (out_some !pcoq).print_check j
+	else msg (print_judgment env j)
+    | Some r ->
+	let redfun = Tacred.reduction_of_redexp (interp_redexp env evmap r) in
+	if !pcoq <> None
+	then (out_some !pcoq).print_eval (redfun env evmap) env rc j
+	else msg (print_eval redfun env j)
+
+  (* The same but avoiding the current goal context if any *)
+let vernac_global_check c =
+  let evmap = Evd.empty in
+  let env = Global.env() in
+  let c = interp_constr evmap env c in
+  let senv = Global.safe_env() in
+  let j = Safe_typing.typing senv c in
+  msg (print_safe_judgment env j)
+
+let vernac_print = function
+  | PrintTables -> print_tables ()
+  | PrintLocalContext -> msg (print_local_context ())
+  | PrintFullContext -> msg (print_full_context_typ ())
+  | PrintSectionContext qid -> msg (print_sec_context_typ qid)
+  | PrintInspect n -> msg (inspect n)
+  | PrintGrammar (uni,ent) -> Metasyntax.print_grammar uni ent
+  | PrintLoadPath -> (* For compatibility ? *) print_loadpath ()
+  | PrintModules -> msg (print_modules ())
+  | PrintModule qid -> print_module qid
+  | PrintModuleType qid -> print_modtype qid
+  | PrintMLLoadPath -> Mltop.print_ml_path ()
+  | PrintMLModules -> Mltop.print_ml_modules ()
+  | PrintName qid -> 
+      if !pcoq <> None then (out_some !pcoq).print_name qid
+      else msg (print_name qid)
+  | PrintOpaqueName qid -> msg (print_opaque_name qid)
+  | PrintGraph -> ppnl (Prettyp.print_graph())
+  | PrintClasses -> ppnl (Prettyp.print_classes())
+  | PrintCoercions -> ppnl (Prettyp.print_coercions())
+  | PrintCoercionPaths (cls,clt) ->
+      ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
+  | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ()))
+  | PrintUniverses (Some s) -> dump_universes s
+  | PrintHint qid -> Auto.print_hint_ref (Nametab.global qid)
+  | PrintHintGoal -> Auto.print_applicable_hint ()
+  | PrintHintDbName s -> Auto.print_hint_db_by_name s
+  | PrintHintDb -> Auto.print_searchtable ()
+  | PrintScopes ->
+      pp (Symbols.pr_scopes (Constrextern.without_symbols pr_rawterm))
+  | PrintScope s ->
+      pp (Symbols.pr_scope (Constrextern.without_symbols pr_rawterm) s)
+  | PrintVisibility s ->
+      pp (Symbols.pr_visibility (Constrextern.without_symbols pr_rawterm) s)
+  | PrintAbout qid -> msgnl (print_about qid)
+  | PrintImplicit qid -> msg (print_impargs qid)
+
+let global_module r =
+  let (loc,qid) = qualid_of_reference r in
+  try Nametab.full_name_module qid
+  with Not_found -> 
+    user_err_loc (loc, "global_module",
+      str "Module/section " ++ pr_qualid qid ++ str " not found")
+
+let interp_search_restriction = function
+  | SearchOutside l -> (List.map global_module l, true)
+  | SearchInside l -> (List.map global_module l, false)
+
+open Search
+
+let interp_search_about_item = function
+  | SearchRef qid -> GlobSearchRef (Nametab.global qid)
+  | SearchString s -> GlobSearchString s
+
+let vernac_search s r =
+  let r = interp_search_restriction r in
+  if !pcoq <> None then (out_some !pcoq).search s r else
+  match s with
+  | SearchPattern c ->
+      let _,pat = interp_constrpattern Evd.empty (Global.env()) c in
+      Search.search_pattern pat r
+  | SearchRewrite c ->
+      let _,pat = interp_constrpattern Evd.empty (Global.env()) c in
+      Search.search_rewrite pat r
+  | SearchHead locqid ->
+      Search.search_by_head (Nametab.global locqid) r
+  | SearchAbout sl ->
+      Search.search_about (List.map interp_search_about_item sl) r
+
+let vernac_locate = function
+  | LocateTerm qid -> msgnl (print_located_qualid qid)
+  | LocateLibrary qid -> print_located_library qid
+  | LocateFile f -> locate_file f
+  | LocateNotation ntn ->
+      ppnl (Symbols.locate_notation (Constrextern.without_symbols pr_rawterm)
+	(Metasyntax.standardise_locatable_notation ntn))
+
+(********************)
+(* Proof management *)
+
+let vernac_goal = function
+  | None -> ()
+  | Some c ->
+      if not (refining()) then begin
+        let unnamed_kind = Lemma (* Arbitrary *) in
+        start_proof_com None (IsGlobal (Proof unnamed_kind)) c (fun _ _ ->());
+	print_subgoals ()
+      end else 
+	error "repeated Goal not permitted in refining mode"
+
+let vernac_abort = function
+  | None ->
+      delete_current_proof ();
+      if_verbose message "Current goal aborted";
+      if !pcoq <> None then (out_some !pcoq).abort ""
+  | Some id ->
+      delete_proof id;
+      let s = string_of_id (snd id) in
+      if_verbose message ("Goal "^s^" aborted");
+      if !pcoq <> None then (out_some !pcoq).abort s
+
+let vernac_abort_all () =
+  if refining() then begin
+    delete_all_proofs ();
+    message "Current goals aborted"
+  end else
+    error "No proof-editing in progress"
+
+let vernac_restart () = restart_proof(); print_subgoals ()
+
+  (* Proof switching *)
+
+let vernac_suspend = suspend_proof
+
+let vernac_resume = function
+  | None -> resume_last_proof ()
+  | Some id -> resume_proof id
+
+let vernac_undo n =
+  undo n;
+  print_subgoals ()
+
+  (* Est-ce normal que "Focus" ne semble pas se comporter comme "Focus 1" ? *)
+let vernac_focus = function
+  | None -> traverse_nth_goal 1; print_subgoals ()
+  | Some n -> traverse_nth_goal n; print_subgoals ()
+
+  (* Reset the focus to the top of the tree *)
+let vernac_unfocus () =
+  make_focus 0; reset_top_of_tree (); print_subgoals ()
+
+let vernac_go = function
+  | GoTo n -> Pfedit.traverse n;show_node()
+  | GoTop -> Pfedit.reset_top_of_tree ();show_node()
+  | GoNext -> Pfedit.traverse_next_unproven ();show_node()
+  | GoPrev -> Pfedit.traverse_prev_unproven ();show_node()
+
+let apply_subproof f occ =
+  let pts = get_pftreestate() in
+  let evc = evc_of_pftreestate pts in
+  let rec aux pts = function
+    | [] -> pts
+    | (n::l) -> aux (Tacmach.traverse n pts) occ in 
+  let pts = aux pts (occ@[-1]) in
+  let pf = proof_of_pftreestate pts in
+  f evc (Global.named_context()) pf
+
+let explain_proof occ =
+  msg (apply_subproof (Refiner.print_treescript true) occ)
+
+let explain_tree occ =
+  msg (apply_subproof Refiner.print_proof occ)
+
+let vernac_show = function
+  | ShowGoal nopt ->
+      if !pcoq <> None then (out_some !pcoq).show_goal nopt
+      else msg (match nopt with
+	| None -> pr_open_subgoals ()
+	| Some n -> pr_nth_open_subgoal n)
+  | ShowGoalImplicitly None ->
+      Constrextern.with_implicits msg (pr_open_subgoals ())
+  | ShowGoalImplicitly (Some n) ->
+      Constrextern.with_implicits msg (pr_nth_open_subgoal n)
+  | ShowProof -> show_proof ()
+  | ShowNode -> show_node ()
+  | ShowScript -> show_script ()
+  | ShowExistentials -> show_top_evars ()
+  | ShowTree -> show_prooftree ()
+  | ShowProofNames ->
+      msgnl (prlist_with_sep pr_spc pr_id (Pfedit.get_all_proof_names()))
+  | ShowIntros all -> show_intro all
+  | ExplainProof occ -> explain_proof occ
+  | ExplainTree occ -> explain_tree occ
+
+let vernac_check_guard () =
+  let pts = get_pftreestate () in
+  let pf = proof_of_pftreestate pts 
+  and cursor = cursor_of_pftreestate pts in
+  let (pfterm,_) = extract_open_pftreestate pts in
+  let message = 
+    try 
+      Inductiveops.control_only_guard (Evarutil.evar_env (goal_of_proof pf))
+	pfterm; 
+      (str "The condition holds up to here")
+    with UserError(_,s) -> 
+      (str ("Condition violated : ") ++s)
+  in 
+  msgnl message
+
+let vernac_debug b =
+  set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
+
+
+(**************************)
+(* Not supported commands *)
+(***
+let _ =
+  add "ResetSection"
+    (function 
+       | [VARG_IDENTIFIER id] ->
+	   (fun () -> reset_section (string_of_id id))
+       | _ -> bad_vernac_args "ResetSection")
+
+(* Modules *)
+
+let _ =
+  vinterp_add "BeginModule"
+    (function 
+       | [VARG_IDENTIFIER id] ->
+	   let s = string_of_id id in
+	   let lpe,_ = System.find_file_in_path (Library.get_load_path ()) (s^".v") in
+	   let dir = extend_dirpath (Library.find_logical_path lpe) id in
+	   fun () ->
+	     Lib.start_module dir
+       | _ -> bad_vernac_args "BeginModule")
+
+let _ =
+  vinterp_add "WriteModule"
+    (function 
+       | [VARG_IDENTIFIER id] ->
+	   let mid = Lib.end_module id in
+	   fun () -> let m = string_of_id id in Library.save_module_to mid m
+       | [VARG_IDENTIFIER id; VARG_STRING f] ->
+	   let mid = Lib.end_module id in
+	   fun () -> Library.save_module_to mid f
+       | _ -> bad_vernac_args "WriteModule")
+
+let _ =
+  vinterp_add "CLASS"
+    (function 
+       | [VARG_STRING kind; VARG_QUALID qid] -> 
+	   let stre = 
+	     if kind = "LOCAL" then 
+	       make_strength_0()
+             else 
+	       Nametab.NeverDischarge 
+	   in
+	   fun () -> 
+	     let ref = Nametab.global (dummy_loc, qid) in
+	     Class.try_add_new_class ref stre;
+             if_verbose message
+               ((string_of_qualid qid) ^ " is now a class")
+       | _ -> bad_vernac_args "CLASS")
+
+(* Meta-syntax commands *)
+let _ =
+  add "TOKEN"
+    (function
+       | [VARG_STRING s] -> (fun () -> Metasyntax.add_token_obj s)
+       | _ -> bad_vernac_args "TOKEN")
+***)
+
+(* Search commands *)
+
+(***
+let _ =
+  add "Searchisos"
+  (function
+     | [VARG_CONSTR com] -> 
+	 (fun () ->
+	    let env = Global.env() in
+	    let c = constr_of_com Evd.empty env com in
+	    let cc = nf_betaiota env Evd.empty c in
+            Searchisos.type_search cc)
+     | _ -> bad_vernac_args "Searchisos")
+***)
+
+let interp c = match c with
+  (* Control (done in vernac) *)
+  | (VernacTime _ | VernacVar _ | VernacList _ | VernacLoad _) -> assert false
+  | (VernacV7only _ | VernacV8only _) -> assert false
+
+  (* Syntax *)
+  | VernacSyntax (whatfor,sel) -> vernac_syntax whatfor sel
+  | VernacTacticGrammar al -> Metasyntax.add_tactic_grammar al
+  | VernacGrammar (univ,al) -> vernac_grammar univ al
+  | VernacSyntaxExtension (lcl,sl,l8) -> vernac_syntax_extension lcl sl l8
+  | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr
+  | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl
+  | VernacOpenCloseScope sc -> vernac_open_close_scope sc
+  | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope qid scl
+  | VernacInfix (local,mv,qid,mv8,sc) -> vernac_infix local mv qid mv8 sc
+  | VernacDistfix (local,assoc,n,inf,qid,sc) -> 
+      vernac_distfix local assoc n inf qid sc
+  | VernacNotation (local,c,infpl,mv8,sc) ->
+      vernac_notation local c infpl mv8 sc
+
+  (* Gallina *)
+  | VernacDefinition (k,(_,id),d,f) -> vernac_definition k id d f
+  | VernacStartTheoremProof (k,(_,id),t,top,f) ->
+      vernac_start_proof k (Some id) t top f
+  | VernacEndProof e -> vernac_end_proof e
+  | VernacExactProof c -> vernac_exact_proof c
+  | VernacAssumption (stre,l) -> vernac_assumption stre l
+  | VernacInductive (finite,l) -> vernac_inductive finite l
+  | VernacFixpoint l -> vernac_fixpoint l
+  | VernacCoFixpoint l -> vernac_cofixpoint l
+  | VernacScheme l -> vernac_scheme l
+
+  (* Modules *)
+  | VernacDeclareModule ((_,id),bl,mtyo,mexpro) -> 
+      vernac_declare_module id bl mtyo mexpro
+  | VernacDefineModule ((_,id),bl,mtyo,mexpro) -> 
+      vernac_define_module id bl mtyo mexpro
+  | VernacDeclareModuleType ((_,id),bl,mtyo) -> 
+      vernac_declare_module_type id bl mtyo
+
+  (* Gallina extensions *)
+  | VernacBeginSection (_,id) -> vernac_begin_section id
+
+  | VernacEndSegment (_,id) -> vernac_end_segment id
+
+  | VernacRecord (_,id,bl,s,idopt,fs) -> vernac_record id bl s idopt fs
+  | VernacRequire (export,spec,qidl) -> vernac_require export spec qidl
+  | VernacImport (export,qidl) -> vernac_import export qidl
+  | VernacCanonical qid -> vernac_canonical qid
+  | VernacCoercion (str,r,s,t) -> vernac_coercion str r s t
+  | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t
+
+  (* Solving *)
+  | VernacSolve (n,tac,b) -> vernac_solve n tac b
+  | VernacSolveExistential (n,c) -> vernac_solve_existential n c
+
+  (* Auxiliary file and library management *)
+  | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f
+  | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
+  | VernacRemoveLoadPath s -> vernac_remove_loadpath s
+  | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s
+  | VernacDeclareMLModule l -> vernac_declare_ml_module l
+  | VernacChdir s -> vernac_chdir s
+
+  (* State management *)
+  | VernacWriteState s -> vernac_write_state s
+  | VernacRestoreState s -> vernac_restore_state s
+
+  (* Resetting *)
+  | VernacResetName id -> vernac_reset_name id
+  | VernacResetInitial -> vernac_reset_initial ()
+  | VernacBack n -> vernac_back n
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition (x,l) -> vernac_declare_tactic_definition x l
+  | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints
+  | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b
+  | VernacDeclareImplicits (qid,l) -> vernac_declare_implicits qid l
+  | VernacReserve (idl,c) -> vernac_reserve idl c
+  | VernacSetOpacity (opaq, qidl) -> List.iter (vernac_set_opacity opaq) qidl
+  | VernacSetOption (key,v) -> vernac_set_option key v
+  | VernacUnsetOption key -> vernac_unset_option key
+  | VernacRemoveOption (key,v) -> vernac_remove_option key v
+  | VernacAddOption (key,v) -> vernac_add_option key v
+  | VernacMemOption (key,v) -> vernac_mem_option key v
+  | VernacPrintOption key -> vernac_print_option key
+  | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c
+  | VernacGlobalCheck c -> vernac_global_check c
+  | VernacPrint p -> vernac_print p
+  | VernacSearch (s,r) -> vernac_search s r
+  | VernacLocate l -> vernac_locate l
+  | VernacComments l -> if_verbose message ("Comments ok\n")
+  | VernacNop -> ()
+
+  (* Proof management *)
+  | VernacGoal t -> vernac_start_proof Theorem None ([],t) false (fun _ _ ->())
+  | VernacAbort id -> vernac_abort id
+  | VernacAbortAll -> vernac_abort_all ()
+  | VernacRestart -> vernac_restart ()
+  | VernacSuspend -> vernac_suspend ()
+  | VernacResume id -> vernac_resume id
+  | VernacUndo n -> vernac_undo n
+  | VernacFocus n -> vernac_focus n
+  | VernacUnfocus -> vernac_unfocus ()
+  | VernacGo g -> vernac_go g
+  | VernacShow s -> vernac_show s
+  | VernacCheckGuard -> vernac_check_guard ()
+  | VernacDebug b -> vernac_debug b
+  | VernacProof tac -> vernac_set_end_tac tac
+  (* Toplevel control *)
+  | VernacToplevelControl e -> raise e
+
+  (* Extensions *)
+  | VernacExtend (opn,args) -> Vernacinterp.call (opn,args)
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
new file mode 100644
index 00000000..a359b4a1
--- /dev/null
+++ b/toplevel/vernacentries.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: vernacentries.mli,v 1.16.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Vernacinterp
+open Vernacexpr
+open Topconstr
+(*i*)
+
+(* Vernacular entries *)
+
+val show_script : unit -> unit
+val show_prooftree : unit -> unit
+
+val show_node : unit -> unit
+
+(* This function can be used by any command that want to observe terms
+   in the context of the current goal, as for instance in pcoq *)
+val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
+
+(* this function is used to analyse the extra arguments in search commands.
+   It is used in pcoq. *) (*i anciennement: inside_outside i*)
+(*
+val interp_search_restriction : search_restriction -> dir_path list * bool
+*)
+
+type pcoq_hook = {
+  start_proof : unit -> unit;
+  solve : int -> unit;
+  abort : string -> unit;
+  search : searchable -> dir_path list * bool -> unit;
+  print_name : Libnames.reference -> unit;
+  print_check : Environ.unsafe_judgment -> unit;
+  print_eval : (constr -> constr) -> Environ.env -> constr_expr -> Environ.unsafe_judgment -> unit;
+  show_goal : int option -> unit
+}
+
+val set_pcoq_hook : pcoq_hook -> unit
+
+(* This function makes sure that the function given is argument is preceded
+   by a command aborting all proofs if necessary.
+   It is used in pcoq. *)
+val abort_refine : ('a -> unit) -> 'a -> unit;;
+
+val interp : Vernacexpr.vernac_expr -> unit
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
new file mode 100644
index 00000000..e1525c17
--- /dev/null
+++ b/toplevel/vernacexpr.ml
@@ -0,0 +1,293 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: vernacexpr.ml,v 1.55.2.1 2004/07/16 19:31:50 herbelin Exp $ *)
+
+open Util
+open Names
+open Tacexpr
+open Extend
+open Genarg
+open Topconstr
+open Decl_kinds
+open Ppextend
+
+(* Toplevel control exceptions *)
+exception ProtectedLoop
+exception Drop
+exception Quit
+
+open Libnames
+open Nametab
+
+type lident = identifier located
+type lname = name located
+type lstring = string
+type lreference = reference
+
+type class_rawexpr = FunClass | SortClass | RefClass of reference
+  
+type printable =
+  | PrintTables
+  | PrintLocalContext
+  | PrintFullContext
+  | PrintSectionContext of reference
+  | PrintInspect of int
+  | PrintGrammar of string * string
+  | PrintLoadPath
+  | PrintModules
+  | PrintModule of reference
+  | PrintModuleType of reference
+  | PrintMLLoadPath
+  | PrintMLModules
+  | PrintName of reference
+  | PrintOpaqueName of reference
+  | PrintGraph
+  | PrintClasses
+  | PrintCoercions
+  | PrintCoercionPaths of class_rawexpr * class_rawexpr
+  | PrintUniverses of string option
+  | PrintHint of reference
+  | PrintHintGoal
+  | PrintHintDbName of string
+  | PrintHintDb
+  | PrintScopes
+  | PrintScope of string
+  | PrintVisibility of string option
+  | PrintAbout of reference
+  | PrintImplicit of reference
+
+type search_about_item =
+  | SearchRef of reference
+  | SearchString of string
+
+type searchable =
+  | SearchPattern of pattern_expr
+  | SearchRewrite of pattern_expr
+  | SearchHead of reference
+  | SearchAbout of search_about_item list
+
+type locatable =
+  | LocateTerm of reference
+  | LocateLibrary of reference
+  | LocateFile of string
+  | LocateNotation of notation
+
+type goable =
+  | GoTo of int
+  | GoTop
+  | GoNext
+  | GoPrev
+
+type showable =
+  | ShowGoal of int option
+  | ShowGoalImplicitly of int option
+  | ShowProof
+  | ShowNode
+  | ShowScript
+  | ShowExistentials
+  | ShowTree
+  | ShowProofNames
+  | ShowIntros of bool
+  | ExplainProof of int list
+  | ExplainTree of int list
+
+type comment =
+  | CommentConstr of constr_expr
+  | CommentString of string
+  | CommentInt of int
+
+type hints =
+  | HintsResolve of (identifier option * constr_expr) list
+  | HintsImmediate of (identifier option * constr_expr) list
+  | HintsUnfold of (identifier option * reference) list
+  | HintsConstructors of identifier option * reference list
+  | HintsExtern of identifier option * int * constr_expr * raw_tactic_expr
+  | HintsDestruct of identifier *
+      int * (bool,unit) location * constr_expr * raw_tactic_expr
+
+type search_restriction =
+  | SearchInside of reference list
+  | SearchOutside of reference list
+
+type option_value =
+  | StringValue of string
+  | IntValue of int
+  | BoolValue of bool
+
+type option_ref_value =
+  | StringRefValue of string
+  | QualidRefValue of reference
+
+type rec_flag       = bool (* true = Rec;           false = NoRec          *)
+type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
+type opacity_flag   = bool (* true = Opaque;        false = Transparent    *)
+type locality_flag  = bool (* true = Local;         false = Global         *)
+type coercion_flag  = bool (* true = AddCoercion;   false = NoCoercion     *)
+type export_flag    = bool (* true = Export;        false = Import         *)
+type specif_flag    = bool (* true = Specification; false = Implementation *)
+type inductive_flag = bool (* true = Inductive;     false = CoInductive    *)
+type onlyparsing_flag = bool (* true = Parse only;  false = Print also     *)
+
+type sort_expr = Rawterm.rawsort
+
+type decl_notation = (string * constr_expr * scope_name option) option
+type simple_binder = lident list  * constr_expr
+type 'a with_coercion = coercion_flag * 'a
+type constructor_expr = (lident * constr_expr) with_coercion
+type inductive_expr =
+     lident * decl_notation * local_binder list * constr_expr
+    * constructor_expr list
+type definition_expr =
+  | ProveBody of local_binder list * constr_expr
+  | DefineBody of local_binder list * raw_red_expr option * constr_expr
+      * constr_expr option
+
+type local_decl_expr =
+  | AssumExpr of lname * constr_expr
+  | DefExpr of lname * constr_expr * constr_expr option
+
+type module_binder = lident list * module_type_ast
+
+type proof_end =
+  | Admitted
+  | Proved of opacity_flag * (lident * theorem_kind option) option
+
+type vernac_expr =
+  (* Control *)
+  | VernacList of located_vernac_expr list
+  | VernacLoad of verbose_flag * lstring
+  | VernacTime of vernac_expr
+  | VernacVar of lident
+
+  (* Syntax *) 
+  | VernacGrammar of lstring * raw_grammar_entry list
+  | VernacTacticGrammar of
+      (lstring * (lstring * grammar_production list) * raw_tactic_expr) list
+  | VernacSyntax of lstring * raw_syntax_entry list
+  | VernacSyntaxExtension of locality_flag *
+      (lstring * syntax_modifier list) option 
+      * (lstring * syntax_modifier list) option
+  | VernacDistfix of locality_flag *
+      grammar_associativity * precedence * lstring * lreference *
+      scope_name option
+  | VernacOpenCloseScope of (locality_flag * bool * scope_name)
+  | VernacDelimiters of scope_name * lstring
+  | VernacBindScope of scope_name * class_rawexpr list
+  | VernacArgumentsScope of lreference * scope_name option list
+  | VernacInfix of locality_flag * (lstring * syntax_modifier list) *
+      lreference * (lstring * syntax_modifier list) option * scope_name option
+  | VernacNotation of
+      locality_flag * constr_expr * (lstring * syntax_modifier list) option *
+      (lstring * syntax_modifier list) option * scope_name option
+
+  (* Gallina *)
+  | VernacDefinition of definition_kind * lident * definition_expr * 
+      declaration_hook
+  | VernacStartTheoremProof of theorem_kind * lident *
+      (local_binder list * constr_expr) * bool * declaration_hook
+  | VernacEndProof of proof_end
+  | VernacExactProof of constr_expr
+  | VernacAssumption of assumption_kind * simple_binder with_coercion list
+  | VernacInductive of inductive_flag * inductive_expr list
+  | VernacFixpoint of (fixpoint_expr * decl_notation) list
+  | VernacCoFixpoint of cofixpoint_expr list
+  | VernacScheme of (lident * bool * lreference * sort_expr) list
+
+  (* Gallina extensions *)
+  | VernacRecord of bool (* = Record or Structure *)
+      * lident with_coercion * local_binder list
+      * constr_expr * lident option * local_decl_expr with_coercion list
+  | VernacBeginSection of lident
+  | VernacEndSegment of lident
+  | VernacRequire of
+      export_flag option * specif_flag option * lreference list
+  | VernacImport of export_flag * lreference list
+  | VernacCanonical of lreference
+  | VernacCoercion of strength * lreference * class_rawexpr * class_rawexpr
+  | VernacIdentityCoercion of strength * lident * 
+      class_rawexpr * class_rawexpr
+
+  (* Modules and Module Types *)
+  | VernacDeclareModule of lident * 
+      module_binder list * (module_type_ast * bool) option * module_ast option
+  | VernacDefineModule of lident * 
+      module_binder list * (module_type_ast * bool) option * module_ast option
+  | VernacDeclareModuleType of lident * 
+      module_binder list * module_type_ast option
+
+  (* Solving *)
+  | VernacSolve of int * raw_tactic_expr * bool
+  | VernacSolveExistential of int * constr_expr
+
+  (* Auxiliary file and library management *)
+  | VernacRequireFrom of export_flag option * specif_flag option * lstring
+  | VernacAddLoadPath of rec_flag * lstring * dir_path option
+  | VernacRemoveLoadPath of lstring
+  | VernacAddMLPath of rec_flag * lstring
+  | VernacDeclareMLModule of lstring list
+  | VernacChdir of lstring option
+
+  (* State management *)
+  | VernacWriteState of lstring
+  | VernacRestoreState of lstring
+
+  (* Resetting *)
+  | VernacResetName of lident
+  | VernacResetInitial
+  | VernacBack of int
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition of
+      rec_flag * (lident * raw_tactic_expr) list
+  | VernacHints of locality_flag * lstring list * hints
+  | VernacSyntacticDefinition of identifier * constr_expr * locality_flag *
+      onlyparsing_flag
+  | VernacDeclareImplicits of lreference * explicitation list option
+  | VernacReserve of lident list * constr_expr
+  | VernacSetOpacity of opacity_flag * lreference list
+  | VernacUnsetOption of Goptions.option_name
+  | VernacSetOption of Goptions.option_name * option_value
+  | VernacAddOption of Goptions.option_name * option_ref_value list
+  | VernacRemoveOption of Goptions.option_name * option_ref_value list
+  | VernacMemOption of Goptions.option_name * option_ref_value list
+  | VernacPrintOption of Goptions.option_name
+  | VernacCheckMayEval of raw_red_expr option * int option * constr_expr
+  | VernacGlobalCheck of constr_expr
+  | VernacPrint of printable
+  | VernacSearch of searchable * search_restriction
+  | VernacLocate of locatable
+  | VernacComments of comment list
+  | VernacNop
+
+  (* Proof management *)
+  | VernacGoal of constr_expr
+  | VernacAbort of lident option
+  | VernacAbortAll
+  | VernacRestart
+  | VernacSuspend
+  | VernacResume of lident option
+  | VernacUndo of int
+  | VernacFocus of int option
+  | VernacUnfocus
+  | VernacGo of goable
+  | VernacShow of showable
+  | VernacCheckGuard
+  | VernacDebug of bool
+  | VernacProof of raw_tactic_expr
+  (* Toplevel control *)
+  | VernacToplevelControl of exn
+
+  (* For translation from V7 to V8 syntax *)
+  | VernacV8only of vernac_expr
+  | VernacV7only of vernac_expr
+
+  (* For extension *)
+  | VernacExtend of string * raw_generic_argument list
+
+and located_vernac_expr = loc * vernac_expr
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
new file mode 100644
index 00000000..c7846d71
--- /dev/null
+++ b/toplevel/vernacinterp.ml
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: vernacinterp.ml,v 1.17.8.1 2004/07/16 19:31:50 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Himsg
+open Proof_type
+open Tacinterp
+open Coqast
+open Vernacexpr
+open Ast
+open Extend
+
+let disable_drop e =
+  if e <> Drop then e
+  else UserError("Vernac.disable_drop",(str"Drop is forbidden."))
+
+(* Table of vernac entries *)
+let vernac_tab =
+  (Hashtbl.create 51 :
+    (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t)
+
+let vinterp_add s f =
+  try 
+    Hashtbl.add vernac_tab s f
+  with Failure _ ->
+    errorlabstrm "vinterp_add"
+      (str"Cannot add the vernac command " ++ str s ++ str" twice")
+
+let overwriting_vinterp_add s f =
+  begin 
+    try 
+      let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s 
+    with Not_found -> ()
+  end;
+  Hashtbl.add vernac_tab s f
+
+let vinterp_map s =
+  try 
+    Hashtbl.find vernac_tab s
+  with Not_found -> 
+    errorlabstrm "Vernac Interpreter"
+      (str"Cannot find vernac command " ++ str s)
+
+let vinterp_init () = Hashtbl.clear vernac_tab
+
+(* Interpretation of a vernac command *)
+
+let call (opn,converted_args) =
+  let loc = ref "Looking up command" in
+  try
+    let callback = vinterp_map opn in
+    loc:= "Checking arguments";
+    let hunk = callback converted_args in
+    loc:= "Executing command";
+    hunk()
+  with
+    | Drop -> raise Drop
+    | ProtectedLoop -> raise ProtectedLoop
+    | e ->
+        if !Options.debug then
+	  msgnl (str"Vernac Interpreter " ++ str !loc);
+        raise e
+
+let bad_vernac_args s =
+  anomalylabstrm s
+    (str"Vernac " ++ str s ++ str" called with bad arguments")
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
new file mode 100644
index 00000000..86b80935
--- /dev/null
+++ b/toplevel/vernacinterp.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: vernacinterp.mli,v 1.11.10.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*i*)
+open Tacexpr
+(*i*)
+
+(* Interpretation of extended vernac phrases. *)
+ 
+val disable_drop : exn -> exn
+
+val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit
+val overwriting_vinterp_add : 
+  string -> (raw_generic_argument list -> unit -> unit) -> unit
+
+val vinterp_init : unit -> unit
+val call : string * raw_generic_argument list -> unit