Imported Upstream version 8.0pl1upstream/8.0pl1

58 files changed, 13984 insertions, 0 deletions

diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
new file mode 100644
index 00000000..5fa781ad
--- /dev/null
+++ b/parsing/argextend.ml4
@@ -0,0 +1,289 @@
+(************************************************************************)
+(*  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: argextend.ml4,v 1.9.2.2 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Genarg
+open Q_util
+open Q_coqast
+open Ast
+
+let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
+let loc = Util.dummy_loc
+let default_loc = <:expr< Util.dummy_loc >>
+
+let rec make_rawwit loc = function
+  | BoolArgType -> <:expr< Genarg.rawwit_bool >>
+  | IntArgType -> <:expr< Genarg.rawwit_int >>
+  | IntOrVarArgType -> <:expr< Genarg.rawwit_int_or_var >>
+  | StringArgType -> <:expr< Genarg.rawwit_string >>
+  | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >>
+  | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >>
+  | IdentArgType -> <:expr< Genarg.rawwit_ident >>
+  | HypArgType -> <:expr< Genarg.rawwit_var >>
+  | RefArgType -> <:expr< Genarg.rawwit_ref >>
+  | SortArgType -> <:expr< Genarg.rawwit_sort >>
+  | ConstrArgType -> <:expr< Genarg.rawwit_constr >>
+  | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >>
+  | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >>
+  | TacticArgType -> <:expr< Genarg.rawwit_tactic >>
+  | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >>
+  | CastedOpenConstrArgType -> <:expr< Genarg.rawwit_casted_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Genarg.rawwit_bindings >>
+  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >>
+  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_rawwit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >>
+  | PairArgType (t1,t2) -> 
+      <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >>
+  | ExtraArgType s -> <:expr< $lid:"rawwit_"^s$ >>
+
+let rec make_globwit loc = function
+  | BoolArgType -> <:expr< Genarg.globwit_bool >>
+  | IntArgType -> <:expr< Genarg.globwit_int >>
+  | IntOrVarArgType -> <:expr< Genarg.globwit_int_or_var >>
+  | StringArgType -> <:expr< Genarg.globwit_string >>
+  | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >>
+  | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >>
+  | IdentArgType -> <:expr< Genarg.globwit_ident >>
+  | HypArgType -> <:expr< Genarg.globwit_var >>
+  | RefArgType -> <:expr< Genarg.globwit_ref >>
+  | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >>
+  | SortArgType -> <:expr< Genarg.globwit_sort >>
+  | ConstrArgType -> <:expr< Genarg.globwit_constr >>
+  | ConstrMayEvalArgType -> <:expr< Genarg.globwit_constr_may_eval >>
+  | TacticArgType -> <:expr< Genarg.globwit_tactic >>
+  | RedExprArgType -> <:expr< Genarg.globwit_red_expr >>
+  | CastedOpenConstrArgType -> <:expr< Genarg.globwit_casted_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Genarg.globwit_bindings >>
+  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >>
+  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_globwit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >>
+  | PairArgType (t1,t2) -> 
+      <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >>
+  | ExtraArgType s -> <:expr< $lid:"globwit_"^s$ >>
+
+let rec make_wit loc = function
+  | BoolArgType -> <:expr< Genarg.wit_bool >>
+  | IntArgType -> <:expr< Genarg.wit_int >>
+  | IntOrVarArgType -> <:expr< Genarg.wit_int_or_var >>
+  | StringArgType -> <:expr< Genarg.wit_string >>
+  | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >>
+  | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >>
+  | IdentArgType -> <:expr< Genarg.wit_ident >>
+  | HypArgType -> <:expr< Genarg.wit_var >>
+  | RefArgType -> <:expr< Genarg.wit_ref >>
+  | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >>
+  | SortArgType -> <:expr< Genarg.wit_sort >>
+  | ConstrArgType -> <:expr< Genarg.wit_constr >>
+  | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >>
+  | TacticArgType -> <:expr< Genarg.wit_tactic >>
+  | RedExprArgType -> <:expr< Genarg.wit_red_expr >>
+  | CastedOpenConstrArgType -> <:expr< Genarg.wit_casted_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Genarg.wit_bindings >>
+  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >>
+  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_wit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >>
+  | PairArgType (t1,t2) -> 
+      <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >>
+  | ExtraArgType s -> <:expr< $lid:"wit_"^s$ >>
+
+let make_act loc act pil =
+  let rec make = function
+    | [] -> <:expr< Gramext.action (fun loc -> ($act$ : 'a)) >>
+    | None :: tl -> <:expr< Gramext.action (fun _ -> $make tl$) >>
+    | Some (p, t) :: tl ->
+	<:expr<
+          Gramext.action 
+            (fun $lid:p$ -> let _ = in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
+        >> in
+  make (List.rev pil)
+
+let make_rule loc (prods,act) =
+  let (symbs,pil) = List.split prods in
+  <:expr< ($mlexpr_of_list (fun x -> x) symbs$,$make_act loc act pil$) >>
+
+let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl =
+  let interp = match f with
+    | None -> <:expr< Tacinterp.interp_genarg >>
+    | Some f -> <:expr< $lid:f$>> in
+  let glob = match g with
+    | None -> <:expr< Tacinterp.intern_genarg >>
+    | Some f -> <:expr< $lid:f$>> in
+  let substitute = match h with
+    | None -> <:expr< Tacinterp.subst_genarg >>
+    | Some f -> <:expr< $lid:f$>> in
+  let rawtyp, rawpr = match rawtyppr with
+    | None -> typ,pr
+    | Some (t,p) -> t,p in
+  let globtyp, globpr = match globtyppr with
+    | None -> typ,pr
+    | Some (t,p) -> t,p in
+  let se = mlexpr_of_string s in
+  let wit = <:expr< $lid:"wit_"^s$ >> in
+  let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
+  let globwit = <:expr< $lid:"globwit_"^s$ >> in
+  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
+  <:str_item<
+    declare
+      value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
+        Genarg.create_arg $se$;
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
+      Tacinterp.add_interp_genarg $se$
+        ((fun e x ->
+          (in_gen $globwit$
+             (out_gen $make_globwit loc typ$
+          	($glob$ e
+         	  (in_gen $make_rawwit loc rawtyp$
+	             (out_gen $rawwit$ x)))))),
+        (fun ist gl x ->
+          (in_gen $wit$
+             (out_gen $make_wit loc typ$
+          	($interp$ ist gl
+         	  (in_gen $make_globwit loc rawtyp$
+	             (out_gen $globwit$ x)))))),
+        (fun subst x ->
+          (in_gen $globwit$
+             (out_gen $make_globwit loc typ$
+          	($substitute$ subst
+         	  (in_gen $make_globwit loc rawtyp$
+	             (out_gen $globwit$ x)))))));
+      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None 
+        [(None, None, $rules$)];
+      Pptactic.declare_extra_genarg_pprule
+        $mlexpr_of_bool for_v8$
+        ($rawwit$, $lid:rawpr$)
+        ($globwit$, $lid:globpr$)
+        ($wit$, $lid:pr$);
+    end
+  >>
+
+let declare_vernac_argument for_v8 loc s cl =
+  let se = mlexpr_of_string s in
+  let typ = ExtraArgType s in
+  let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
+  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
+  <:str_item<
+    declare
+      value $lid:"rawwit_"^s$ = let (_,_,x) = Genarg.create_arg $se$ in x;
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
+      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None 
+        [(None, None, $rules$)];
+    end
+  >>
+
+open Vernacexpr
+open Pcoq
+
+let rec interp_entry_name loc s =
+  let l = String.length s in
+  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
+    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
+  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
+    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
+  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
+    OptArgType t, <:expr< Gramext.Sopt $g$ >>
+  else 
+    let t, se =
+      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
+	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
+	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
+	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
+	| None -> None, <:expr< $lid:s$ >> in
+    let t =
+      match t with
+	| Some t -> t
+	| None ->
+(*	    Pp.warning_with Pp_control.err_ft
+            ("Unknown primitive grammar entry: "^s);*)
+	    ExtraArgType s
+    in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
+
+open Pcaml
+
+EXTEND
+  GLOBAL: str_item;
+  str_item:
+    [ [ "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
+        "TYPED"; "AS"; typ = argtype;
+        "PRINTED"; "BY"; pr = LIDENT;
+        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
+        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
+        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
+        rawtyppr =
+        (* Necessary if the globalized type is different from the final type *)
+          OPT [ "RAW_TYPED"; "AS"; t = argtype; 
+                "RAW_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
+        globtyppr =
+          OPT [ "GLOB_TYPED"; "AS"; t = argtype; 
+                "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
+        OPT "|"; l = LIST1 argrule SEP "|";
+        "END" ->
+	  if String.capitalize s = s then
+	    failwith "Argument entry names must be lowercase";
+         declare_tactic_argument true loc s typ pr f g h rawtyppr globtyppr l
+      | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
+        OPT "|"; l = LIST1 argrule SEP "|";
+        "END" ->
+	  if String.capitalize s = s then
+	    failwith "Argument entry names must be lowercase";
+         declare_vernac_argument true loc s l
+      | "V7"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
+        "TYPED"; "AS"; typ = argtype;
+        "PRINTED"; "BY"; pr = LIDENT;
+        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
+        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
+        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
+        rawtyppr =
+          OPT [ "GLOB_TYPED"; "AS"; t = argtype; 
+                "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
+        globtyppr =
+          OPT [ "GLOB_TYPED"; "AS"; t = argtype; 
+                "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
+        OPT "|"; l = LIST1 argrule SEP "|";
+        "END" ->
+	  if String.capitalize s = s then
+	    failwith "Argument entry names must be lowercase";
+         declare_tactic_argument false loc s typ pr f g h rawtyppr globtyppr l
+      | "V7"; "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
+        OPT "|"; l = LIST1 argrule SEP "|";
+        "END" ->
+	  if String.capitalize s = s then
+	    failwith "Argument entry names must be lowercase";
+         declare_vernac_argument false loc s l ] ]
+  ;
+  argtype:
+    [ [ e = LIDENT -> fst (interp_entry_name loc e) 
+      | e1 = LIDENT; "*"; e2 = LIDENT ->
+          let e1 = fst (interp_entry_name loc e1) in
+          let e2 = fst (interp_entry_name loc e2) in
+          PairArgType (e1, e2) ] ]
+  ;
+  argrule:
+    [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ]
+  ;
+  genarg:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name loc e in (g, Some (s,t))
+      | s = STRING ->
+	  if String.length s > 0 && Util.is_letter s.[0] then
+	    Pcoq.lexer.Token.using ("", s);
+        (<:expr< (Gramext.Stoken (Extend.terminal $str:s$)) >>, None)
+    ] ]
+  ;
+  END
+
diff --git a/parsing/ast.ml b/parsing/ast.ml
new file mode 100755
index 00000000..b2a30f9c
--- /dev/null
+++ b/parsing/ast.ml
@@ -0,0 +1,600 @@
+(************************************************************************)
+(*  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: ast.ml,v 1.29.2.1 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Coqast
+open Topconstr
+open Genarg
+
+let isMeta s = String.length s <> 0 & s.[0]='$'
+
+let loc = function
+  | Node (loc,_,_) -> loc
+  | Nvar (loc,_) -> loc
+  | Nmeta (loc,_) -> loc
+  | Slam (loc,_,_) -> loc
+  | Smetalam (loc,_,_) -> loc
+  | Num (loc,_) -> loc
+  | Id (loc,_) -> loc
+  | Str (loc,_) -> loc
+  | Path (loc,_) -> loc
+  | Dynamic (loc,_) -> loc
+
+(* patterns of ast *)
+type astpat =
+  | Pquote of t
+  | Pmeta of string * tok_kind
+  | Pnode of string * patlist
+  | Pslam of identifier option * astpat
+  | Pmeta_slam of string * astpat
+
+and patlist =
+  | Pcons of astpat * patlist
+  | Plmeta of string
+  | Pnil
+
+and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist
+
+type pat =
+  | AstListPat of patlist
+  | PureAstPat of astpat
+
+(* building a node with dummy location *)
+
+let ope(op,l) = Node(dummy_loc,op,l)
+let slam(idl,b) = Slam(dummy_loc,idl,b)
+let ide s = Id(dummy_loc,s)
+let nvar s = Nvar(dummy_loc,s)
+let num n = Num(dummy_loc,n)
+let string s = Str(dummy_loc,s)
+let path sl = Path(dummy_loc,sl)
+let dynamic d = Dynamic(dummy_loc,d)
+
+let rec set_loc loc = function
+  | Node(_,op,al) -> Node(loc, op, List.map (set_loc loc) al)
+  | Slam(_,idl,b) -> Slam(loc,idl, set_loc loc b)
+  | Smetalam(_,idl,b) -> Smetalam(loc,idl, set_loc loc b)
+  | Nvar(_,s) -> Nvar(loc,s)
+  | Nmeta(_,s) -> Nmeta(loc,s)
+  | Id(_,s) -> Id(loc,s)
+  | Str(_,s) -> Str(loc,s)
+  | Num(_,s) -> Num(loc,s)
+  | Path(_,sl) -> Path(loc,sl)
+  | Dynamic(_,d) -> Dynamic(loc,d)
+
+let path_section loc sp = Coqast.Path(loc, sp)
+
+let section_path sp = sp
+
+(* ast destructors *)
+let num_of_ast = function
+  | Num(_,n) -> n
+  | ast -> invalid_arg_loc (loc ast, "Ast.num_of_ast")
+
+let nvar_of_ast = function
+  | Nvar(_,s) -> s
+  | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast")
+
+let meta_of_ast = function
+  | Nmeta(_,s) -> s
+  | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast")
+
+let id_of_ast =  function
+  | Id(_,s) -> s
+  | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast")
+
+(* semantic actions of grammar rules *)
+type act =
+  | Act of constr_expr
+  | ActCase of act * (pat * act) list
+  | ActCaseList of act * (pat * act) list
+
+(* values associated to variables *)
+(*
+type typed_ast =
+  | AstListNode of Coqast.t list
+  | PureAstNode of Coqast.t
+*)
+type typed_ast =
+  | AstListNode of Coqast.t list
+  | PureAstNode of Coqast.t
+
+type ast_action_type = ETast | ETastl
+
+type dynamic_grammar =
+  | ConstrNode of constr_expr
+  | CasesPatternNode of cases_pattern_expr
+
+type grammar_action =
+  | SimpleAction of loc * dynamic_grammar
+  | CaseAction of
+      loc * grammar_action * ast_action_type * (t list * grammar_action) list
+
+type env = (string * typed_ast) list
+
+let string_of_dirpath = function
+  | [] -> "<empty>"
+  | sl ->
+      String.concat "." (List.map string_of_id (List.rev sl))
+
+let pr_id id = str (string_of_id id)
+
+let print_kn kn =
+  let (mp,dp,l) = repr_kn kn in
+  let dpl = repr_dirpath dp in
+  str (string_of_mp mp) ++ str "." ++
+  prlist_with_sep (fun _ -> str".") pr_id dpl ++
+  str (string_of_label l)
+
+(* Pretty-printing *)
+let rec print_ast ast =
+  match ast with
+    | Num(_,n) -> int n
+    | Str(_,s) -> qs s
+    | Path(_,sl) -> print_kn sl
+    | Id (_,s) -> str "{" ++ str s ++ str "}"
+    | Nvar(_,s) -> pr_id s
+    | Nmeta(_,s) -> str s
+    | Node(_,op,l) ->
+        hov 3 (str "(" ++ str op ++ spc () ++ print_astl l ++ str ")")
+    | Slam(_,None,ast) -> hov 1 (str "[<>]" ++ print_ast ast)
+    | Slam(_,Some x,ast) ->
+        hov 1
+          (str "[" ++ pr_id x ++ str "]" ++ cut () ++ 
+	   print_ast ast)
+    | Smetalam(_,id,ast) -> hov 1 (str id ++ print_ast ast)
+    | Dynamic(_,d) ->
+	hov 0 (str "<dynamic: " ++ str (Dyn.tag d) ++ str ">")
+
+and print_astl astl =
+  prlist_with_sep pr_spc print_ast astl
+
+let print_ast_cast = function
+  | Tany -> (mt ())
+  | Tvar -> (str":var")
+  | Tid -> (str":id")
+  | Tstr -> (str":str")
+  | Tpath -> (str":path")
+  | Tnum -> (str":num")
+  | Tlist -> (str":list")
+
+let rec print_astpat = function
+  | Pquote ast -> 
+      str"'" ++ print_ast ast 
+  | Pmeta(s,tk) -> 
+      str s ++ print_ast_cast tk 
+  | Pmeta_slam(s,b) ->
+      hov 1 (str "[" ++ str s ++ str"]" ++ cut () ++ print_astpat b)
+  | Pnode(op,al) ->
+      hov 2 (str"("  ++ str op ++ spc () ++ print_astlpat al ++ str")" )
+  | Pslam(None,b) -> 
+      hov 1 (str"[<" ++ cut () ++ print_astpat b)
+  | Pslam(Some id,b) ->
+      hov 1
+        (str"[" ++ str(string_of_id id) ++ str"]" ++ cut () ++ print_astpat b)
+
+and print_astlpat = function
+  | Pnil -> mt ()
+  | Pcons(h,Pnil) -> hov 1 (print_astpat h)
+  | Pcons(h,t) -> hov 1 (print_astpat h ++ spc () ++ print_astlpat t)
+  | Plmeta(s) -> str"| " ++ str s
+
+
+let print_val = function
+  | PureAstNode a -> print_ast a
+  | AstListNode al -> 
+      hov 1 (str"[" ++ prlist_with_sep pr_spc print_ast al ++ str"]")
+
+(* Ast values environments *)
+
+let grammar_type_error (loc,s) =
+  anomaly_loc (loc,s,(str"grammar type error: " ++ str s))
+
+
+(* Coercions enforced by the user *)
+let check_cast loc a k =
+  match (k,a) with
+    | (Tany, _) -> ()
+    | (Tid, Id _) -> ()
+    | (Tvar, Nvar _) -> ()
+    | (Tpath, Path _) -> ()
+    | (Tstr, Str _) -> ()
+    | (Tnum, Num _) -> ()
+    | (Tlist, _) -> grammar_type_error (loc,"Ast.cast_val")
+    | _ -> user_err_loc (loc,"Ast.cast_val",
+                         (str"cast _" ++ print_ast_cast k ++ str"failed"))
+
+let rec coerce_to_var = function
+  | Nvar(_,id) as var -> var
+  | Nmeta(_,id) as var -> var
+  | Node(_,"QUALID",[Nvar(_,id) as var]) -> var
+  | ast -> user_err_loc
+        (loc ast,"Ast.coerce_to_var",
+         (str"This expression should be a simple identifier"))
+
+let coerce_to_id_ast a = match coerce_to_var a with
+  | Nvar (_,id) -> id
+  | ast -> user_err_loc
+        (loc ast,"Ast.coerce_to_id",
+         str"This expression should be a simple identifier")
+
+let coerce_to_id = function
+  | CRef (Ident (loc,id)) -> (loc,id)
+  | a -> user_err_loc
+        (constr_loc a,"Ast.coerce_to_id",
+         str"This expression should be a simple identifier")
+
+let coerce_reference_to_id = function
+  | Ident (_,id) -> id
+  | Qualid (loc,_) ->
+      user_err_loc (loc, "Ast.coerce_reference_to_id",
+        str"This expression should be a simple identifier")
+
+let coerce_global_to_id = coerce_reference_to_id
+
+(* Pattern-matching on ast *)
+
+let env_assoc_value loc v env =
+  try 
+    List.assoc v env
+  with Not_found -> 
+    anomaly_loc
+      (loc,"Ast.env_assoc_value",
+       (str"metavariable " ++ str v ++ str" is unbound"))
+
+let env_assoc_list sigma (loc,v) =
+  match env_assoc_value loc v sigma with
+    | AstListNode al -> al
+    | PureAstNode a -> [a]
+
+let env_assoc sigma k (loc,v) =
+  match env_assoc_value loc v sigma with
+    | PureAstNode a -> check_cast loc a k; a
+    | _ -> grammar_type_error (loc,"Ast.env_assoc: "^v^" is an ast list")
+
+let env_assoc_nvars sigma (dloc,v) =
+  match env_assoc_value dloc v sigma with
+    | AstListNode al -> List.map coerce_to_id_ast al
+    | PureAstNode ast -> [coerce_to_id_ast ast]
+
+let build_lams dloc idl ast =
+  List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast
+
+(* Alpha-conversion *)
+	  
+let rec alpha_var id1 id2 = function
+  | (i1,i2)::_ when i1=id1 -> i2 = id2
+  | (i1,i2)::_ when i2=id2 -> i1 = id1
+  | _::idl -> alpha_var id1 id2 idl
+  | [] -> id1 = id2
+
+let rec alpha alp a1 a2 =
+  match (a1,a2) with
+    | (Node(_,op1,tl1),Node(_,op2,tl2)) ->
+        (op1 = op2) & (List.length tl1 = List.length tl2)
+        & (List.for_all2 (alpha alp) tl1 tl2)
+    | (Nvar(_,id1),Nvar(_,id2)) -> alpha_var id1 id2 alp
+    | (Slam(_,None,body1),Slam(_,None,body2)) -> alpha alp body1 body2
+    | (Slam(_,Some s1,body1),Slam(_,Some s2,body2)) ->
+        alpha ((s1,s2)::alp) body1 body2
+    | (Id(_,s1),Id(_,s2)) -> s1=s2
+    | (Str(_,s1),Str(_,s2)) -> s1=s2
+    | (Num(_,n1),Num(_,n2)) -> n1=n2
+    | (Path(_,sl1),Path(_,sl2)) -> sl1=sl2
+    | ((Smetalam _ | Nmeta _ | Dynamic _), _) -> false
+    | (_, (Smetalam _ | Nmeta _ | Dynamic _)) -> false
+    | _ -> false
+
+let alpha_eq (a1,a2)= alpha [] a1 a2
+
+let alpha_eq_val (x,y) = x = y
+(*
+let alpha_eq_val = function
+  | (Vast a1, Vast a2) -> alpha_eq (a1,a2)
+  | (Vastlist al1, Vastlist al2) ->
+      (List.length al1 = List.length al2)
+      & List.for_all2 (fun x y -> alpha_eq (x,y)) al1 al2
+  | _ ->  false
+*)
+
+exception No_match of string
+
+let no_match_loc (loc,s) = Stdpp.raise_with_loc loc (No_match s)
+
+(* Binds value v to variable var. If var is already bound, checks if
+   its value is alpha convertible with v. This allows non-linear patterns.
+
+   Important note: The Metavariable $_ is a special case; it cannot be
+   bound, which is like _ in the ML matching. *)
+
+let bind_env sigma var v =
+  if var = "$_" then 
+    sigma
+  else
+    try
+      let vvar = List.assoc var sigma in
+      if alpha_eq_val (v,vvar) then sigma
+      else raise (No_match "Ast.bind_env: values do not match")
+    with Not_found -> 
+      (var,v)::sigma
+
+let bind_env_ast sigma var ast =
+  try 
+    bind_env sigma var (PureAstNode ast)
+  with e -> 
+    Stdpp.raise_with_loc (loc ast) e
+
+let alpha_define sigma loc ps s =
+  try 
+    let _ = List.assoc ps sigma in sigma
+  with Not_found ->
+    if ps = "$_" then sigma else (ps, PureAstNode(Nvar(loc,s)))::sigma
+
+
+(* Match an ast with an ast pattern. Returns the new environnement. *)
+
+let rec amatch alp sigma spat ast =
+  match (spat,ast) with
+    | (Pquote a, _) ->
+        if alpha alp a ast then 
+	  sigma
+        else 
+	  no_match_loc (loc ast,"quote does not match")
+    | (Pmeta(pv,Tany), _) -> bind_env_ast sigma pv ast
+    | (Pmeta(pv,Tvar), Nvar _) -> bind_env_ast sigma pv ast
+    | (Pmeta(pv,Tid), Id _) -> bind_env_ast sigma pv ast
+    | (Pmeta(pv,Tnum), Num _) -> bind_env_ast sigma pv ast
+    | (Pmeta(pv,Tstr), Str _) -> bind_env_ast sigma pv ast
+    | (Pmeta(pv,Tpath), Path _) -> bind_env_ast sigma pv ast
+    | (Pmeta(pv,Tlist),_) -> grammar_type_error (loc ast,"Ast.amatch")
+    | (Pmeta_slam(pv,pb), Slam(loc, Some s, b)) ->
+        amatch alp (bind_env_ast sigma pv (Nvar(loc,s))) pb b
+    | (Pmeta_slam(pv,pb), Slam(loc, None, b)) ->
+        amatch alp (bind_env_ast sigma pv (Nvar(loc,id_of_string "_"))) pb b
+    | (Pmeta_slam(pv,pb), Smetalam(loc, s, b)) ->
+	anomaly "amatch: match a pattern with an open ast"
+    | (Pnode(nodp,argp), Node(loc,op,args)) when nodp = op ->
+        (try amatchl alp sigma argp args
+         with e -> Stdpp.raise_with_loc loc e)
+    | (Pslam(None,bp), Slam(_,None,b)) -> amatch alp sigma bp b
+    | (Pslam(Some ps,bp), Slam(_,Some s,b)) -> amatch ((ps,s)::alp) sigma bp b
+    | _ -> no_match_loc (loc ast, "Ast.amatch")
+
+and amatchl alp sigma spatl astl =
+  match (spatl,astl) with
+    | (Pnil, []) -> sigma
+    | (Pcons(pat,patl), ast::asttl) ->
+        amatchl alp (amatch alp sigma pat ast) patl asttl
+    | (Plmeta pv, _) -> bind_env sigma pv (AstListNode astl)
+    | _ -> raise (No_match "Ast.amatchl")
+
+let ast_match = amatch []
+
+let typed_ast_match env p a = match (p,a) with
+  | PureAstPat p, PureAstNode a -> amatch [] env p a
+  | AstListPat pl, AstListNode al -> amatchl [] env pl al
+  | _ -> failwith "Ast.typed_ast_match: TODO"
+
+let astl_match = amatchl []
+
+let first_match pat_of_fun env ast sl =
+  let rec aux = function
+    | [] -> None
+    | h::t ->
+        (try Some (h, ast_match env (pat_of_fun h) ast)
+         with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t)
+  in 
+  aux sl
+
+let find_all_matches pat_of_fun env ast sl =
+  let rec aux = function
+    | [] -> []
+    | (h::t) ->
+        let l = aux t in
+        (try (h, ast_match env (pat_of_fun h) ast)::l
+         with (No_match _| Stdpp.Exc_located (_,No_match _)) -> l)
+  in 
+  aux sl
+
+let first_matchl patl_of_fun env astl sl =
+  let rec aux = function
+    | [] -> None
+    | (h::t) ->
+        (try Some (h, astl_match env (patl_of_fun h) astl)
+         with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t)
+  in 
+  aux sl
+    
+let bind_patvar env loc v etyp =
+  try
+    if List.assoc v env = etyp then 
+      env
+    else 
+      user_err_loc
+	(loc,"Ast.bind_patvar",
+	 (str"variable " ++ str v ++
+            str" is bound several times with different types"))
+  with Not_found -> 
+    if v="$_" then env else (v,etyp)::env
+      
+let make_astvar env loc v cast =
+  let env' = bind_patvar env loc v ETast in
+  (Pmeta(v,cast), env')
+
+(* Note: no metavar in operator position. necessary ? *)
+let rec pat_of_ast env ast =
+  match ast with
+    | Nmeta(loc,pv) -> make_astvar env loc pv Tany
+(* Obsolète
+    | Id(loc,pv) when isMeta pv -> make_astvar env loc pv Tid
+*)
+    | Smetalam(loc,s,a) ->
+        let senv = bind_patvar env loc s ETast in
+        let (pa,env') = pat_of_ast senv a in
+        (Pmeta_slam(s, pa), env')
+    | Node(_,"$VAR",[Nmeta(loc,pv)]) ->
+        make_astvar env loc pv Tvar
+    | Node(_,"$ID",[Nmeta(loc,pv)]) ->
+        make_astvar env loc pv Tid
+    | Node(_,"$NUM",[Nmeta(loc,pv)]) ->
+        make_astvar env loc pv Tnum
+    | Node(_,"$STR",[Nmeta(loc,pv)]) ->
+        make_astvar env loc pv Tstr
+    | Node(_,"$PATH",[Nmeta(loc,pv)]) ->
+        make_astvar env loc pv Tpath
+    | Node(_,"$QUOTE",[qast]) -> (Pquote (set_loc dummy_loc qast), env)
+
+   (* This may occur when the meta is not textual but bound by coerce_to_id*)
+    | Slam(loc,Some id,b) when isMeta (string_of_id id) ->
+	let s = string_of_id id in
+        let senv = bind_patvar env loc s ETast in
+        let (pb,env') = pat_of_ast senv b in
+        (Pmeta_slam(s, pb), env')
+
+    | Slam(_,os,b) ->
+        let (pb,env') = pat_of_ast env b in
+        (Pslam(os,pb), env')
+    | Node(loc,op,_) when isMeta op ->
+        user_err_loc(loc,"Ast.pat_of_ast",
+                     (str"no patvar in operator position."))
+    | Node(_,op,args) ->
+        let (pargs, env') = patl_of_astl env args in
+        (Pnode(op,pargs), env')
+(* Compatibility with new parsing mode *)
+    | Nvar(loc,id) when (string_of_id id).[0] = '$' -> make_astvar env loc (string_of_id id) Tany
+    | (Path _|Num _|Id _|Str _ |Nvar _) -> (Pquote (set_loc dummy_loc ast), env)
+    | Dynamic(loc,_) ->
+        invalid_arg_loc(loc,"pat_of_ast: dynamic")
+	  
+and patl_of_astl env astl =
+  match astl with
+    | [Node(_,"$LIST",[Nmeta(loc,pv)])] ->
+        let penv = bind_patvar env loc pv ETastl in
+        (Plmeta pv, penv)
+    | [] -> (Pnil,env)
+    | ast::asttl ->
+        let (p1,env1) = pat_of_ast env ast in
+        let (ptl,env2) = patl_of_astl env1 asttl in
+        (Pcons (p1,ptl), env2)
+
+type entry_env = (string * ast_action_type) list
+	
+let to_pat = pat_of_ast
+
+(* Substitution *)
+
+(* Locations in quoted ast are wrong (they refer to the right hand
+   side of a grammar rule). A default location dloc is used whenever
+   we create an ast constructor. Locations in the binding list are trusted. *)
+
+(* For old ast printer *)
+let rec pat_sub dloc sigma pat =
+  match pat with
+    | Pmeta(pv,c) -> env_assoc sigma c (dloc,pv) 
+    | Pmeta_slam(pv,p) ->
+        let idl = env_assoc_nvars sigma (dloc,pv) in
+        build_lams dloc idl (pat_sub dloc sigma p)
+    | Pquote a -> set_loc dloc a
+    | Pnode(op,pl) -> Node(dloc, op, patl_sub dloc sigma pl)
+    | Pslam(os,p) -> Slam(dloc, os, pat_sub dloc sigma p)
+	  
+and patl_sub dloc sigma pl =
+  match pl with
+    | Pnil -> 
+	[]
+    | Plmeta pv -> 
+	env_assoc_list sigma (dloc,pv)
+    | Pcons(Pmeta(pv,Tlist), ptl) ->
+        (env_assoc_list sigma (dloc,pv))@(patl_sub dloc sigma ptl)
+    | Pcons(p1,ptl) -> 
+	(pat_sub dloc sigma p1)::(patl_sub dloc sigma ptl)
+
+(* Converting and checking free meta-variables *)
+
+(* For old ast printer *)
+let type_of_meta env loc pv =
+  try 
+    List.assoc pv env
+  with Not_found ->
+    user_err_loc (loc,"Ast.type_of_meta",
+                  (str"variable " ++ str pv ++ str" is unbound"))
+
+(* For old ast printer *)
+let check_ast_meta env loc pv =
+  match type_of_meta env loc pv with
+    | ETast -> ()
+    | _ ->
+	user_err_loc (loc,"Ast.check_ast_meta",
+                      (str"variable " ++ str pv ++ str" is not of ast type"))
+
+(* For old ast printer *)
+let rec val_of_ast env = function
+  | Nmeta(loc,pv) -> 
+      check_ast_meta env loc pv;
+      Pmeta(pv,Tany)
+  | Node(_,"$QUOTE",[qast]) -> Pquote (set_loc dummy_loc qast)
+  | Smetalam(loc,s,a) ->
+    let _ = type_of_meta env loc s in (* ids are coerced to id lists *)
+    Pmeta_slam(s, val_of_ast env a)
+  | (Path _|Num _|Id _|Str _|Nvar _ as ast) -> Pquote (set_loc dummy_loc ast)
+  | Slam(_,os,b) -> Pslam(os, val_of_ast env b)
+  | Node(loc,op,_) when isMeta op ->
+      user_err_loc(loc,"Ast.val_of_ast",
+                   (str"no patvar in operator position."))
+  | Node(_,op,args) -> Pnode(op, vall_of_astl env args)
+  | Dynamic(loc,_) ->
+      invalid_arg_loc(loc,"val_of_ast: dynamic")
+	  
+and vall_of_astl env = function
+  | (Node(loc,"$LIST",[Nmeta(locv,pv)]))::asttl ->
+      if type_of_meta env locv pv = ETastl then
+	if asttl = [] then 
+	  Plmeta pv
+	else 
+	  Pcons(Pmeta(pv,Tlist), vall_of_astl env asttl)
+      else
+	user_err_loc
+	  (loc,"Ast.vall_of_astl",
+	    str"variable " ++ str pv ++ str" is not a List")
+  | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl)
+  | [] -> Pnil
+
+(* For old ast printer *)
+let rec occur_var_ast s = function
+  | Node(_,"QUALID",_::_::_) -> false
+  | Node(_,"QUALID",[Nvar(_,s2)]) -> s = s2
+  | Nvar(_,s2) -> s = s2
+  | Node(loc,op,args) -> List.exists (occur_var_ast s) args
+  | Smetalam _ | Nmeta _ -> anomaly "occur_var: metas should not occur here"
+  | Slam(_,sopt,body) -> (Some s <> sopt) & occur_var_ast s body
+  | Id _ | Str _ | Num _ | Path _ -> false
+  | Dynamic _ -> (* Hum... what to do here *) false
+
+
+(**********************************************************************)
+(* Object substitution in modules *)
+
+let rec subst_astpat subst = function
+  | Pquote a -> Pquote (subst_ast subst a)
+  | Pmeta _ as p -> p
+  | Pnode (s,pl) -> Pnode (s,subst_astpatlist subst pl)
+  | Pslam (ido,p) -> Pslam (ido,subst_astpat subst p)
+  | Pmeta_slam (s,p) -> Pmeta_slam (s,subst_astpat subst p)
+
+and subst_astpatlist subst = function
+  | Pcons (p,pl) -> Pcons (subst_astpat subst p, subst_astpatlist subst pl)
+  | (Plmeta _ | Pnil) as pl -> pl
+
+let subst_pat subst = function
+  | AstListPat pl -> AstListPat (subst_astpatlist subst pl)
+  | PureAstPat p -> PureAstPat (subst_astpat subst p)
diff --git a/parsing/ast.mli b/parsing/ast.mli
new file mode 100755
index 00000000..7bc0b607
--- /dev/null
+++ b/parsing/ast.mli
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  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: ast.mli,v 1.17.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Libnames
+open Coqast
+open Topconstr
+open Genarg
+(*i*)
+
+(* Abstract syntax trees. *)
+
+val loc : Coqast.t -> loc
+
+(* ast constructors with dummy location *)
+val ope : string * Coqast.t list -> Coqast.t
+val slam : identifier option * Coqast.t -> Coqast.t
+val nvar : identifier -> Coqast.t
+val ide : string -> Coqast.t
+val num : int -> Coqast.t
+val string : string -> Coqast.t
+val path : kernel_name -> Coqast.t
+val dynamic : Dyn.t -> Coqast.t
+
+val set_loc : loc -> Coqast.t -> Coqast.t
+
+val path_section : loc -> kernel_name -> Coqast.t
+val section_path : kernel_name -> kernel_name
+
+(* ast destructors *)
+val num_of_ast : Coqast.t -> int
+val id_of_ast : Coqast.t -> string
+val nvar_of_ast : Coqast.t -> identifier
+val meta_of_ast : Coqast.t -> string
+
+(* patterns of ast *)
+type astpat =
+  | Pquote of t
+  | Pmeta of string * tok_kind
+  | Pnode of string * patlist
+  | Pslam of identifier option * astpat
+  | Pmeta_slam of string * astpat
+
+and patlist =
+  | Pcons of astpat * patlist
+  | Plmeta of string
+  | Pnil
+
+and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist
+
+type pat =
+  | AstListPat of patlist
+  | PureAstPat of astpat
+
+(* semantic actions of grammar rules *)
+type act =
+  | Act of constr_expr
+  | ActCase of act * (pat * act) list
+  | ActCaseList of act * (pat * act) list
+
+(* values associated to variables *)
+type typed_ast =
+  | AstListNode of Coqast.t list
+  | PureAstNode of Coqast.t
+
+type ast_action_type = ETast | ETastl
+
+type dynamic_grammar =
+  | ConstrNode of constr_expr
+  | CasesPatternNode of cases_pattern_expr
+
+type grammar_action =
+  | SimpleAction of loc * dynamic_grammar
+  | CaseAction of
+      loc * grammar_action * ast_action_type * (t list * grammar_action) list
+
+type env = (string * typed_ast) list
+
+val coerce_to_id : constr_expr -> identifier located
+
+val coerce_global_to_id : reference -> identifier
+val coerce_reference_to_id : reference -> identifier
+
+exception No_match of string
+
+val isMeta : string -> bool
+
+val print_ast : Coqast.t -> std_ppcmds
+val print_astl : Coqast.t list -> std_ppcmds
+val print_astpat : astpat -> std_ppcmds
+val print_astlpat : patlist -> std_ppcmds
+
+(* Meta-syntax operations: matching and substitution *)
+
+type entry_env = (string * ast_action_type) list
+
+val grammar_type_error : loc * string -> 'a
+ 
+(* Converting and checking free meta-variables *)
+
+(* For old ast printer *)
+val pat_sub : loc -> env -> astpat -> Coqast.t
+val val_of_ast : entry_env -> Coqast.t -> astpat
+val alpha_eq : Coqast.t * Coqast.t -> bool
+val alpha_eq_val : typed_ast * typed_ast -> bool
+val occur_var_ast : identifier -> Coqast.t -> bool
+val find_all_matches : ('a -> astpat) -> env -> t -> 'a list -> ('a * env) list
+val first_matchl : ('a -> patlist) -> env -> Coqast.t list -> 'a list ->
+  ('a * env) option
+val to_pat : entry_env -> Coqast.t -> (astpat * entry_env)
+
+(* Object substitution in modules *)
+val subst_astpat : Names.substitution -> astpat -> astpat
diff --git a/parsing/coqast.ml b/parsing/coqast.ml
new file mode 100644
index 00000000..0f447766
--- /dev/null
+++ b/parsing/coqast.ml
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  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: coqast.ml,v 1.9.6.1 2004/07/16 19:30:37 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Names
+open Libnames
+(*i*)
+
+type t =
+  | Node of loc * string * t list
+  | Nmeta of loc * string
+  | Nvar of loc * identifier
+  | Slam of loc * identifier option * t
+  | Smetalam of loc * string * t
+  | Num of loc * int
+  | Str of loc * string
+  | Id of loc * string
+  | Path of loc * kernel_name
+  | Dynamic of loc * Dyn.t
+
+type the_coq_ast = t
+
+let subst_meta bl ast =
+  let rec aux = function
+    | Node (_,"META", [Num(_, n)]) -> List.assoc n bl
+    | Node(loc, node_name, args) -> 
+	Node(loc, node_name, List.map aux args)
+    | Slam(loc, var, arg) -> Slam(loc, var, aux arg)
+    | Smetalam(loc, var, arg) -> Smetalam(loc, var, aux arg)
+    | other -> other
+  in 
+  aux ast
+
+let rec collect_metas = function
+  | Node (_,"META", [Num(_, n)]) -> [n]
+  | Node(_, _, args) -> List.concat (List.map collect_metas args)
+  | Slam(loc, var, arg) -> collect_metas arg
+  | Smetalam(loc, var, arg) -> collect_metas arg
+  | _ -> []
+
+(* Hash-consing *)
+module Hloc = Hashcons.Make(
+  struct
+    type t = loc
+    type u = unit
+    let equal (b1,e1) (b2,e2) = b1=b2 & e1=e2
+    let hash_sub () x = x
+    let hash = Hashtbl.hash
+  end)
+
+module Hast = Hashcons.Make(
+  struct
+    type t = the_coq_ast
+    type u = 
+	(the_coq_ast -> the_coq_ast) *
+	((loc -> loc) * (string -> string)
+	 * (identifier -> identifier) * (kernel_name -> kernel_name))
+    let hash_sub (hast,(hloc,hstr,hid,hsp)) = function
+      | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al)
+      | Nmeta(l,s) -> Nmeta(hloc l, hstr s)
+      | Nvar(l,s) -> Nvar(hloc l, hid s)
+      | Slam(l,None,t) -> Slam(hloc l, None, hast t)
+      | Slam(l,Some s,t) -> Slam(hloc l, Some (hid s), hast t)
+      | Smetalam(l,s,t) -> Smetalam(hloc l, hstr s, hast t)
+      | Num(l,n) -> Num(hloc l, n)
+      | Id(l,s) -> Id(hloc l, hstr s)
+      | Str(l,s) -> Str(hloc l, hstr s)
+      | Path(l,d) -> Path(hloc l, hsp d)
+      | Dynamic(l,d) -> Dynamic(hloc l, d)
+    let equal a1 a2 =
+      match (a1,a2) with
+        | (Node(l1,s1,al1), Node(l2,s2,al2)) ->
+            (l1==l2 & s1==s2 & List.length al1 = List.length al2)
+            & List.for_all2 (==) al1 al2
+        | (Nmeta(l1,s1), Nmeta(l2,s2)) -> l1==l2 & s1==s2
+        | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2
+        | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2
+        | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) ->l1==l2 & s1==s2 & t1==t2
+        | (Smetalam(l1,s1,t1), Smetalam(l2,s2,t2)) -> l1==l2 & s1==s2 & t1==t2
+        | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2
+        | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2
+        | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2
+        | (Path(l1,d1), Path(l2,d2)) -> (l1==l2 & d1==d2)
+        | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+let hcons_ast (hstr,hid,hpath) =
+  let hloc = Hashcons.simple_hcons Hloc.f () in
+  let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr,hid,hpath) in
+  (hast,hloc)
+
+let rec subst_ast subst ast = match ast with
+  | Node (l,s,astl) ->
+      let astl' = Util.list_smartmap (subst_ast subst) astl in
+	if astl' == astl then ast else
+	  Node (l,s,astl')
+  | Slam (l,ido,ast1) ->
+      let ast1' = subst_ast subst ast1 in
+	if ast1' == ast1 then ast else
+	  Slam (l,ido,ast1')
+  | Smetalam (l,s,ast1) ->
+      let ast1' = subst_ast subst ast1 in
+	if ast1' == ast1 then ast else
+	  Smetalam (l,s,ast1')
+  | Path (loc,kn) -> 
+      let kn' = Names.subst_kn subst kn in
+	if kn' == kn then ast else
+	  Path(loc,kn')
+  | Nmeta _
+  | Nvar _ -> ast
+  | Num _
+  | Str _
+  | Id _
+  | Dynamic _ -> ast
diff --git a/parsing/coqast.mli b/parsing/coqast.mli
new file mode 100644
index 00000000..546725c0
--- /dev/null
+++ b/parsing/coqast.mli
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  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: coqast.mli,v 1.10.6.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Libnames
+(*i*)
+
+(* Abstract syntax trees. *)
+
+type t =
+  | Node of loc * string * t list
+  | Nmeta of loc * string
+  | Nvar of loc * identifier
+  | Slam of loc * identifier option * t
+  | Smetalam of loc * string * t
+  | Num of loc * int
+  | Str of loc * string
+  | Id of loc * string
+  | Path of loc * kernel_name
+  | Dynamic of loc * Dyn.t
+
+(* returns the list of metas occuring in the ast *)
+val collect_metas : t -> int list
+
+(* [subst_meta bl ast]: for each binding [(i,c_i)] in [bl], 
+   replace the metavar [?i] by [c_i] in [ast] *)
+val subst_meta : (int * t) list -> t -> t
+
+(* hash-consing function *)
+val hcons_ast: 
+  (string -> string) * (Names.identifier -> Names.identifier)
+  * (kernel_name -> kernel_name)
+  -> (t -> t) * (loc -> loc)
+
+val subst_ast: Names.substitution -> t -> t
+
+(*
+val map_tactic_expr : (t -> t) -> (tactic_expr -> tactic_expr) -> tactic_expr -> tactic_expr
+val fold_tactic_expr :
+  ('a -> t -> 'a) -> ('a -> tactic_expr -> 'a) -> 'a -> tactic_expr -> 'a
+val iter_tactic_expr : (tactic_expr -> unit) -> tactic_expr -> unit
+*)
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
new file mode 100644
index 00000000..9886bbf1
--- /dev/null
+++ b/parsing/egrammar.ml
@@ -0,0 +1,479 @@
+(************************************************************************)
+(*  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: egrammar.ml,v 1.48.2.1 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Pp
+open Util
+open Extend
+open Pcoq
+open Topconstr
+open Ast
+open Genarg
+open Libnames
+open Nameops
+
+(* State of the grammar extensions *)
+
+type all_grammar_command =
+  | Notation of
+      (int * Gramext.g_assoc option * notation * prod_item list *
+      int list option)
+  | Grammar of grammar_command
+  | TacticGrammar of
+      (string * (string * grammar_production list) * 
+      (Names.dir_path * Tacexpr.raw_tactic_expr))
+      list
+
+let subst_all_grammar_command subst = function
+  | Notation _ -> anomaly "Notation not in GRAMMAR summary"
+  | Grammar gc -> Grammar (subst_grammar_command subst gc)
+  | TacticGrammar g -> TacticGrammar g (* TODO ... *)
+
+let (grammar_state : all_grammar_command list ref) = ref []
+
+
+(**************************************************************************)
+(* Interpretation of the right hand side of grammar rules *)
+
+(* When reporting errors, we add the name of the grammar rule that failed *)
+let specify_name name e =
+  match e with
+    | UserError(lab,strm) ->
+        UserError(lab, (str"during interpretation of grammar rule " ++
+                          str name ++ str"," ++ spc () ++ strm))
+    | Anomaly(lab,strm) ->
+        Anomaly(lab, (str"during interpretation of grammar rule " ++
+                        str name ++ str"," ++ spc () ++ strm))
+    | Failure s ->
+        Failure("during interpretation of grammar rule "^name^", "^s)
+    | e -> e
+
+(* Translation of environments: a production
+ *   [ nt1(x1) ... nti(xi) ] -> act(x1..xi)
+ * is written (with camlp4 conventions):
+ *   (fun vi -> .... (fun v1 -> act(v1 .. vi) )..)
+ * where v1..vi are the values generated by non-terminals nt1..nti.
+ * Since the actions are executed by substituting an environment,
+ * make_act builds the following closure:
+ *
+ *      ((fun env ->
+ *          (fun vi -> 
+ *             (fun env -> ...
+ *           
+ *                  (fun v1 ->
+ *                     (fun env -> gram_action .. env act)
+ *                     ((x1,v1)::env))
+ *                  ...)
+ *             ((xi,vi)::env)))
+ *         [])
+ *)
+
+open Names
+
+type 'a action_env = (identifier * 'a) list
+
+let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
+  let rec make (env : constr_expr action_env) = function
+    | [] ->
+	Gramext.action (fun loc -> f loc env)
+    | None :: tl -> (* parse a non-binding item *)
+        Gramext.action (fun _ -> make env tl)
+    | Some (p, (ETConstr _| ETOther _)) :: tl -> (* constr non-terminal *)
+        Gramext.action (fun (v:constr_expr) -> make ((p,v) :: env) tl)
+    | Some (p, ETReference) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:reference) -> make ((p,CRef v) :: env) tl)
+    | Some (p, ETIdent) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:identifier) ->
+	  make ((p,CRef (Ident (dummy_loc,v))) :: env) tl)
+    | Some (p, ETBigint) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:Bignat.bigint) ->
+	  make ((p,CNumeral (dummy_loc,v)) :: env) tl)
+    | Some (p, ETConstrList _) :: tl ->
+        Gramext.action (fun (v:constr_expr list) ->
+          let dummyid = Ident (dummy_loc,id_of_string "") in
+	  make ((p,CAppExpl (dummy_loc,(None,dummyid),v)) :: env) tl)
+    | Some (p, ETPattern) :: tl -> 
+	failwith "Unexpected entry of type cases pattern" in
+  make [] (List.rev pil)
+
+let make_act_in_cases_pattern (* For Notations *)
+  (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
+  let rec make (env : cases_pattern_expr action_env) = function
+    | [] ->
+	Gramext.action (fun loc -> f loc env)
+    | None :: tl -> (* parse a non-binding item *)
+        Gramext.action (fun _ -> make env tl)
+    | Some (p, ETConstr _) :: tl -> (* pattern non-terminal *)
+        Gramext.action (fun (v:cases_pattern_expr) -> make ((p,v) :: env) tl)
+    | Some (p, ETReference) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:reference) ->
+	  make ((p,CPatAtom (dummy_loc,Some v)) :: env) tl)
+    | Some (p, ETIdent) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:identifier) ->
+	  make ((p,CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))) :: env) tl)
+    | Some (p, ETBigint) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:Bignat.bigint) ->
+	  make ((p,CPatNumeral (dummy_loc,v)) :: env) tl)
+    | Some (p, ETConstrList _) :: tl ->
+        Gramext.action (fun (v:cases_pattern_expr list) ->
+          let dummyid = Ident (dummy_loc,id_of_string "") in
+	  make ((p,CPatCstr (dummy_loc,dummyid,v)) :: env) tl)
+    | Some (p, (ETPattern | ETOther _)) :: tl -> 
+	failwith "Unexpected entry of type cases pattern or other" in
+  make [] (List.rev pil)
+
+(* For V7 Grammar only *)
+let make_cases_pattern_act
+  (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
+  let rec make (env : cases_pattern_expr action_env) = function
+    | [] ->
+	Gramext.action (fun loc -> f loc env)
+    | None :: tl -> (* parse a non-binding item *)
+        Gramext.action (fun _ -> make env tl)
+    | Some (p, ETPattern) :: tl -> (* non-terminal *)
+        Gramext.action (fun v -> make ((p,v) :: env) tl)
+    | Some (p, ETReference) :: tl -> (* non-terminal *)
+	Gramext.action (fun v -> make ((p,CPatAtom(dummy_loc,Some v)) :: env)
+	  tl)
+    | Some (p, ETBigint) :: tl -> (* non-terminal *)
+	Gramext.action (fun v -> make ((p,CPatNumeral(dummy_loc,v)) :: env) tl)
+    | Some (p, (ETConstrList _ | ETIdent | ETConstr _ | ETOther _)) :: tl ->
+	error "ident and constr entry not admitted in patterns cases syntax extensions" in
+  make [] (List.rev pil)
+
+(* Grammar extension command. Rules are assumed correct.
+ * Type-checking of grammar rules is done during the translation of
+ * ast to the type grammar_command.  We only check that the existing
+ * entries have the type assumed in the grammar command (these types
+ * annotations are added when type-checking the command, function
+ * Extend.of_ast) *)
+
+let symbol_of_prod_item univ assoc from forpat = function
+  | Term tok -> (Gramext.Stoken tok, None)
+  | NonTerm (nt, ovar) ->
+      let eobj = symbol_of_production assoc from forpat nt in
+      (eobj, ovar)
+
+let coerce_to_id = function
+  | CRef (Ident (_,id)) -> id 
+  | c ->
+      user_err_loc (constr_loc c, "subst_rawconstr",
+        str"This expression should be a simple identifier")
+
+let coerce_to_ref = function
+  | CRef r -> r
+  | c ->
+      user_err_loc (constr_loc c, "subst_rawconstr",
+        str"This expression should be a simple reference")
+
+let subst_ref loc subst id =
+  try coerce_to_ref (List.assoc id subst) with Not_found -> Ident (loc,id)
+
+let subst_pat_id loc subst id =
+  try List.assoc id subst
+  with Not_found -> CPatAtom (loc,Some (Ident (loc,id)))
+
+let subst_id subst id =
+  try coerce_to_id (List.assoc id subst) with Not_found -> id
+
+(*
+let subst_cases_pattern_expr a loc subs =
+  let rec subst = function
+  | CPatAlias (_,p,x) -> CPatAlias (loc,subst p,x)
+    (* No subst in compound pattern ? *)
+  | CPatCstr (_,ref,pl) -> CPatCstr (loc,ref,List.map subst pl)
+  | CPatAtom (_,Some (Ident (_,id))) -> subst_pat_id loc subs id
+  | CPatAtom (_,x) -> CPatAtom (loc,x)
+  | CPatNotation (_,ntn,l) -> CPatNotation 
+  | CPatNumeral (_,n) -> CPatNumeral (loc,n)
+  | CPatDelimiters (_,key,p) -> CPatDelimiters (loc,key,subst p)
+  in subst a
+*)
+
+let subst_constr_expr a loc subs =
+  let rec subst = function
+  | CRef (Ident (_,id)) ->
+      (try List.assoc id subs with Not_found -> CRef (Ident (loc,id)))
+  (* Temporary: no robust treatment of substituted binders *)
+  | CLambdaN (_,[],c) -> subst c
+  | CLambdaN (_,([],t)::bl,c) -> subst (CLambdaN (loc,bl,c))
+  | CLambdaN (_,((_,na)::bl,t)::bll,c) -> 
+      let na = name_app (subst_id subs) na in
+      CLambdaN (loc,[[loc,na],subst t], subst (CLambdaN (loc,(bl,t)::bll,c)))
+  | CProdN (_,[],c) -> subst c
+  | CProdN (_,([],t)::bl,c) -> subst (CProdN (loc,bl,c))
+  | CProdN (_,((_,na)::bl,t)::bll,c) -> 
+      let na = name_app (subst_id subs) na in
+      CProdN (loc,[[loc,na],subst t], subst (CProdN (loc,(bl,t)::bll,c)))
+  | CLetIn (_,(_,na),b,c) ->
+      let na = name_app (subst_id subs) na in
+      CLetIn (loc,(loc,na),subst b,subst c)
+  | CArrow (_,a,b) -> CArrow (loc,subst a,subst b)
+  | CAppExpl (_,(p,Ident (_,id)),l) ->
+      CAppExpl (loc,(p,subst_ref loc subs id),List.map subst l) 
+  | CAppExpl (_,r,l) -> CAppExpl (loc,r,List.map subst l) 
+  | CApp (_,(p,a),l) ->
+      CApp (loc,(p,subst a),List.map (fun (a,i) -> (subst a,i)) l)
+  | CCast (_,a,b) -> CCast (loc,subst a,subst b)
+  | CNotation (_,n,l) -> CNotation (loc,n,List.map subst l)
+  | CDelimiters (_,s,a) -> CDelimiters (loc,s,subst a)
+  | CHole _ | CEvar _ | CPatVar _ | CSort _ 
+  | CNumeral _ | CDynamic _ | CRef _ as x -> x
+  | CCases (_,(po,rtntypo),a,bl) ->
+      (* TODO: apply g on the binding variables in pat... *)
+      let bl = List.map (fun (_,pat,rhs) -> (loc,pat,subst rhs)) bl in
+      CCases (loc,(option_app subst po,option_app subst rtntypo),
+        List.map (fun (tm,x) -> subst tm,x) a,bl)
+  | COrderedCase (_,s,po,a,bl) ->
+      COrderedCase (loc,s,option_app subst po,subst a,List.map subst bl)
+  | CLetTuple (_,nal,(na,po),a,b) ->
+      let na = option_app (name_app (subst_id subs)) na in
+      let nal = List.map (name_app (subst_id subs)) nal in
+      CLetTuple (loc,nal,(na,option_app subst po),subst a,subst b)
+  | CIf (_,c,(na,po),b1,b2) ->
+      let na = option_app (name_app (subst_id subs)) na in
+      CIf (loc,subst c,(na,option_app subst po),subst b1,subst b2)
+  | CFix (_,id,dl) ->
+      CFix (loc,id,List.map (fun (id,n,bl, t,d) ->
+        (id,n,
+         List.map(function
+             LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty)
+           | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl,
+         subst t,subst d)) dl)
+  | CCoFix (_,id,dl) ->
+      CCoFix (loc,id,List.map (fun (id,bl,t,d) ->
+        (id,
+         List.map(function
+             LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty)
+           | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl,
+         subst t,subst d)) dl)
+  in subst a
+
+(* For V7 Grammar only *)
+let make_rule univ assoc etyp rule =
+  if not !Options.v7 then anomaly "No Grammar in new syntax";
+  let pil = List.map (symbol_of_prod_item univ assoc etyp false) rule.gr_production in
+  let (symbs,ntl) = List.split pil in
+  let act = match etyp with
+    | ETPattern ->
+        (* Ugly *)
+        let f loc env = match rule.gr_action, env with
+          | CRef (Ident(_,p)), [p',a] when p=p' -> a
+          | CDelimiters (_,s,CRef (Ident(_,p))), [p',a] when p=p' ->
+	      CPatDelimiters (loc,s,a)
+          | _ -> error "Unable to handle this grammar extension of pattern" in
+	make_cases_pattern_act f ntl
+    | ETConstrList _ | ETIdent | ETBigint | ETReference -> error "Cannot extend"
+    | ETConstr _ | ETOther _ -> 
+	make_act (subst_constr_expr rule.gr_action) ntl in
+  (symbs, act)
+
+(* Rules of a level are entered in reverse order, so that the first rules
+   are applied before the last ones *)
+(* For V7 Grammar only *)
+let extend_entry univ (te, etyp, pos, name, ass, p4ass, rls) =
+  let rules = List.rev (List.map (make_rule univ ass etyp) rls) in
+  grammar_extend te pos [(name, p4ass, rules)]
+
+(* Defines new entries. If the entry already exists, check its type *)
+let define_entry univ {ge_name=typ; gl_assoc=ass; gl_rules=rls} =
+  let e,lev,keepassoc = get_constr_entry false typ in
+  let pos,p4ass,name = find_position false keepassoc ass lev in
+  (e,typ,pos,name,ass,p4ass,rls)
+
+(* Add a bunch of grammar rules. Does not check if it is well formed *)
+(* For V7 Grammar only *)
+let extend_grammar_rules gram =
+  let univ = get_univ gram.gc_univ in
+  let tl = List.map (define_entry univ) gram.gc_entries in
+  List.iter (extend_entry univ) tl
+
+(* Add a grammar rules for tactics *)
+type grammar_tactic_production =
+  | TacTerm of string
+  | TacNonTerm of loc * (Gram.te Gramext.g_symbol * argument_type) * string option
+
+let make_prod_item = function
+  | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None)
+  | TacNonTerm (_,(nont,t), po) ->
+      (nont, option_app (fun p -> (p,t)) po)
+
+let make_gen_act f pil =
+  let rec make env = function
+    | [] -> 
+	Gramext.action (fun loc -> f loc env)
+    | None :: tl -> (* parse a non-binding item *)
+        Gramext.action (fun _ -> make env tl)
+    | Some (p, t) :: tl -> (* non-terminal *)
+        Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in
+  make [] (List.rev pil)
+
+let extend_constr entry (n,assoc,pos,p4assoc,name) make_act (forpat,pt) =
+  let univ = get_univ "constr" in
+  let pil = List.map (symbol_of_prod_item univ assoc n forpat) pt in
+  let (symbs,ntl) = List.split pil in
+  let act = make_act ntl in
+  grammar_extend entry pos [(name, p4assoc, [symbs, act])]
+
+let extend_constr_notation (n,assoc,ntn,rule,permut) =
+  let mkact =
+    match permut with
+        None -> (fun loc env -> CNotation (loc,ntn,List.map snd env))
+      | Some p -> (fun loc env ->
+          CNotation (loc,ntn,List.map (fun i -> snd (List.nth env i)) p)) in
+  let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in
+  let pos,p4assoc,name = find_position false keepassoc assoc level in
+  extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name)
+    (make_act mkact) (false,rule);
+  if not !Options.v7 then
+  let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in
+  let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in
+  let pos,p4assoc,name = find_position true keepassoc assoc level in
+  extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name)
+    (make_act_in_cases_pattern mkact) (true,rule)
+    
+(* These grammars are not a removable *)
+let make_rule univ f g (s,pt) =
+  let hd = Gramext.Stoken ("IDENT", s) in
+  let pil = (hd,None) :: List.map g pt in
+  let (symbs,ntl) = List.split pil in
+  let act = make_gen_act f ntl in
+  (symbs, act)
+
+let tac_exts = ref []
+let get_extend_tactic_grammars () = !tac_exts
+
+let extend_tactic_grammar s gl =
+  tac_exts := (s,gl) :: !tac_exts;
+  let univ = get_univ "tactic" in
+  let make_act loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
+  let rules = List.map (make_rule univ make_act make_prod_item) gl in
+  Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+
+let vernac_exts = ref []
+let get_extend_vernac_grammars () = !vernac_exts
+
+let extend_vernac_command_grammar s gl =
+  vernac_exts := (s,gl) :: !vernac_exts;
+  let univ = get_univ "vernac" in
+  let make_act loc l = Vernacexpr.VernacExtend (s,List.map snd l) in
+  let rules = List.map (make_rule univ make_act make_prod_item) gl in
+  Gram.extend Vernac_.command None [(None, None, List.rev rules)]
+
+let rec interp_entry_name u s =
+  let l = String.length s in
+  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name u (String.sub s 3 (l-8)) in
+    List1ArgType t, Gramext.Slist1 g
+  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name u (String.sub s 0 (l-5)) in
+    List0ArgType t, Gramext.Slist0 g
+  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    let t, g = interp_entry_name u (String.sub s 0 (l-4)) in
+    OptArgType t, Gramext.Sopt g
+  else
+    let e = 
+    if !Options.v7 then get_entry (get_univ u) s
+    else
+      (* Qualified entries are no longer in use *)
+      try get_entry (get_univ "tactic") s
+      with _ -> 
+      try get_entry (get_univ "prim") s
+      with _ ->
+      try get_entry (get_univ "constr") s
+      with _ -> error ("Unknown entry "^s)
+    in
+    let o = object_of_typed_entry e in
+    let t = type_of_typed_entry e in
+    t,Gramext.Snterm (Pcoq.Gram.Entry.obj o)
+
+let qualified_nterm current_univ = function
+  | NtQual (univ, en) -> if !Options.v7 then (univ, en) else assert false
+  | NtShort en -> (current_univ, en)
+
+let make_vprod_item univ = function
+  | VTerm s -> (Gramext.Stoken (Extend.terminal s), None)
+  | VNonTerm (loc, nt, po) ->
+      let (u,nt) = qualified_nterm univ nt in
+      let (etyp, e) = interp_entry_name u nt in
+      e, option_app (fun p -> (p,etyp)) po
+
+let add_tactic_entries gl =
+  let univ = get_univ "tactic" in
+  let make_act s tac loc l = Tacexpr.TacAlias (loc,s,l,tac) in
+  let f (s,l,tac) =
+    make_rule univ (make_act s tac) (make_vprod_item "tactic") l in
+  let rules = List.map f gl in
+  let _ = find_position true true None None (* to synchronise with remove *) in
+  grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+
+let extend_grammar gram =
+  (match gram with
+  | Notation a -> extend_constr_notation a
+  | Grammar g -> extend_grammar_rules g
+  | TacticGrammar l -> add_tactic_entries l);
+  grammar_state := gram :: !grammar_state
+
+let reset_extend_grammars_v8 () =
+  let te = List.rev !tac_exts in
+  let tv = List.rev !vernac_exts in
+  tac_exts := [];
+  vernac_exts := [];
+  List.iter (fun (s,gl) -> extend_tactic_grammar s gl) te;
+  List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv
+
+
+(* Summary functions: the state of the lexer is included in that of the parser.
+   Because the grammar affects the set of keywords when adding or removing
+   grammar rules. *)
+type frozen_t = all_grammar_command list * Lexer.frozen_t
+
+let freeze () = (!grammar_state, Lexer.freeze ())
+
+(* We compare the current state of the grammar and the state to unfreeze, 
+   by computing the longest common suffixes *)
+let factorize_grams l1 l2 =
+  if l1 == l2 then ([], [], l1) else list_share_tails l1 l2
+
+let number_of_entries gcl =
+  List.fold_left
+    (fun n -> function
+      | Notation _ -> 
+          if !Options.v7 then n + 1
+	  else n + 2 (* 1 for operconstr, 1 for pattern *)
+      | Grammar gc ->
+          n + (List.length gc.gc_entries)
+      | TacticGrammar _ -> n + 1)
+    0 gcl
+
+let unfreeze (grams, lex) =
+  let (undo, redo, common) = factorize_grams !grammar_state grams in
+  let n = number_of_entries undo in
+  remove_grammars n;
+  remove_levels n;
+  grammar_state := common;
+  Lexer.unfreeze lex;
+  List.iter extend_grammar (List.rev redo)
+ 
+let init_grammar () =
+  remove_grammars (number_of_entries !grammar_state);
+  grammar_state := []
+
+let init () =
+  init_grammar ()
+
+open Summary
+
+let _ = 
+  declare_summary "GRAMMAR_LEXER"
+    { freeze_function = freeze;
+      unfreeze_function = unfreeze;
+      init_function = init;
+      survive_module = false;
+      survive_section = false }
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
new file mode 100644
index 00000000..c601c5fc
--- /dev/null
+++ b/parsing/egrammar.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: egrammar.mli,v 1.14.2.2 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Topconstr
+open Ast
+open Coqast
+open Vernacexpr
+open Extend
+open Rawterm
+(*i*)
+
+type all_grammar_command =
+  | Notation of
+      (int * Gramext.g_assoc option * notation * prod_item list *
+      int list option)
+  | Grammar of grammar_command
+  | TacticGrammar of
+      (string * (string * grammar_production list) * 
+      (Names.dir_path * Tacexpr.raw_tactic_expr))
+      list
+
+val extend_grammar : all_grammar_command -> unit
+
+(* Add grammar rules for tactics *)
+type grammar_tactic_production =
+  | TacTerm of string
+  | TacNonTerm of loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option
+
+val extend_tactic_grammar :
+  string -> (string * grammar_tactic_production list) list -> unit
+
+val extend_vernac_command_grammar :
+  string -> (string * grammar_tactic_production list) list -> unit
+
+val get_extend_tactic_grammars :
+ unit -> (string * (string * grammar_tactic_production list) list) list
+val get_extend_vernac_grammars :
+ unit -> (string * (string * grammar_tactic_production list) list) list
+val reset_extend_grammars_v8 : unit -> unit
+
+val subst_all_grammar_command :
+  Names.substitution -> all_grammar_command -> all_grammar_command
+
+val interp_entry_name : string -> string -> 
+  entry_type * Token.t Gramext.g_symbol
diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml
new file mode 100644
index 00000000..6a4758ab
--- /dev/null
+++ b/parsing/esyntax.ml
@@ -0,0 +1,276 @@
+(************************************************************************)
+(*  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: esyntax.ml,v 1.21.2.1 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Coqast
+open Ast
+open Extend
+open Ppextend
+open Names
+open Nametab
+open Topconstr
+open Symbols
+ 
+(*** Syntax keys ***)
+
+(* We define keys for ast and astpats. This is a kind of hash
+ * function.  An ast may have several keys, but astpat only one. The
+ * idea is that if an ast A matches a pattern P, then the key of P
+ * is in the set of keys of A. Thus, we can split the syntax entries
+ * according to the key of the pattern. *)
+
+type key =
+  | Cst of Names.constant (* keys for global constants rules *)
+  | SecVar of Names.variable
+  | Ind of Names.inductive
+  | Cstr of Names.constructor
+  | Nod of string      (* keys for other constructed asts rules *)
+  | Oth                (* key for other syntax rules *)
+  | All     (* key for catch-all rules (i.e. with a pattern such as $x .. *)
+
+let warning_verbose = ref true
+
+let ast_keys = function
+  | Node(_,"APPLIST", Node(_,"CONST", [Path (_,sl)]) ::_) ->
+      [Cst sl; Nod "APPLIST"; All]
+  | Node(_,"APPLIST", Node(_,"SECVAR", [Nvar (_,s)]) ::_) ->
+      [SecVar s; Nod "APPLIST"; All]
+  | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl); Num (_,tyi)]) ::_) ->
+      [Ind (sl,tyi); Nod "APPLIST"; All]
+  | Node(_,"APPLIST", Node(_,"MUTCONSTRUCT",
+			   [Path (_,sl); Num (_,tyi); Num (_,i)]) ::_) ->
+      [Cstr ((sl,tyi),i); Nod "APPLIST"; All]
+  | Node(_,s,_) -> [Nod s; All]
+  | _ -> [Oth; All]
+
+let spat_key astp =
+  match astp with
+    | Pnode("APPLIST",
+            Pcons(Pnode("CONST",
+                        Pcons(Pquote(Path (_,sl)),_)), _))
+      -> Cst sl
+    | Pnode("APPLIST",
+            Pcons(Pnode("SECVAR",
+                        Pcons(Pquote(Nvar (_,s)),_)), _))
+      -> SecVar s
+    | Pnode("APPLIST",
+            Pcons(Pnode("MUTIND",
+                        Pcons(Pquote(Path (_,sl)),
+			      Pcons(Pquote(Num (_,tyi)),_))), _))
+      -> Ind (sl,tyi)
+    | Pnode("APPLIST",
+            Pcons(Pnode("MUTCONSTRUCT",
+                        Pcons(Pquote(Path (_,sl)),
+			      Pcons(Pquote(Num (_,tyi)),
+				    Pcons(Pquote(Num (_,i)),_)))), _))
+      -> Cstr ((sl,tyi),i)
+    | Pnode(na,_) -> Nod na
+    | Pquote ast -> List.hd (ast_keys ast)
+    | Pmeta _ -> All
+    | _ -> Oth
+
+let se_key se = spat_key se.syn_astpat
+
+(** Syntax entry tables (state of the pretty_printer) **)
+let from_name_table = ref Gmap.empty
+let from_key_table = ref Gmapl.empty
+
+(* Summary operations *)
+type frozen_t = (string * string, astpat syntax_entry) Gmap.t * 
+                (string * key, astpat syntax_entry) Gmapl.t
+
+let freeze () =
+  (!from_name_table, !from_key_table)
+
+let unfreeze (fnm,fkm) =
+  from_name_table := fnm;
+  from_key_table := fkm
+
+let init () =
+  from_name_table := Gmap.empty;
+  from_key_table := Gmapl.empty
+
+let find_syntax_entry whatfor gt =
+  let gt_keys = ast_keys gt in
+  let entries =
+    List.flatten
+      (List.map (fun k -> Gmapl.find (whatfor,k) !from_key_table) gt_keys)
+  in 
+  find_all_matches (fun se -> se.syn_astpat) [] gt entries
+
+let remove_with_warning name =
+  if Gmap.mem name !from_name_table then begin
+    let se = Gmap.find name !from_name_table in
+    let key = (fst name, se_key se) in
+    if !warning_verbose then
+      (Options.if_verbose
+    	warning ("overriding syntax rule "^(fst name)^":"^(snd name)^"."));
+    from_name_table := Gmap.remove name !from_name_table;
+    from_key_table := Gmapl.remove key se !from_key_table
+  end
+
+let add_rule whatfor se =
+  let name = (whatfor,se.syn_id) in
+  let key = (whatfor, se_key se) in
+  remove_with_warning name;
+  from_name_table := Gmap.add name se !from_name_table;
+  from_key_table := Gmapl.add key se !from_key_table
+
+let add_ppobject {sc_univ=wf;sc_entries=sel} = List.iter (add_rule wf) sel
+
+
+(* Pretty-printing machinery *)
+
+type std_printer = Coqast.t -> std_ppcmds
+type unparsing_subfunction = string -> tolerability option -> std_printer
+type primitive_printer = Coqast.t -> std_ppcmds option
+
+(* Module of primitive printers *)
+module Ppprim =
+  struct
+    type t = std_printer -> std_printer
+    let tab = ref ([] : (string * t) list)
+    let map a = List.assoc a !tab
+    let add (a,ppr) = tab := (a,ppr)::!tab
+  end
+
+(**********************************************************************)
+(* Primitive printers (e.g. for numerals)                             *)
+
+(* This is the map associating to a printer the scope it belongs to   *)
+(* and its ML code                                                    *)
+
+let primitive_printer_tab = 
+  ref (Stringmap.empty : (scope_name * primitive_printer) Stringmap.t)
+let declare_primitive_printer s sc pp =
+  primitive_printer_tab := Stringmap.add s (sc,pp) !primitive_printer_tab
+let lookup_primitive_printer s =
+  Stringmap.find s !primitive_printer_tab
+
+(* Register the primitive printer for "token". It is not used in syntax/PP*.v,
+ * but any ast matching no PP rule is printed with it. *)
+(*
+let _ = declare_primitive_printer "token" token_printer
+*)
+
+(* A printer for the tokens. *)
+let token_printer stdpr = function
+  | (Id _ | Num _ | Str _ | Path _ as ast) -> print_ast ast
+  | a -> stdpr a
+
+(* Unused ??
+(* A primitive printer to do "print as" (to specify a length for a string) *)
+let print_as_printer = function
+  | Node (_, "AS", [Num(_,n); Str(_,s)]) -> Some (stras (n,s))
+  | ast                                  -> None
+
+let _ = declare_primitive_printer "print_as" default_scope print_as_printer
+*)
+
+(* Handle infix symbols *)
+
+let pr_parenthesis inherited se strm =
+  if tolerable_prec inherited se.syn_prec then
+    strm
+  else 
+    (str"(" ++ strm ++ str")")
+    
+let print_delimiters inh se strm = function
+  | None -> pr_parenthesis inh se strm
+  | Some key ->
+      let left = "'"^key^":" and right = "'" in
+      let lspace =
+	if is_letter (left.[String.length left -1]) then str " " else mt () in
+      let rspace =
+        let c = right.[0] in
+	if is_ident_tail c then str " " else mt () in
+      hov 0 (str left ++ lspace ++ strm ++ rspace ++ str right)
+
+(* Print the syntax entry. In the unparsing hunks, the tokens are
+ * printed using the token_printer, unless another primitive printer
+ * is specified. *)
+
+let print_syntax_entry sub_pr scopes env se = 
+  let rec print_hunk rule_prec scopes = function
+    | PH(e,externpr,reln) ->
+	let node = Ast.pat_sub dummy_loc env e in
+	let printer =
+	  match externpr with (* May branch to an other printer *)
+	    | Some c ->
+                (try (* Test for a primitive printer *) Ppprim.map c
+                with Not_found -> token_printer)
+	    | _ -> token_printer in
+	printer (sub_pr scopes (Some(rule_prec,reln))) node
+    | RO s -> str s
+    | UNP_TAB -> tab ()
+    | UNP_FNL -> fnl ()
+    | UNP_BRK(n1,n2) -> brk(n1,n2)
+    | UNP_TBRK(n1,n2) -> tbrk(n1,n2)
+    | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist (print_hunk rule_prec scopes) sub)
+    | UNP_SYMBOLIC _ -> anomaly "handled by call_primitive_parser"
+  in 
+  prlist (print_hunk se.syn_prec scopes) se.syn_hunks
+
+let call_primitive_parser rec_pr otherwise inherited scopes (se,env) =
+  try (
+  match se.syn_hunks with
+    | [PH(e,Some c,reln)] ->
+	  (* Test for a primitive printer; may raise Not_found *)
+	  let sc,pr = lookup_primitive_printer c in
+	  (* Look if scope [sc] associated to this printer is OK *)
+	  (match Symbols.availability_of_numeral sc scopes with
+	    | None -> otherwise ()
+	    | Some key ->
+	        (* We can use this printer *)
+	        let node = Ast.pat_sub dummy_loc env e in
+	        match pr node with
+		  | Some strm -> print_delimiters inherited se strm key
+		  | None -> otherwise ())
+    | [UNP_SYMBOLIC (sc,pat,sub)] ->
+	(match Symbols.availability_of_notation (sc,pat) scopes with
+	  | None -> otherwise ()
+	  | Some (scopt,key) ->
+	      print_delimiters inherited se
+		(print_syntax_entry rec_pr
+		  (option_fold_right Symbols.push_scope scopt scopes) env 
+		  {se with syn_hunks = [sub]}) key)
+    | _ ->
+	pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se)
+  )
+  with Not_found -> (* To handle old style printer *)
+	pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se)
+
+(* [genprint whatfor dflt inhprec ast] prints out the ast of
+ * 'universe' whatfor. If the term is not matched by any
+ * pretty-printing rule, then it will call dflt on it, which is
+ * responsible for printing out the term (usually #GENTERM...).
+ * In the case of tactics and commands, dflt also prints 
+ * global constants basenames. *)
+
+let genprint dflt whatfor inhprec ast =
+  let rec rec_pr scopes inherited gt =
+    let entries = find_syntax_entry whatfor gt in
+    let rec test_rule = function
+      | se_env::rules ->
+	  call_primitive_parser
+	    rec_pr 
+	    (fun () -> test_rule rules) 
+	    inherited scopes se_env
+      | [] -> dflt gt (* No rule found *)
+    in test_rule entries
+  in
+  try 
+    rec_pr (Symbols.current_scopes ()) inhprec ast
+  with
+    | Failure _ -> (str"<PP failure: " ++ dflt ast ++ str">")
+    | Not_found -> (str"<PP search failure: " ++ dflt ast ++ str">")
diff --git a/parsing/esyntax.mli b/parsing/esyntax.mli
new file mode 100644
index 00000000..e05e1ca4
--- /dev/null
+++ b/parsing/esyntax.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: esyntax.mli,v 1.10.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Extend
+open Symbols
+open Ppextend
+open Topconstr
+(*i*)
+
+(* Syntax entry tables. *)
+
+type frozen_t
+
+(* pretty-printer summary operations *)
+val init : unit -> unit
+val freeze : unit -> frozen_t
+val unfreeze : frozen_t -> unit
+
+(* Search and add a PP rule for an ast in the summary *)
+val find_syntax_entry :
+  string -> Coqast.t -> (Ast.astpat syntax_entry * Ast.env) list
+val add_rule : string -> Ast.astpat syntax_entry -> unit
+val add_ppobject : Ast.astpat syntax_command -> unit
+val warning_verbose : bool ref
+
+(* Pretty-printing *)
+
+type std_printer = Coqast.t -> std_ppcmds
+type unparsing_subfunction = string -> tolerability option -> std_printer
+type primitive_printer = Coqast.t -> std_ppcmds option
+
+(* Module of constr primitive printers [old style - no scope] *)
+module Ppprim :
+  sig
+    type t = std_printer -> std_printer
+    val add : string * t -> unit
+  end
+
+val declare_primitive_printer : 
+  string -> scope_name -> primitive_printer -> unit
+
+(*
+val declare_infix_symbol : Libnames.section_path -> string -> unit
+*)
+
+(* Generic printing functions *) 
+(*
+val token_printer: std_printer -> std_printer
+*)
+(*
+val print_syntax_entry : 
+  string -> unparsing_subfunction -> Ast.env -> Ast.astpat syntax_entry -> std_ppcmds
+*)
+val genprint : std_printer -> unparsing_subfunction
diff --git a/parsing/extend.ml b/parsing/extend.ml
new file mode 100644
index 00000000..2778de44
--- /dev/null
+++ b/parsing/extend.ml
@@ -0,0 +1,378 @@
+(************************************************************************)
+(*  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: extend.ml,v 1.20.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+open Util
+open Pp
+open Gramext
+open Names
+open Ast
+open Ppextend
+open Topconstr
+open Genarg
+
+type entry_type = argument_type
+
+type production_position =
+  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | InternalProd
+
+type production_level =
+  | NextLevel
+  | NumLevel of int
+
+type ('lev,'pos) constr_entry_key =
+  | ETIdent | ETReference | ETBigint
+  | ETConstr of ('lev * 'pos)
+  | ETPattern
+  | ETOther of string * string
+  | ETConstrList of ('lev * 'pos) * Token.pattern list
+
+type constr_production_entry =
+    (production_level,production_position) constr_entry_key
+type constr_entry = (int,unit) constr_entry_key
+type simple_constr_production_entry = (production_level,unit) constr_entry_key
+
+type nonterm_prod =
+  | ProdList0 of nonterm_prod
+  | ProdList1 of nonterm_prod * Token.pattern list
+  | ProdOpt of nonterm_prod
+  | ProdPrimitive of constr_production_entry
+
+type prod_item =
+  | Term of Token.pattern
+  | NonTerm of constr_production_entry *
+      (Names.identifier * constr_production_entry) option
+
+type grammar_rule = {
+  gr_name : string; 
+  gr_production : prod_item list; 
+  gr_action : constr_expr }
+
+type grammar_entry = { 
+  ge_name : constr_entry;
+  gl_assoc : Gramext.g_assoc option;
+  gl_rules : grammar_rule list }
+
+type grammar_command = { 
+  gc_univ : string; 
+  gc_entries : grammar_entry list }
+
+type grammar_associativity = Gramext.g_assoc option
+
+(**********************************************************************)
+(* Globalisation and type-checking of Grammar actions *)
+
+type entry_context = identifier list
+
+open Rawterm
+open Libnames
+
+let globalizer = ref (fun _ _ -> CHole dummy_loc)
+let set_constr_globalizer f = globalizer := f
+
+let act_of_ast vars = function
+  | SimpleAction (loc,ConstrNode a) -> !globalizer vars a
+  | SimpleAction (loc,CasesPatternNode a) -> 
+      failwith "TODO:act_of_ast: cases_pattern"
+  | CaseAction _ -> failwith "case/let not supported"
+
+let to_act_check_vars = act_of_ast
+
+type syntax_modifier =
+  | SetItemLevel of string list * production_level
+  | SetLevel of int
+  | SetAssoc of Gramext.g_assoc
+  | SetEntryType of string * simple_constr_production_entry
+  | SetOnlyParsing
+  | SetFormat of string located
+
+type nonterm =
+  | NtShort of string
+  | NtQual of string * string
+type grammar_production =
+  | VTerm of string
+  | VNonTerm of loc * nonterm * Names.identifier option
+type raw_grammar_rule = string * grammar_production list * grammar_action
+type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list
+
+(* No kernel names in Grammar's *)
+let subst_constr_expr _ a = a
+
+let subst_grammar_rule subst gr =
+  { gr with gr_action = subst_constr_expr subst gr.gr_action }
+
+let subst_grammar_entry subst ge =
+  { ge with gl_rules = List.map (subst_grammar_rule subst) ge.gl_rules }
+
+let subst_grammar_command subst gc =
+  { gc with gc_entries = List.map (subst_grammar_entry subst) gc.gc_entries }
+
+
+(*s Terminal symbols interpretation *)
+
+let is_ident_not_keyword s =
+  match s.[0] with
+    | 'a'..'z' | 'A'..'Z' | '_' -> not (Lexer.is_keyword s)
+    | _ -> false
+
+let is_number s =
+  match s.[0] with
+    | '0'..'9' -> true
+    | _ -> false
+
+let strip s =
+  let len =
+    let rec loop i len =
+      if i = String.length s then len
+      else if s.[i] == ' ' then loop (i + 1) len
+      else loop (i + 1) (len + 1)
+    in
+    loop 0 0
+  in
+  if len == String.length s then s
+  else
+    let s' = String.create len in
+    let rec loop i i' =
+      if i == String.length s then s'
+      else if s.[i] == ' ' then loop (i + 1) i'
+      else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end
+    in
+    loop 0 0
+
+let terminal s =
+  let s = strip s in
+  if s = "" then failwith "empty token";
+  if is_ident_not_keyword s then ("IDENT", s)
+  else if is_number s then ("INT", s)
+  else ("", s)
+
+(*s Non-terminal symbols interpretation *)
+
+(* For compatibility *)
+let warn nt nt' =
+  warning ("'"^nt^"' grammar entry is obsolete; use name '"^nt'^"' instead");
+  nt'
+
+let rename_command_entry nt =
+  if String.length nt >= 7 & String.sub nt 0 7 = "command"
+  then warn nt ("constr"^(String.sub nt 7 (String.length nt - 7)))
+  else if nt = "lcommand" then warn nt "lconstr"
+  else if nt = "lassoc_command4" then warn nt "lassoc_constr4"
+  else nt
+
+(* This translates constr0, constr1, ... level into camlp4 levels of constr *)
+
+let explicitize_prod_entry inj pos univ nt =
+  if univ = "prim" & nt = "var" then ETIdent else
+  if univ = "prim" & nt = "bigint" then ETBigint else
+  if univ <> "constr" then ETOther (univ,nt) else
+  match nt with
+  | "constr0" -> ETConstr (inj 0,pos)
+  | "constr1" -> ETConstr (inj 1,pos)
+  | "constr2" -> ETConstr (inj 2,pos)
+  | "constr3" -> ETConstr (inj 3,pos)
+  | "lassoc_constr4" -> ETConstr (inj 4,pos)
+  | "constr5" -> ETConstr (inj 5,pos)
+  | "constr6" -> ETConstr (inj 6,pos)
+  | "constr7" -> ETConstr (inj 7,pos)
+  | "constr8" -> ETConstr (inj 8,pos)
+  | "constr" when !Options.v7 -> ETConstr (inj 8,pos)
+  | "constr9" -> ETConstr (inj 9,pos)
+  | "constr10" | "lconstr" -> ETConstr (inj 10,pos)
+  | "pattern" -> ETPattern
+  | "ident" -> ETIdent
+  | "global" -> ETReference
+  | _ -> ETOther (univ,nt)
+
+let explicitize_entry = explicitize_prod_entry (fun x -> x) ()
+
+(* Express border sub entries in function of the from level and an assoc *)
+(* We're cheating: not necessarily the same assoc on right and left *)
+let clever_explicitize_prod_entry pos univ from en =
+  let t = explicitize_prod_entry (fun x -> NumLevel x) pos univ en in
+  match from with
+    | ETConstr (from,()) ->
+	(match t with
+	  | ETConstr (n,BorderProd (left,None))
+              when (n=NumLevel from & left) ->
+	      ETConstr (n,BorderProd (left,Some Gramext.LeftA))
+	  | ETConstr (NumLevel n,BorderProd (left,None))
+              when (n=from-1 & not left) ->
+	      ETConstr
+                (NumLevel (n+1),BorderProd (left,Some Gramext.LeftA))
+	  | ETConstr (NumLevel n,BorderProd (left,None))
+              when (n=from-1 & left) ->
+	      ETConstr
+                (NumLevel (n+1),BorderProd (left,Some Gramext.RightA))
+	  | ETConstr (n,BorderProd (left,None))
+              when (n=NumLevel from & not left) ->
+	      ETConstr (n,BorderProd (left,Some Gramext.RightA))
+	  | t -> t)
+    | _ -> t
+
+let qualified_nterm current_univ pos from = function
+  | NtQual (univ, en) ->
+      clever_explicitize_prod_entry pos univ from en
+  | NtShort en ->
+      clever_explicitize_prod_entry pos current_univ from en
+
+let check_entry check_entry_type = function
+  | ETOther (u,n) -> check_entry_type (u,n)
+  | _ -> ()
+
+let nterm loc (((check_entry_type,univ),from),pos) nont =
+  let typ = qualified_nterm univ pos from nont in
+  check_entry check_entry_type typ;
+  typ
+
+let prod_item univ env = function
+  | VTerm s -> env, Term (terminal s)
+  | VNonTerm (loc, nt, Some p) ->
+     let typ = nterm loc univ nt in
+      (p :: env, NonTerm (typ, Some (p,typ)))
+  | VNonTerm (loc, nt, None) ->
+      let typ = nterm loc univ nt in 
+      env, NonTerm (typ, None)
+
+let rec prod_item_list univ penv pil current_pos =
+  match pil with
+    | [] -> [], penv
+    | pi :: pitl ->
+	let pos = if pitl=[] then (BorderProd (false,None)) else current_pos in
+	let (env, pic) = prod_item (univ,pos) penv pi in
+	let (pictl, act_env) = prod_item_list univ env pitl InternalProd in
+        (pic :: pictl, act_env)
+
+let gram_rule univ (name,pil,act) =
+  let (pilc, act_env) = prod_item_list univ [] pil (BorderProd (true,None)) in
+  let a = to_act_check_vars act_env act in
+  { gr_name = name; gr_production = pilc; gr_action = a }
+
+let border = function
+  | NonTerm (ETConstr(_,BorderProd (_,a)),_) :: _ -> a
+  | _ -> None
+
+let clever_assoc ass g =
+  if g.gr_production <> [] then
+    (match border g.gr_production, border (List.rev g.gr_production) with
+      | Some LeftA, Some RightA -> ass (* Untractable; we cheat *)
+      | Some LeftA, _ -> Some LeftA
+      | _, Some RightA -> Some RightA
+      | _ -> Some NonA)
+  else ass
+
+let gram_entry univ (nt, ass, rl) =
+  let from = explicitize_entry (snd univ) nt in
+  let l = List.map (gram_rule (univ,from)) rl in
+  let ass = List.fold_left clever_assoc ass l in
+  { ge_name = from;
+    gl_assoc = ass;
+    gl_rules = l }
+
+let interp_grammar_command univ ge entryl =
+  { gc_univ = univ;
+    gc_entries = List.map (gram_entry (ge,univ)) entryl }
+
+(* unparsing objects *)
+
+type 'pat unparsing_hunk = 
+  | PH of 'pat * string option * parenRelation
+  | RO of string
+  | UNP_BOX of ppbox * 'pat unparsing_hunk list
+  | UNP_BRK of int * int
+  | UNP_TBRK of int * int
+  | UNP_TAB
+  | UNP_FNL
+  | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk
+
+let rec subst_hunk subst_pat subst hunk = match hunk with
+  | PH (pat,so,pr) ->
+      let pat' = subst_pat subst pat in
+	if pat'==pat then hunk else
+	  PH (pat',so,pr)
+  | RO _ -> hunk
+  | UNP_BOX (ppbox, hunkl) ->
+      let hunkl' = list_smartmap (subst_hunk subst_pat subst) hunkl in
+	if hunkl' == hunkl then hunk else
+	  UNP_BOX (ppbox, hunkl')
+  | UNP_BRK _
+  | UNP_TBRK _
+  | UNP_TAB
+  | UNP_FNL -> hunk
+  | UNP_SYMBOLIC (s1, s2, pat) ->
+      let pat' = subst_hunk subst_pat subst pat in
+	if pat' == pat then hunk else
+	  UNP_SYMBOLIC (s1, s2, pat')
+
+(* Checks if the precedence of the parent printer (None means the
+   highest precedence), and the child's one, follow the given
+   relation. *)
+
+let tolerable_prec oparent_prec_reln child_prec =
+  match oparent_prec_reln with
+    | Some (pprec, L) -> child_prec < pprec
+    | Some (pprec, E) -> child_prec <= pprec
+    | Some (_, Prec level) -> child_prec <= level
+    | _ -> true
+
+type 'pat syntax_entry = {
+  syn_id : string;
+  syn_prec: precedence;
+  syn_astpat : 'pat;
+  syn_hunks : 'pat unparsing_hunk list }
+
+let subst_syntax_entry subst_pat subst sentry = 
+  let syn_astpat' = subst_pat subst sentry.syn_astpat in
+  let syn_hunks' = list_smartmap (subst_hunk subst_pat subst) sentry.syn_hunks 
+  in
+    if syn_astpat' == sentry.syn_astpat 
+      && syn_hunks' == sentry.syn_hunks then sentry 
+    else
+      { sentry with
+	  syn_astpat = syn_astpat' ;
+	  syn_hunks = syn_hunks' ;
+      }
+      
+type 'pat syntax_command = { 
+  sc_univ : string; 
+  sc_entries : 'pat syntax_entry list }
+
+let subst_syntax_command subst_pat subst scomm = 
+  let sc_entries' = 
+    list_smartmap (subst_syntax_entry subst_pat subst) scomm.sc_entries 
+  in
+    if sc_entries' == scomm.sc_entries then scomm else
+      { scomm with sc_entries = sc_entries' }
+      
+type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list
+type raw_syntax_entry = precedence * syntax_rule list
+
+let rec interp_unparsing env = function
+  | PH (ast,ext,pr) -> PH (Ast.val_of_ast env ast,ext,pr)
+  | UNP_BOX (b,ul) -> UNP_BOX (b,List.map (interp_unparsing env) ul)
+  | UNP_BRK _ | RO _ | UNP_TBRK _ | UNP_TAB | UNP_FNL as x -> x
+  | UNP_SYMBOLIC (x,y,u) -> UNP_SYMBOLIC (x,y,interp_unparsing env u)
+
+let rule_of_ast univ prec (s,spat,unp) =
+  let (astpat,meta_env) = Ast.to_pat [] spat in
+  let hunks = List.map (interp_unparsing meta_env) unp in
+  { syn_id = s;
+    syn_prec = prec;
+    syn_astpat = astpat;
+    syn_hunks = hunks }
+
+let level_of_ast univ (prec,rl) = List.map (rule_of_ast univ prec) rl
+
+let interp_syntax_entry univ sel =
+  { sc_univ = univ;
+    sc_entries = List.flatten (List.map (level_of_ast univ) sel)}
+
+
diff --git a/parsing/extend.mli b/parsing/extend.mli
new file mode 100644
index 00000000..761d0e04
--- /dev/null
+++ b/parsing/extend.mli
@@ -0,0 +1,153 @@
+(************************************************************************)
+(*  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: extend.mli,v 1.19.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Ast
+open Coqast
+open Ppextend
+open Topconstr
+open Genarg
+(*i*)
+
+type entry_type = argument_type
+
+type production_position =
+  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | InternalProd
+
+type production_level =
+  | NextLevel
+  | NumLevel of int
+
+type ('lev,'pos) constr_entry_key =
+  | ETIdent | ETReference | ETBigint
+  | ETConstr of ('lev * 'pos)
+  | ETPattern
+  | ETOther of string * string
+  | ETConstrList of ('lev * 'pos) * Token.pattern list
+
+type constr_production_entry =
+    (production_level,production_position) constr_entry_key
+type constr_entry = (int,unit) constr_entry_key
+type simple_constr_production_entry = (production_level,unit) constr_entry_key
+
+type nonterm_prod =
+  | ProdList0 of nonterm_prod
+  | ProdList1 of nonterm_prod * Token.pattern list
+  | ProdOpt of nonterm_prod
+  | ProdPrimitive of constr_production_entry
+
+type prod_item =
+  | Term of Token.pattern
+  | NonTerm of constr_production_entry * 
+      (Names.identifier * constr_production_entry) option
+
+type grammar_rule = {
+  gr_name : string; 
+  gr_production : prod_item list; 
+  gr_action : constr_expr }
+
+type grammar_entry = { 
+  ge_name : constr_entry;
+  gl_assoc : Gramext.g_assoc option;
+  gl_rules : grammar_rule list }
+
+type grammar_command = { 
+  gc_univ : string; 
+  gc_entries : grammar_entry list }
+
+type grammar_associativity = Gramext.g_assoc option
+
+(* Globalisation and type-checking of Grammar actions *)
+type entry_context = identifier list
+
+val set_constr_globalizer : 
+  (entry_context -> constr_expr -> constr_expr) -> unit
+
+type syntax_modifier =
+  | SetItemLevel of string list * production_level
+  | SetLevel of int
+  | SetAssoc of Gramext.g_assoc
+  | SetEntryType of string * simple_constr_production_entry
+  | SetOnlyParsing
+  | SetFormat of string located
+
+type nonterm =
+  | NtShort of string
+  | NtQual of string * string
+type grammar_production =
+  | VTerm of string
+  | VNonTerm of loc * nonterm * Names.identifier option
+type raw_grammar_rule = string * grammar_production list * grammar_action
+type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list
+
+val terminal : string -> string * string
+
+val rename_command_entry : string -> string
+
+val explicitize_entry : string -> string -> constr_entry
+
+val subst_grammar_command : 
+  Names.substitution -> grammar_command -> grammar_command
+
+(* unparsing objects *)
+
+type 'pat unparsing_hunk = 
+  | PH of 'pat * string option * parenRelation
+  | RO of string
+  | UNP_BOX of ppbox * 'pat unparsing_hunk list
+  | UNP_BRK of int * int
+  | UNP_TBRK of int * int
+  | UNP_TAB
+  | UNP_FNL
+  | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk
+
+(*val subst_unparsing_hunk : 
+  Names.substitution -> (Names.substitution -> 'pat -> 'pat) -> 
+  'pat unparsing_hunk -> 'pat unparsing_hunk
+*)
+
+(* Checks if the precedence of the parent printer (None means the
+   highest precedence), and the child's one, follow the given
+   relation. *)
+
+val tolerable_prec : tolerability option -> precedence -> bool
+
+type 'pat syntax_entry = {
+  syn_id : string;
+  syn_prec: precedence;
+  syn_astpat : 'pat;
+  syn_hunks : 'pat unparsing_hunk list }
+
+val subst_syntax_entry : 
+  (Names.substitution -> 'pat -> 'pat) -> 
+  Names.substitution -> 'pat syntax_entry -> 'pat syntax_entry
+
+
+type 'pat syntax_command = { 
+  sc_univ : string; 
+  sc_entries : 'pat syntax_entry list }
+
+val subst_syntax_command : 
+  (Names.substitution -> 'pat -> 'pat) -> 
+  Names.substitution -> 'pat syntax_command -> 'pat syntax_command
+
+type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list
+type raw_syntax_entry = precedence * syntax_rule list
+
+val interp_grammar_command :
+  string -> (string * string -> unit) -> 
+      raw_grammar_entry list -> grammar_command
+
+val interp_syntax_entry :
+  string -> raw_syntax_entry list -> Ast.astpat syntax_command
diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4
new file mode 100644
index 00000000..c4badbc3
--- /dev/null
+++ b/parsing/g_basevernac.ml4
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  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: g_basevernac.ml4,v 1.83.2.2 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Coqast
+open Extend
+open Ppextend
+open Vernacexpr
+open Pcoq
+open Vernac_
+open Goptions
+open Constr
+open Prim
+
+let vernac_kw =
+  [ "Quit"; "Load"; "Compile"; "Fixpoint"; "CoFixpoint";
+    "Definition"; "Inductive"; "CoInductive"; 
+    "Theorem"; "Variable"; "Axiom"; "Parameter"; "Hypothesis";
+    "."; ">->" ]
+let _ = 
+  if !Options.v7 then
+    List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw
+
+let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr"
+let lstring = Gram.Entry.create "lstring"
+
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: class_rawexpr;
+
+  class_rawexpr:
+    [ [ IDENT "FUNCLASS" -> FunClass
+      | IDENT "SORTCLASS" -> SortClass
+      | qid = global -> RefClass qid ] ]
+  ;
+END;
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command lstring;
+
+  lstring:
+    [ [ s = STRING -> s ] ]
+  ;
+  comment:
+    [ [ c = constr -> CommentConstr c
+      | s = STRING -> CommentString s
+      | n = natural -> CommentInt n ] ]
+  ;
+  command:
+    [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l
+
+      (* System directory *)
+      | IDENT "Pwd" -> VernacChdir None
+      | IDENT "Cd" -> VernacChdir None
+      | IDENT "Cd"; dir = lstring -> VernacChdir (Some dir)
+
+      (* Toplevel control *)
+      | IDENT "Drop" -> VernacToplevelControl Drop
+      | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop
+      | "Quit" -> VernacToplevelControl Quit
+
+      (* Dump of the universe graph - to file or to stdout *) 
+      | IDENT "Dump"; IDENT "Universes"; fopt = OPT lstring ->
+	  VernacPrint (PrintUniverses fopt)
+
+      | IDENT "Locate"; l = locatable -> VernacLocate l
+
+      (* Managing load paths *)
+      | IDENT "Add"; IDENT "LoadPath"; dir = lstring; alias = as_dirpath ->
+	  VernacAddLoadPath (false, dir, alias)
+      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = lstring; 
+	  alias = as_dirpath -> VernacAddLoadPath (true, dir, alias)
+      | IDENT "Remove"; IDENT "LoadPath"; dir = lstring ->
+	  VernacRemoveLoadPath dir
+
+       (* For compatibility *)
+      | IDENT "AddPath"; dir = lstring; alias = as_dirpath ->
+	  VernacAddLoadPath (false, dir, alias)
+      | IDENT "AddRecPath"; dir = lstring; alias = as_dirpath ->
+	  VernacAddLoadPath (true, dir, alias)
+      | IDENT "DelPath"; dir = lstring ->
+	  VernacRemoveLoadPath dir
+
+      (* Printing (careful factorization of entries) *)
+      | IDENT "Print"; p = printable -> VernacPrint p
+      | IDENT "Print"; qid = global -> VernacPrint (PrintName qid)
+      | IDENT "Print" -> VernacPrint PrintLocalContext 
+      | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> 
+	  VernacPrint (PrintModuleType qid)
+      | IDENT "Print"; IDENT "Module"; qid = global -> 
+	  VernacPrint (PrintModule qid)
+      | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
+      | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid)
+
+      (* Searching the environment *)
+      | IDENT "Search"; qid = global; l = in_or_out_modules -> 
+	  VernacSearch (SearchHead qid, l)
+      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchPattern c, l)
+      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchRewrite c, l)
+      | IDENT "SearchAbout"; 
+	  sl = [ "["; l = LIST1 [ r = global -> SearchRef r
+                                  | s = lstring -> SearchString s ]; "]" -> l 
+   		 | qid = global -> [SearchRef qid] ];
+	  l = in_or_out_modules -> 
+	  VernacSearch (SearchAbout sl, l)
+
+      (* TODO: rapprocher Eval et Check *)
+      | IDENT "Eval"; r = Tactic.red_expr; "in";
+	  c = constr -> VernacCheckMayEval (Some r, None, c)
+      | IDENT "Check"; c = constr ->
+	  VernacCheckMayEval (None, None, c)
+      | "Type"; c = constr -> VernacGlobalCheck c      (* pas dans le RefMan *)
+
+      | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = lstring ->
+	  VernacAddMLPath (false, dir)
+      | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = lstring ->
+	  VernacAddMLPath (true, dir)
+(*
+      | IDENT "SearchIsos"; c = constr -> VernacSearch (SearchIsos c)
+*)
+
+      (* Pour intervenir sur les tables de paramètres *)
+
+      | "Set"; table = IDENT; field = IDENT; v = option_value ->
+  	  VernacSetOption (SecondaryTable (table,field),v)
+      | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
+  	  VernacAddOption (SecondaryTable (table,field),lv)
+      | "Set"; table = IDENT; field = IDENT ->
+  	  VernacSetOption (SecondaryTable (table,field),BoolValue true)
+      | IDENT "Unset"; table = IDENT; field = IDENT ->
+  	  VernacUnsetOption (SecondaryTable (table,field))
+      | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
+  	  VernacRemoveOption (SecondaryTable (table,field),lv)
+      | "Set"; table = IDENT; value = option_value ->
+  	  VernacSetOption (PrimaryTable table, value)
+      | "Set"; table = IDENT ->
+  	  VernacSetOption (PrimaryTable table, BoolValue true)
+      | IDENT "Unset"; table = IDENT ->
+  	  VernacUnsetOption (PrimaryTable table)
+
+      | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT ->
+	  VernacPrintOption (SecondaryTable (table,field))
+      | IDENT "Print"; IDENT "Table"; table = IDENT ->
+	  VernacPrintOption (PrimaryTable table)
+
+      | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> VernacAddOption (SecondaryTable (table,field), v)
+
+      (* Un value global ci-dessous va être caché par un field au dessus! *)
+      | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
+          VernacAddOption (PrimaryTable table, v)
+
+      | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> VernacMemOption (SecondaryTable (table,field), v)
+      | IDENT "Test"; table = IDENT; field = IDENT ->
+          VernacPrintOption (SecondaryTable (table,field))
+      | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value ->
+          VernacMemOption (PrimaryTable table, v)
+      | IDENT "Test"; table = IDENT ->
+          VernacPrintOption (PrimaryTable table)
+
+      | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
+        -> VernacRemoveOption (SecondaryTable (table,field), v)
+      | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
+	  VernacRemoveOption (PrimaryTable table, v) ] ]
+  ;
+  printable:
+    [ [ IDENT "Term"; qid = global -> PrintOpaqueName qid
+      | IDENT "All" -> PrintFullContext
+      | IDENT "Section"; s = global -> PrintSectionContext s
+      | IDENT "Grammar"; uni = IDENT; ent = IDENT ->
+          (* This should be in "syntax" section but is here for factorization*)
+	  PrintGrammar (uni, ent)
+      | IDENT "LoadPath" -> PrintLoadPath
+      | IDENT "Modules" -> PrintModules
+
+      | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
+      | IDENT "ML"; IDENT "Modules" -> PrintMLModules
+      | IDENT "Graph" -> PrintGraph
+      | IDENT "Classes" ->  PrintClasses
+      | IDENT "Coercions" -> PrintCoercions
+      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
+         -> PrintCoercionPaths (s,t)
+      | IDENT "Tables" -> PrintTables
+      | "Proof"; qid = global -> PrintOpaqueName qid
+      | IDENT "Hint" -> PrintHintGoal
+      | IDENT "Hint"; qid = global -> PrintHint qid
+      | IDENT "Hint"; "*" -> PrintHintDb
+      | IDENT "HintDb"; s = IDENT -> PrintHintDbName s
+      | IDENT "Scopes" -> PrintScopes
+      | IDENT "Scope"; s = IDENT -> PrintScope s
+      | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s
+      | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ]
+  ;
+  locatable:
+    [ [ qid = global -> LocateTerm qid
+      | IDENT "File"; f = lstring -> LocateFile f
+      | IDENT "Library"; qid = global -> LocateLibrary  qid
+      | s = lstring -> LocateNotation s ] ]
+  ;
+  option_value:
+    [ [ n  = integer   -> IntValue n
+      | s  = lstring    -> StringValue s ] ]
+  ;
+  option_ref_value:
+    [ [ id = global   -> QualidRefValue id
+      | s  = lstring   -> StringRefValue s ] ]
+  ;
+  as_dirpath:
+    [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
+  ;
+  in_or_out_modules:
+    [ [ IDENT "inside"; l = LIST1 global -> SearchInside l
+      | IDENT "outside"; l = LIST1 global -> SearchOutside l
+      | -> SearchOutside [] ] ]
+  ;
+END
+
+(* Grammar extensions *)
+
+(* automatic translation of levels *)
+let adapt_level n =
+  if n >= 10 then n*10 else
+    [| 0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100|].(n)
+
+let map_modl = function
+  | SetItemLevel(ids,NumLevel n) -> SetItemLevel(ids,NumLevel (adapt_level n))
+  | SetLevel n -> SetLevel(adapt_level n)
+  | m -> m
+	  
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: syntax;
+
+  univ:
+  [ [ univ = IDENT ->
+        set_default_action_parser (parser_type_from_name univ); univ ] ]
+  ;
+  syntax:
+   [ [ IDENT "Token"; s = lstring ->
+       Pp.warning "Token declarations are now useless"; VernacNop
+
+     | IDENT "Grammar"; IDENT "tactic"; IDENT "simple_tactic";
+        OPT [ ":"; IDENT "tactic" ]; ":=";
+        OPT "|"; tl = LIST0 grammar_tactic_rule SEP "|" -> 
+	  VernacTacticGrammar tl
+
+     | IDENT "Grammar"; u = univ;
+         tl = LIST1 grammar_entry SEP "with" -> 
+	   VernacGrammar (rename_command_entry u,tl)
+
+     | IDENT "Syntax"; u = univ; el = LIST1 syntax_entry SEP ";" ->
+         VernacSyntax (u,el)
+
+     | IDENT "Uninterpreted"; IDENT "Notation"; local = locality; s = lstring; 
+	 modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+         (s8,mv8) =
+             [IDENT "V8only";
+              s8=OPT lstring;
+              mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] ->
+                (s8,mv8)
+             | -> (None,None)] ->
+               let s8 = match s8 with Some s -> s | _ -> s in
+               let mv8 = match mv8 with
+                   Some mv8 -> mv8
+                 | _ -> List.map map_modl modl in
+	       VernacSyntaxExtension (local,Some (s,modl),Some(s8,mv8))
+
+     | IDENT "Uninterpreted"; IDENT "V8Notation"; local = locality; s = lstring; 
+	 modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] ->
+	   VernacSyntaxExtension (local,None,Some(s,modl))
+
+     | IDENT "Open"; local = locality; IDENT "Scope"; 
+	 sc = IDENT -> VernacOpenCloseScope (local,true, sc)
+
+     | IDENT "Close"; local = locality; IDENT "Scope"; 
+	 sc = IDENT -> VernacOpenCloseScope (local,false,sc)
+
+     | IDENT "Delimits"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
+	 VernacDelimiters (sc,key)
+
+     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; 
+       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
+
+     | IDENT "Arguments"; IDENT "Scope"; qid = global;
+         "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl)
+
+     | IDENT "Infix"; local = locality; a = entry_prec; n = OPT natural;
+         op = lstring; 
+         p = global;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc];
+         mv8 =
+              [IDENT "V8only";
+               a8=entry_prec;
+               n8=OPT natural;
+	       op8=OPT lstring;
+               mv8=["("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> []]
+		->
+		 (match (a8,n8,mv8,op8) with
+		   | None,None,[],None -> None
+		   | _,_,mv8,_ ->
+		       Some(op8,Metasyntax.merge_modifiers a8 n8 mv8))
+              | -> (* Means: rules are based on V7 rules *)
+		  Some (None,[]) ] ->
+		let mv = Metasyntax.merge_modifiers a n modl in
+		let v8 = Util.option_app (function (op8,mv8) ->
+		  let op8 = match op8 with None -> op | Some op -> op in
+		  let mv8 =
+		    if mv8=[] then
+		      let mv8 = List.map map_modl mv in
+		      let mv8 =	if List.for_all
+			(function SetLevel _ -> false | _ -> true) mv8
+		      then SetLevel 10 :: mv8 else mv8 in
+		      let mv8 = if List.for_all
+			(function SetAssoc _ -> false | _ -> true) mv8
+		      then SetAssoc Gramext.LeftA :: mv8 else mv8 in
+		      mv8
+		  else mv8 in
+		  (op8,mv8)) mv8 in
+		VernacInfix (local,(op,mv),p,v8,sc)
+     | IDENT "Distfix"; local = locality; a = entry_prec; n = natural; 
+	   s = lstring; p = global; sc = OPT [ ":"; sc = IDENT -> sc ] ->
+             let (a,s,c) = Metasyntax.translate_distfix a s p in
+	     let mv = Some(s,[SetLevel n;SetAssoc a]) in
+             VernacNotation (local,c,mv,mv,sc)
+(*
+	     VernacDistfix (local,a,n,s,p,sc)
+*)
+     | IDENT "Notation"; local = locality; id = ident; ":="; c = constr;
+         b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
+	 VernacSyntacticDefinition (id,c,local,b)
+     | IDENT "Notation"; local = locality; s = lstring; ":="; c = constr;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc ];
+         (s8,mv8) =
+             [IDENT "V8only";
+              s8=OPT lstring;
+              mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] ->
+		(s8,mv8)
+             | -> (* Means: rules are based on V7 rules *)
+		 None, Some [] ] ->
+	       let smv8 = match s8,mv8 with
+		 | None, None -> None   (* = only interpretation *)
+		 | Some s8, None -> Some (s8,[]) (* = only interp, new s *)
+		 | None, Some [] -> Some (s,List.map map_modl modl) (*like v7*)
+		 | None, Some mv8 -> Some (s,mv8) (* s like v7 *)
+		 | Some s8, Some mv8 -> Some (s8,mv8) in
+               VernacNotation (local,c,Some(s,modl),smv8,sc)
+     | IDENT "V8Notation"; local = locality; s = lstring; ":="; c = constr;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
+         VernacNotation (local,c,None,Some(s,modl),sc)
+
+     | IDENT "V8Infix"; local = locality; op8 = lstring; p = global;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc] ->
+           let mv8 = Metasyntax.merge_modifiers None None modl in
+           VernacInfix (local,("",[]),p,Some (op8,mv8),sc)
+
+     (* "Print" "Grammar" should be here but is in "command" entry in order 
+        to factorize with other "Print"-based vernac entries *)
+  ] ]
+  ;
+  locality:
+    [ [ IDENT "Local" -> true | -> false ] ]
+  ;
+  level:
+    [ [ IDENT "level"; n = natural -> NumLevel n
+      | IDENT "next"; IDENT "level" -> NextLevel ] ]
+  ;
+  syntax_modifier:
+    [ [ x = IDENT; IDENT "at"; lev = level -> SetItemLevel ([x],lev)
+      | x = IDENT; ","; l = LIST1 IDENT SEP ","; IDENT "at"; lev = level ->
+          SetItemLevel (x::l,lev)
+      | IDENT "at"; IDENT "level"; n = natural -> SetLevel n
+      | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
+      | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA
+      | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA
+      | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ)
+      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
+      | IDENT "format"; s = [s = lstring -> (loc,s)] -> SetFormat s ] ]
+  ;
+  syntax_extension_type:
+    [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference
+      | IDENT "bigint" -> ETBigint
+      | i=IDENT -> ETOther ("constr",i)
+    ] ]
+  ;
+  opt_scope:
+    [ [ IDENT "_" -> None | sc = IDENT -> Some sc ] ]
+  ;
+  (* Syntax entries for Grammar. Only grammar_entry is exported *)
+  grammar_entry:
+    [[ nont = IDENT; set_entry_type; ":=";
+       ep = entry_prec; OPT "|"; rl = LIST0 grammar_rule SEP "|" ->
+	 (rename_command_entry nont,ep,rl) ]]
+  ;
+  entry_prec:
+    [[ IDENT "LEFTA" -> Some Gramext.LeftA
+     | IDENT "RIGHTA" -> Some Gramext.RightA
+     | IDENT "NONA" -> Some Gramext.NonA
+     | -> None ]]
+  ;
+  grammar_tactic_rule:
+    [[ name = rule_name; "["; s = lstring; pil = LIST0 production_item; "]";
+       "->"; "["; t = Tactic.tactic; "]"  -> (name, (s,pil), t) ]]
+  ;
+  grammar_rule:
+    [[ name = rule_name; "["; pil = LIST0 production_item; "]"; "->";
+       a = action -> (name, pil, a) ]]
+  ;
+  rule_name:
+    [[ name = IDENT -> name ]]
+  ;
+  production_item:
+    [[ s = lstring -> VTerm s
+     | nt = non_terminal; po = OPT [ "("; p = METAIDENT; ")" -> p ] ->
+         match po with
+           | Some p -> VNonTerm (loc,nt,Some (Names.id_of_string p))
+           | _ -> VNonTerm (loc,nt,None) ]]
+  ;
+  non_terminal:
+    [[ u = IDENT; ":"; nt = IDENT ->
+        NtQual(rename_command_entry u, rename_command_entry nt)
+     | nt = IDENT -> NtShort (rename_command_entry nt) ]]
+  ;
+
+
+  (* Syntax entries for Syntax. Only syntax_entry is exported *)
+  syntax_entry:
+    [ [ IDENT "level"; p = precedence; ":";
+	OPT "|"; rl = LIST1 syntax_rule SEP "|" -> (p,rl) ] ]
+  ;
+  syntax_rule:
+    [ [ nm = IDENT; "["; s = astpat; "]"; "->"; u = unparsing -> (nm,s,u) ] ]
+  ;
+  precedence:
+    [ [ a = natural -> a
+(*      | "["; a1 = natural; a2 = natural; a3 = natural; "]" -> (a1,a2,a3)*)
+    ] ]
+  ;
+  unparsing:
+    [ [ "["; ll = LIST0 next_hunks; "]" -> ll ] ]
+  ;
+  next_hunks:
+    [ [ IDENT "FNL" -> UNP_FNL
+      | IDENT "TAB" -> UNP_TAB
+      | c = lstring -> RO c
+      | "[";
+        x =
+          [ b = box; ll = LIST0 next_hunks -> UNP_BOX (b,ll)
+          | n = natural; m = natural -> UNP_BRK (n, m)
+          | IDENT "TBRK"; n = natural; m = natural -> UNP_TBRK (n, m) ];
+        "]" -> x
+      | e = Prim.ast; oprec = OPT [ ":"; pr = paren_reln_or_extern -> pr ] ->
+          match oprec with
+	    | Some (ext,pr) -> PH (e,ext,pr)
+            | None -> PH (e,None,Any)
+ ]]
+  ;
+  box:
+    [ [ "<"; bk = box_kind; ">" -> bk ] ]
+  ;
+  box_kind:
+    [ [ IDENT "h"; n = natural -> PpHB n
+      | IDENT "v"; n = natural -> PpVB n
+      | IDENT "hv"; n = natural -> PpHVB n
+      | IDENT "hov"; n = natural -> PpHOVB n
+      | IDENT "t" -> PpTB ] ]
+  ;
+  paren_reln_or_extern:
+    [ [ IDENT "L" -> None, L
+      | IDENT "E" -> None, E
+      | pprim = lstring; precrec = OPT [ ":"; p = precedence -> p ] ->
+	  match precrec with
+	    | Some p -> Some pprim, Prec p
+            | None -> Some pprim, Any ] ]
+  ;
+  (* meta-syntax entries *)
+  astpat:
+    [ [ "<<" ; a = Prim.ast; ">>" -> a 
+      | a = Constr.constr -> 
+	  Termast.ast_of_rawconstr 
+	  (Constrintern.interp_rawconstr Evd.empty (Global.env()) a)
+    ] ]
+  ; 
+  action:
+    [ [ IDENT "let"; p = Prim.astlist; et = set_internal_entry_type;
+        "="; e1 = action; "in"; e = action -> Ast.CaseAction (loc,e1,et,[p,e])
+      | IDENT "case"; a = action; et = set_internal_entry_type; "of";
+        cl = LIST1 case SEP "|"; IDENT "esac" -> Ast.CaseAction (loc,a,et,cl)
+      | "["; a = default_action_parser; "]" -> Ast.SimpleAction (loc,a) ] ]
+  ;
+  case:
+    [[ p = Prim.astlist; "->"; a = action -> (p,a) ]]
+  ;
+  set_internal_entry_type:
+    [[ ":"; IDENT "ast"; IDENT "list" -> Ast.ETastl
+     | [ ":"; IDENT "ast" -> () | -> () ] -> Ast.ETast ]]
+  ;
+  set_entry_type:
+    [[ ":"; et = entry_type -> set_default_action_parser et
+     | -> () ]]
+  ;
+  entry_type:
+    [[ IDENT "ast"; IDENT "list" -> Util.error "type ast list no longer supported"
+     | IDENT "ast" -> Util.error "type ast no longer supported"
+     | IDENT "constr" -> ConstrParser
+     | IDENT "pattern" -> CasesPatternParser
+     | IDENT "tactic" -> assert false
+     | IDENT "vernac" -> Util.error "vernac extensions no longer supported" ] ]
+  ;
+END
diff --git a/parsing/g_cases.ml4 b/parsing/g_cases.ml4
new file mode 100644
index 00000000..b952305d
--- /dev/null
+++ b/parsing/g_cases.ml4
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  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: g_cases.ml4,v 1.27.2.1 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pcoq
+open Constr
+open Topconstr
+open Term
+open Libnames
+
+open Prim
+
+let pair loc =
+  Qualid (loc, Libnames.qualid_of_string "Coq.Init.Datatypes.pair")
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: operconstr pattern;
+
+  pattern:
+    [ [ r = Prim.reference -> CPatAtom (loc,Some r)
+      | IDENT "_" -> CPatAtom (loc,None)
+      (* Hack to parse syntax "(n)" as a natural number *)
+      | "("; G_constr.test_int_rparen; n = bigint; ")" ->
+	  (* Delimiter "N" moved to "nat" in V7 *)
+          CPatDelimiters (loc,"nat",CPatNumeral (loc,n))
+      | "("; p = compound_pattern; ")" -> p
+      | n = bigint -> CPatNumeral (loc,n)
+      | "'"; G_constr.test_ident_colon; key = IDENT; ":"; c = pattern; "'" -> 
+          CPatDelimiters (loc,key,c)
+    ] ]
+  ;
+  compound_pattern:
+    [ [ p = pattern ; lp = LIST1 pattern ->
+        (match p with
+          | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
+          | _ -> Util.user_err_loc 
+              (loc, "compound_pattern", Pp.str "Constructor expected"))
+      | p = pattern; "as"; id = base_ident ->
+	  CPatAlias (loc, p, id)
+      | p1 = pattern; ","; p2 = pattern ->
+	  CPatCstr (loc, pair loc, [p1; p2])
+      | p = pattern -> p ] ]
+  ;
+  equation:
+    [ [ lhs = LIST1 pattern; "=>"; rhs = operconstr LEVEL "9" -> (loc,lhs,rhs) ] ]
+  ;
+  ne_eqn_list:
+    [ [ leqn = LIST1 equation SEP "|" -> leqn ] ]
+  ;
+  operconstr: LEVEL "1"
+    [ [ "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of";
+        OPT "|"; eqs = ne_eqn_list; "end" ->
+          let lc = List.map (fun c -> c,(None,None)) lc in
+	  CCases (loc, (Some p,None), lc, eqs)
+      | "Cases"; lc = LIST1 constr; "of";
+	OPT "|"; eqs = ne_eqn_list; "end" ->
+          let lc = List.map (fun c -> c,(None,None)) lc in
+	  CCases (loc, (None,None), lc, eqs)
+      | "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of"; "end" ->
+          let lc = List.map (fun c -> c,(None,None)) lc in
+	  CCases (loc, (Some p,None), lc, [])
+      | "Cases"; lc = LIST1 constr; "of"; "end" -> 
+          let lc = List.map (fun c -> c,(None,None)) lc in
+	  CCases (loc, (None,None), lc, []) ] ]
+  ;
+END;
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
new file mode 100644
index 00000000..7b0f7da2
--- /dev/null
+++ b/parsing/g_constr.ml4
@@ -0,0 +1,368 @@
+(************************************************************************)
+(*  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: g_constr.ml4,v 1.52.2.1 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pcoq
+open Constr
+open Rawterm
+open Term
+open Names
+open Libnames
+open Prim
+open Topconstr
+
+(* Initialize the lexer *)
+let constr_kw =
+  [ "Cases"; "of"; "with"; "end"; "as"; "in"; "Prop"; "Set"; "Type";
+    ":"; "("; ")"; "["; "]"; "{"; "}"; ","; ";"; "->"; "="; ":="; "!";
+    "::"; "<:"; ":<"; "=>"; "<"; ">"; "|"; "?"; "/";
+    "<->"; "\\/"; "/\\"; "`"; "``"; "&"; "*"; "+"; "@"; "^"; "#"; "-";
+    "~"; "'"; "<<"; ">>"; "<>"
+  ]
+let _ =
+  if !Options.v7 then
+  List.iter (fun s -> Lexer.add_token ("",s)) constr_kw
+(* "let" is not a keyword because #Core#let.cci would not parse.
+   Is it still accurate ? *)
+
+
+let coerce_to_var = function
+  | CRef (Ident (_,id)) -> id
+  | ast -> Util.user_err_loc
+        (constr_loc ast,"Ast.coerce_to_var",
+         (Pp.str"This expression should be a simple identifier"))
+
+let coerce_to_name = function
+  | CRef (Ident (loc,id)) -> (loc, Name id)
+  | ast -> Util.user_err_loc
+        (constr_loc ast,"Ast.coerce_to_var",
+         (Pp.str"This expression should be a simple identifier"))
+
+let set_loc loc = function
+  | CRef(Ident(_,i)) -> CRef(Ident(loc,i))
+  | CRef(Qualid(_,q)) -> CRef(Qualid(loc,q))
+  | CFix(_,x,a) -> CFix(loc,x,a)
+  | CCoFix(_,x,a) -> CCoFix(loc,x,a)
+  | CArrow(_,a,b) -> CArrow(loc,a,b)
+  | CProdN(_,bl,a) -> CProdN(loc,bl,a)
+  | CLambdaN(_,bl,a) -> CLambdaN(loc,bl,a)
+  | CLetIn(_,x,a,b) -> CLetIn(loc,x,a,b)
+  | CAppExpl(_,f,a) -> CAppExpl(loc,f,a)
+  | CApp(_,f,a) -> CApp(loc,f,a)
+  | CCases(_,p,a,br) -> CCases(loc,p,a,br)
+  | COrderedCase(_,s,p,a,br) -> COrderedCase(loc,s,p,a,br)
+  | CLetTuple(_,ids,p,a,b) -> CLetTuple(loc,ids,p,a,b)
+  | CIf(_,e,p,a,b) -> CIf(loc,e,p,a,b)
+  | CHole _ -> CHole loc
+  | CPatVar(_,v) -> CPatVar(loc,v)
+  | CEvar(_,ev) -> CEvar(loc,ev)
+  | CSort(_,s) -> CSort(loc,s)
+  | CCast(_,a,b) -> CCast(loc,a,b)
+  | CNotation(_,n,l) -> CNotation(loc,n,l)
+  | CNumeral(_,i) -> CNumeral(loc,i)
+  | CDelimiters(_,s,e) -> CDelimiters(loc,s,e)
+  | CDynamic(_,d) -> CDynamic(loc,d)
+
+open Util
+
+let rec abstract_constr loc c = function
+  | [] -> c
+  | LocalRawDef ((loc',x),b)::bl ->
+      CLetIn (join_loc loc' loc, (loc', x), b, abstract_constr loc c bl)
+  | LocalRawAssum (nal,t)::bl ->
+      let loc' = join_loc (fst (List.hd nal)) loc in
+      CLambdaN(loc', [nal, t], abstract_constr loc c bl)
+
+(* Hack to parse "(n)" as nat without conflicts with the (useless) *)
+(* admissible notation "(n)" *)
+let test_int_rparen =
+  Gram.Entry.of_parser "test_int_rparen"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("INT", _)] ->
+            begin match Stream.npeek 2 strm with
+              | [_; ("", ")")] -> ()
+              | _ -> raise Stream.Failure
+            end
+        | _ -> raise Stream.Failure)
+
+(* Hack to parse "n" at level 0 without conflicting with "n!" at level 91 *)
+(* admissible notation "(n)" *)
+let test_int_bang =
+  Gram.Entry.of_parser "test_int_bang"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("INT", n)] ->
+            begin match Stream.npeek 2 strm with
+              | [_; ("", "!")] -> ()
+              | _ -> raise Stream.Failure
+            end
+        | _ -> raise Stream.Failure)
+
+(* Hack to parse "`id:...`" at level 0 without conflicting with
+   "`...`" from ZArith *)
+let test_ident_colon =
+  Gram.Entry.of_parser "test_ident_colon"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("IDENT", _)] ->
+            begin match Stream.npeek 2 strm with
+              | [_; ("", ":")] -> ()
+              | _ -> raise Stream.Failure
+            end
+        | _ -> raise Stream.Failure)
+
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: operconstr lconstr constr sort global constr_pattern Constr.ident annot
+          (*ne_name_comma_list*);
+  Constr.ident:
+    [ [ id = Prim.ident -> id
+
+      (* This is used in quotations and Syntax *)
+      | id = METAIDENT -> id_of_string id ] ]
+  ;
+  global:
+    [ [ r = Prim.reference -> r
+
+      (* This is used in quotations *)
+      | id = METAIDENT -> Ident (loc,id_of_string id) ] ]
+  ;
+  constr_pattern:
+    [ [ c = constr -> c ] ]
+  ;
+  ne_constr_list:
+    [ [ cl = LIST1 constr -> cl ] ]
+  ;
+  sort:
+    [ [ "Set"  -> RProp Pos
+      | "Prop" -> RProp Null
+      | "Type" -> RType None ] ]
+  ;
+  constr:
+    [ [ c = operconstr LEVEL "8" -> c ] ]
+  ;
+  lconstr:
+    [ [ c = operconstr LEVEL "10" -> c ] ]
+  ;
+  operconstr:
+    [ "10" RIGHTA
+      [ "!"; f = global; args = LIST0 (operconstr LEVEL "9") ->
+          CAppExpl (loc, (None,f), args)
+(*
+      | "!"; f = global; "with"; b = binding_list ->
+	  <:ast< (APPLISTWITH $f $b) >>
+*)
+      | f = operconstr; args = LIST1 constr91 -> CApp (loc, (None,f), args) ]
+    | "9" RIGHTA
+      [ c1 = operconstr; "::"; c2 = operconstr LEVEL "9" -> CCast (loc, c1, c2) ]
+    | "8" RIGHTA
+      [ c1 = operconstr; "->"; c2 = operconstr LEVEL "8"-> CArrow (loc, c1, c2) ]
+    | "1" RIGHTA
+      [ "<"; p = annot; ">"; IDENT "Match"; c = constr; "with";
+        cl = LIST0 constr; "end" ->
+	  COrderedCase (loc, MatchStyle, Some p, c, cl)
+      | "<"; p = annot; ">"; IDENT "Case"; c = constr; "of";
+        cl = LIST0 constr; "end" ->
+	  COrderedCase (loc, RegularStyle, Some p, c, cl)
+      | IDENT "Case"; c = constr; "of"; cl = LIST0 constr; "end" ->
+          COrderedCase (loc, RegularStyle, None, c, cl)
+      | IDENT "Match"; c = constr; "with"; cl = LIST1 constr; "end" ->
+          COrderedCase (loc, MatchStyle, None, c, cl)
+      | IDENT "let"; "("; b = ne_name_comma_list; ")"; "=";
+        c = constr; "in"; c1 = constr ->
+          (* TODO: right loc *)
+	  COrderedCase
+            (loc, LetStyle, None, c, [CLambdaN (loc, [b, CHole loc], c1)])
+      | IDENT "let"; na = name; "="; c = opt_casted_constr; 
+	"in"; c1 = constr ->
+          CLetIn (loc, na, c, c1)
+      | IDENT "if"; c1 = constr;
+        IDENT "then"; c2 = constr;
+        IDENT "else"; c3 = constr ->
+	  COrderedCase (loc, IfStyle, None, c1, [c2; c3])
+      | "<"; p = annot; ">";
+        IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; c = constr; 
+        "in"; c1 = constr ->
+          (* TODO: right loc *)
+	  COrderedCase (loc, LetStyle, Some p, c,
+            [CLambdaN (loc, [b, CHole loc], c1)])
+      | "<"; p = annot; ">";
+        IDENT "if"; c1 = constr;
+        IDENT "then"; c2 = constr; 
+        IDENT "else"; c3 = constr ->
+	  COrderedCase (loc, IfStyle, Some p, c1, [c2; c3])
+      | ".."; c = operconstr LEVEL "0"; ".." ->
+          CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ]
+    | "0" RIGHTA
+      [ "?" -> CHole loc
+      | "?"; n = Prim.natural -> CPatVar (loc, (false,Pattern.patvar_of_int n))
+      | bll = binders; c = constr -> abstract_constr loc c bll
+      (* Hack to parse syntax "(n)" as a natural number *)
+      | "("; test_int_rparen; n = bigint; ")" ->
+	  (* Delimiter "N" moved to "nat" in V7 *)
+          CDelimiters (loc,"nat",CNumeral (loc,n))
+      | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_tail ->
+          let id = coerce_to_name lc1 in
+	  CProdN (loc, ([id], c)::bl, body)
+(* TODO: Syntaxe (_:t...)t et (_,x...)t *)
+      | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr;
+        (bl,body) = product_tail ->
+          let id1 = coerce_to_name lc1 in
+          let id2 = coerce_to_name lc2 in
+	  CProdN (loc, ([id1; id2], c)::bl, body)
+      | "("; lc1 = lconstr; ","; lc2 = lconstr; ",";
+        idl = ne_name_comma_list; ":"; c = constr; (bl,body) = product_tail ->
+          let id1 = coerce_to_name lc1 in
+          let id2 = coerce_to_name lc2 in
+	  CProdN (loc, (id1::id2::idl, c)::bl, body)
+      | "("; lc1 = lconstr; ")" ->
+          if Options.do_translate() then set_loc loc lc1 else lc1
+      | "("; lc1 = lconstr; ")"; "@"; "["; cl = ne_constr_list; "]" ->
+	  (match lc1 with
+	    | CPatVar (loc2,(false,n)) -> 
+                CApp (loc,(None,CPatVar (loc2, (true,n))), List.map (fun c -> c, None) cl)
+	    | _ ->
+	    Util.error "Second-order pattern-matching expects a head metavariable")
+      | IDENT "Fix"; id = identref; "{"; fbinders = fixbinders; "}" ->
+	  CFix (loc, id, fbinders)
+      | IDENT "CoFix"; id = identref; "{"; fbinders = cofixbinders; "}" ->
+	  CCoFix (loc, id, fbinders)
+      | IDENT "Prefix" ; "(" ;  s = STRING ; cl = LIST0 constr ; ")" ->
+	  CNotation(loc, s, cl)
+      | s = sort -> CSort (loc, s)
+      | v = global -> CRef v
+      | n = bigint -> CNumeral (loc,n)
+      | "!"; f = global -> CAppExpl (loc,(None,f),[])
+      | "'"; test_ident_colon; key = IDENT; ":"; c = constr; "'" -> 
+	  (* Delimiter "N" implicitly moved to "nat" in V7 *)
+	  let key = if key = "N" then "nat" else key in
+	  let key = if key = "P" then "positive" else key in
+	  let key = if key = "T" then "type" else key in
+	  CDelimiters (loc,key,c) ] ]
+  ;
+  constr91:
+    [ [ test_int_bang; n = INT; "!"; c = operconstr LEVEL "9" ->
+        (c, Some (loc,ExplByPos (int_of_string n)))
+      | c = operconstr LEVEL "9" -> (c, None) ] ]
+  ;
+  (* annot and product_annot_tail are hacks to forbid concrete syntax *)
+  (* ">" (e.g. for gt, Zgt, ...) in annotations *)
+  annot:
+    [ RIGHTA
+      [ bll = binders; c = annot -> abstract_constr loc c bll 
+      | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_annot_tail ->
+          let id = coerce_to_name lc1 in
+	  CProdN (loc, ([id], c)::bl, body)
+      | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr;
+        (bl,body) = product_annot_tail ->
+          let id1 = coerce_to_name lc1 in
+          let id2 = coerce_to_name lc2 in
+	  CProdN (loc, ([id1; id2], c)::bl, body)
+      | "("; lc1 = lconstr; ","; lc2 = lconstr; ",";
+        idl = ne_name_comma_list; ":"; c = constr;
+	(bl,body) = product_annot_tail ->
+          let id1 = coerce_to_name lc1 in
+          let id2 = coerce_to_name lc2 in
+	  CProdN (loc, (id1::id2::idl, c)::bl, body)
+      | "("; lc1 = lconstr; ")" -> lc1
+      | c1 = annot; "->"; c2 = annot -> CArrow (loc, c1, c2) ]
+    | RIGHTA 
+      [ c1 = annot; "\\/"; c2 = annot -> CNotation (loc, "_ \\/ _", [c1;c2]) ]
+    | RIGHTA
+      [ c1 = annot; "/\\"; c2 = annot -> CNotation (loc, "_ /\\ _", [c1;c2]) ]
+    | RIGHTA
+      [ "~"; c = SELF -> CNotation (loc, "~ _", [c]) ]
+    | RIGHTA
+      [ c1 = SELF; "=="; c2 = NEXT -> CNotation (loc, "_ == _", [c1;c2]) ]
+    | RIGHTA
+      [ c1 = SELF; "="; c2 = NEXT -> CNotation (loc, "_ = _", [c1;c2]) ]
+    | [ c = operconstr LEVEL "4L" -> c ] ]
+  ;
+  product_annot_tail:
+    [ [ ";"; idl = ne_name_comma_list; ":"; c = constr;
+        (bl,c2) = product_annot_tail -> ((idl, c)::bl, c2)
+      | ";"; idl = ne_name_comma_list; (bl,c2) = product_annot_tail ->
+          ((idl, CHole (fst (List.hd idl)))::bl, c2)
+      | ")"; c = annot -> ([], c) ] ]
+  ;
+  ne_name_comma_list:
+    [ [ nal = LIST1 name SEP "," -> nal ] ]
+  ;
+  name_comma_list_tail:
+    [ [ ","; idl = ne_name_comma_list -> idl
+      | -> [] ] ]
+  ;
+  opt_casted_constr:
+    [ [ c = constr;  ":"; t = constr -> CCast (loc, c, t)
+      | c = constr -> c ] ]
+  ;
+  vardecls:
+    [ [ na = name; nal = name_comma_list_tail; c = type_option ->
+          LocalRawAssum (na::nal,c)
+      | na = name; "="; c = opt_casted_constr ->
+          LocalRawDef (na, c)
+      | na = name; ":="; c = opt_casted_constr ->
+          LocalRawDef (na, c)
+
+      (* This is used in quotations *)
+      | id = METAIDENT; c = type_option -> LocalRawAssum ([loc, Name (id_of_string id)], c)
+    ] ]
+  ;
+  ne_vardecls_list:
+    [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl
+      | id = vardecls -> [id] ] ]
+  ;
+  binders:
+    [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ]
+  ;
+  simple_params:
+    [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c)
+      | idl = LIST1 name SEP "," -> (idl, CHole loc)
+    ] ]
+  ;
+  simple_binders:
+    [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ]
+  ;
+  ne_simple_binders_list:
+    [ [ bll = LIST1 simple_binders -> List.flatten bll ] ]
+  ;
+  type_option:
+    [ [ ":"; c = constr -> c 
+      | -> CHole loc ] ]
+  ;
+  fixbinder:
+    [ [ id = base_ident; "/"; recarg = natural; ":"; type_ = constr;
+        ":="; def = constr ->
+          (id, recarg-1, [], type_, def)
+      | id = base_ident; bl = ne_simple_binders_list; ":"; type_ = constr;
+	":="; def = constr ->
+          let ni = List.length (List.flatten (List.map fst bl)) -1 in
+          let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in
+	  (id, ni, bl, type_, def) ] ]
+  ;
+  fixbinders:
+    [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ]
+  ;
+  cofixbinder:
+    [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr ->
+          (id, [],type_, def) ] ]
+  ;
+  cofixbinders:
+    [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ]
+  ;
+  product_tail:
+    [ [ ";"; idl = ne_name_comma_list; ":"; c = constr;
+        (bl,c2) = product_tail -> ((idl, c)::bl, c2)
+      | ";"; idl = ne_name_comma_list; (bl,c2) = product_tail ->
+          ((idl, CHole (fst (List.hd idl)))::bl, c2)
+      | ")"; c = constr -> ([], c) ] ]
+  ;
+END;;
diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4
new file mode 100644
index 00000000..18dc5683
--- /dev/null
+++ b/parsing/g_constrnew.ml4
@@ -0,0 +1,336 @@
+(************************************************************************)
+(*  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: g_constrnew.ml4,v 1.41.2.1 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pcoq
+open Constr
+open Prim
+open Rawterm
+open Term
+open Names
+open Libnames
+open Topconstr
+
+open Util
+
+let constr_kw =
+  [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; 
+    "end"; "as"; "let"; "if"; "then"; "else"; "return";
+    "Prop"; "Set"; "Type"; ".("; "_" ]
+
+let _ = 
+  if not !Options.v7 then
+    List.iter (fun s -> Lexer.add_token("",s)) constr_kw
+
+(* For Correctness syntax; doesn't work if in psyntax (freeze pb?)  *)
+let _ = Lexer.add_token ("","!")
+
+let mk_cast = function
+    (c,(_,None)) -> c
+  | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, ty)
+
+let mk_lam = function
+    ([],c) -> c
+  | (bl,c) -> CLambdaN(constr_loc c, bl,c)
+
+let mk_match (loc,cil,rty,br) =
+  CCases(loc,(None,rty),cil,br)
+
+let loc_of_binder_let = function
+  | LocalRawAssum ((loc,_)::_,_)::_ -> loc
+  | LocalRawDef ((loc,_),_)::_ -> loc
+  | _ -> dummy_loc
+
+let rec mkCProdN loc bll c =
+  match bll with
+  | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> 
+      CProdN (loc,[idl,t],mkCProdN (join_loc loc1 loc) bll c)
+  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
+      CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c)
+  | [] -> c
+  | LocalRawAssum ([],_) :: bll -> mkCProdN loc bll c
+
+let rec mkCLambdaN loc bll c =
+  match bll with
+  | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> 
+      CLambdaN (loc,[idl,t],mkCLambdaN (join_loc loc1 loc) bll c)
+  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
+      CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c)
+  | [] -> c
+  | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c
+
+let rec index_of_annot loc bl ann =
+  match names_of_local_assums bl,ann with
+    | [_], None -> 0
+    | lids, Some x ->
+        let ids = List.map snd lids in
+        (try list_index (snd x) ids - 1
+        with Not_found ->
+          user_err_loc(fst x,"index_of_annot", Pp.str"no such fix variable"))
+    | _ -> user_err_loc(loc,"index_of_annot",
+      Pp.str "cannot guess decreasing argument of fix")
+
+let mk_fixb (id,bl,ann,body,(loc,tyc)) =
+  let n = index_of_annot (fst id) bl ann in
+  let ty = match tyc with
+      Some ty -> ty
+    | None -> CHole loc in
+  (snd id,n,bl,ty,body)
+
+let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
+  let _ = option_app (fun (aloc,_) ->
+    Util.user_err_loc
+      (aloc,"Constr:mk_cofixb",
+       Pp.str"Annotation forbidden in cofix expression")) ann in
+  let ty = match tyc with
+      Some ty -> ty
+    | None -> CHole loc in
+  (snd id,bl,ty,body)
+
+let mk_fix(loc,kw,id,dcls) =
+  if kw then 
+    let fb = List.map mk_fixb dcls in
+    CFix(loc,id,fb)
+  else
+    let fb = List.map mk_cofixb dcls in
+    CCoFix(loc,id,fb)
+
+let mk_single_fix (loc,kw,dcl) =
+  let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl])
+
+let binder_constr =
+  create_constr_entry (get_univ "constr") "binder_constr"
+
+(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
+(* admissible notation "(x t)" *)
+let lpar_id_coloneq =
+  Gram.Entry.of_parser "test_lpar_id_coloneq"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+	      | [_; ("IDENT",s)] ->
+                  (match Stream.npeek 3 strm with
+                    | [_; _; ("", ":=")] ->
+                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+                        Names.id_of_string s
+	            | _ -> raise Stream.Failure)
+              | _ -> raise Stream.Failure)
+        | _ -> raise Stream.Failure)
+
+
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: binder_constr lconstr constr operconstr sort global
+  constr_pattern lconstr_pattern Constr.ident binder binder_let pattern;
+  Constr.ident:
+    [ [ id = Prim.ident -> id
+
+      (* This is used in quotations and Syntax *)
+      | id = METAIDENT -> id_of_string id ] ]
+  ;
+  Prim.name:
+    [ [ "_" -> (loc, Anonymous) ] ]
+  ;
+  Prim.ast:
+    [ [ "_" -> Coqast.Nvar(loc,id_of_string"_") ] ]
+  ;
+  global:
+    [ [ r = Prim.reference -> r
+
+      (* This is used in quotations *)
+      | id = METAIDENT -> Ident (loc,id_of_string id) ] ]
+  ;
+  constr_pattern:
+    [ [ c = constr -> c ] ]
+  ;
+  lconstr_pattern:
+    [ [ c = lconstr -> c ] ]
+  ;
+  sort:
+    [ [ "Set"  -> RProp Pos
+      | "Prop" -> RProp Null
+      | "Type" -> RType None ] ]
+  ;
+  lconstr:
+    [ [ c = operconstr LEVEL "200" -> c ] ]
+  ;
+  constr:
+    [ [ c = operconstr LEVEL "9" -> c ] ]
+  ;
+  operconstr:
+    [ "200" RIGHTA
+      [ c = binder_constr -> c ]
+    | "100" RIGHTA
+      [ c1 = operconstr; ":"; c2 = binder_constr -> CCast(loc,c1,c2)
+      | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1,c2) ]
+    | "99" RIGHTA [ ]
+    | "90" RIGHTA
+      [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2)
+      | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)]
+    | "10" LEFTA
+      [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args)
+      | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) ]
+    | "9"
+        [ ".."; c = operconstr LEVEL "0"; ".." ->
+          CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ]
+    | "1" LEFTA
+      [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" ->
+	CApp(loc,(Some (List.length args+1),CRef f),args@[c,None])
+      | c=operconstr; ".("; "@"; f=global;
+        args=LIST0 (operconstr LEVEL "9"); ")" ->
+        CAppExpl(loc,(Some (List.length args+1),f),args@[c]) 
+      | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ]
+    | "0"
+      [ c=atomic_constr -> c
+      | c=match_constr -> c
+      | "("; c = operconstr LEVEL "200"; ")" ->
+          (match c with
+              CNumeral(_,Bignat.POS _) -> CNotation(loc,"( _ )",[c])
+            | _ -> c) ] ]
+  ;
+  binder_constr:
+    [ [ "forall"; bl = binder_list; ","; c = operconstr LEVEL "200" ->
+          mkCProdN loc bl c
+      | "fun"; bl = binder_list; "=>"; c = operconstr LEVEL "200" ->
+          mkCLambdaN loc bl c
+      | "let"; id=name; bl = LIST0 binder_let; ty = type_cstr; ":=";
+        c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" ->
+          let loc1 = loc_of_binder_let bl in
+          CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2)
+      | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" ->
+          let fixp = mk_single_fix fx in
+          let (li,id) = match fixp with
+              CFix(_,id,_) -> id
+            | CCoFix(_,id,_) -> id
+            | _ -> assert false in
+          CLetIn(loc,(li,Name id),fixp,c)
+      | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []];
+	  po = return_type;
+	  ":="; c1 = operconstr LEVEL "200"; "in";
+          c2 = operconstr LEVEL "200" ->
+          CLetTuple (loc,List.map snd lb,po,c1,c2)
+      | "if"; c=operconstr LEVEL "200"; po = return_type;
+	"then"; b1=operconstr LEVEL "200";
+        "else"; b2=operconstr LEVEL "200" ->
+          CIf (loc, c, po, b1, b2)
+      | c=fix_constr -> c ] ]
+  ;
+  appl_arg:
+    [ [ id = lpar_id_coloneq; c=lconstr; ")" ->
+	  (c,Some (loc,ExplByName id))
+      | c=constr -> (c,None) ] ]
+  ;
+  atomic_constr:
+    [ [ g=global -> CRef g
+      | s=sort -> CSort(loc,s)
+      | n=INT -> CNumeral (loc,Bignat.POS (Bignat.of_string n))
+      | "_" -> CHole loc
+      | "?"; id=ident -> CPatVar(loc,(false,id)) ] ]
+  ;
+  fix_constr:
+    [ [ fx1=single_fix -> mk_single_fix fx1
+      | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with";
+        "for"; id=identref ->
+          mk_fix(loc,kw,id,dcl1::dcls)
+    ] ]
+  ;
+  single_fix:
+    [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ]
+  ;
+  fix_kw:
+    [ [ "fix" -> true
+      | "cofix" -> false ] ]
+  ;
+  fix_decl:
+    [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":=";
+        c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ]
+  ;
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
+      | -> None ] ]
+  ;
+  match_constr:
+    [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with";
+        br=branches; "end" -> mk_match (loc,ci,ty,br) ] ]
+  ;
+  case_item:
+    [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ]
+  ;
+  pred_pattern:
+    [ [ ona = OPT ["as"; id=name -> snd id];
+        ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ]
+  ;
+  case_type:
+    [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
+  ;
+  return_type:
+    [ [ a = OPT [ na = OPT["as"; id=name -> snd id];
+                  ty = case_type -> (na,ty) ] -> 
+        match a with 
+          | None -> None, None
+          | Some (na,t) -> (na, Some t)
+    ] ]
+  ;
+  branches:
+    [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ]
+  ;
+  eqn:
+    [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ]
+  ;
+  pattern:
+    [ "10" LEFTA
+      [ p = pattern ; lp = LIST1 (pattern LEVEL "0") ->
+        (match p with
+          | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
+          | _ -> Util.user_err_loc 
+              (cases_pattern_loc p, "compound_pattern",
+               Pp.str "Constructor expected"))
+      | p = pattern; "as"; id = base_ident ->
+	  CPatAlias (loc, p, id)
+      | c = pattern; "%"; key=IDENT -> 
+          CPatDelimiters (loc,key,c) ]
+    | "0"
+      [ r = Prim.reference -> CPatAtom (loc,Some r)
+      | "_" -> CPatAtom (loc,None)
+      | "("; p = pattern LEVEL "200"; ")" ->
+          (match p with
+              CPatNumeral(_,Bignat.POS _) -> CPatNotation(loc,"( _ )",[p])
+            | _ -> p)
+      | n = INT -> CPatNumeral (loc,Bignat.POS(Bignat.of_string n)) ] ]
+  ;
+  binder_list:
+    [ [ idl=LIST1 name; bl=LIST0 binder_let -> 
+          LocalRawAssum (idl,CHole loc)::bl
+      | idl=LIST1 name; ":"; c=lconstr -> 
+          [LocalRawAssum (idl,c)]
+      | "("; idl=LIST1 name; ":"; c=lconstr; ")"; bl=LIST0 binder_let ->
+          LocalRawAssum (idl,c)::bl ] ]
+  ;
+  binder_let:
+    [ [ id=name ->
+          LocalRawAssum ([id],CHole loc)
+      | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> 
+          LocalRawAssum (id::idl,c)
+      | "("; id=name; ":"; c=lconstr; ")" -> 
+          LocalRawAssum ([id],c)
+      | "("; id=name; ":="; c=lconstr; ")" ->
+          LocalRawDef (id,c)
+      | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> 
+          LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c,t))
+    ] ]
+  ;
+  binder:
+    [ [ id=name -> ([id],CHole loc)
+      | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ]
+  ;
+  type_cstr:
+    [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ]
+  ;
+  END;;
diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4
new file mode 100644
index 00000000..7349a6f8
--- /dev/null
+++ b/parsing/g_ltac.ml4
@@ -0,0 +1,213 @@
+(************************************************************************)
+(*  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: g_ltac.ml4,v 1.28.2.2 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pp
+open Util
+open Ast
+open Topconstr
+open Rawterm
+open Tacexpr
+open Vernacexpr
+open Ast
+open Pcoq
+open Prim
+open Tactic
+
+type let_clause_kind =
+  | LETTOPCLAUSE of Names.identifier * constr_expr
+  | LETCLAUSE of
+      (Names.identifier Util.located * raw_tactic_expr option * raw_tactic_arg)
+
+let fail_default_value = Genarg.ArgArg 0
+
+let out_letin_clause loc = function
+  | LETTOPCLAUSE _ -> user_err_loc (loc, "", (str "Syntax Error"))
+  | LETCLAUSE (id,c,d) -> (id,c,d)
+
+let make_letin_clause loc = List.map (out_letin_clause loc)
+
+let arg_of_expr = function
+    TacArg a -> a
+  | e -> Tacexp (e:raw_tactic_expr)
+    
+(* Tactics grammar rules *)
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: tactic Vernac_.command tactic_arg;
+
+(*
+  GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun;
+*)
+  input_fun:
+    [ [ l = base_ident -> Some l
+      | "()" -> None ] ]
+  ;
+  let_clause:
+    [ [ id = identref; "="; te = tactic_letarg -> LETCLAUSE (id, None, te)
+      | id = base_ident; ":"; c = Constr.constr; ":="; "Proof" ->
+          LETTOPCLAUSE (id, c)
+      | id = identref; ":"; c = constrarg; ":="; te = tactic_letarg ->
+          LETCLAUSE (id, Some (TacArg(ConstrMayEval c)), te)
+      |	id = base_ident; ":"; c = Constr.constr ->
+	  LETTOPCLAUSE (id, c) ] ]
+  ;
+  rec_clause:
+    [ [ name = identref; it = LIST1 input_fun; "->"; body = tactic_expr ->
+          (name,(it,body)) ] ]
+  ;
+  match_pattern:
+    [ [ id = Constr.constr_pattern; "["; pc = Constr.constr_pattern; "]" ->
+        let (_,s) = coerce_to_id id in Subterm (Some s, pc)
+      | "["; pc = Constr.constr_pattern; "]" -> Subterm (None,pc)
+      | pc = Constr.constr_pattern -> Term pc ] ]
+  ;
+  match_hyps:
+    [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp) ] ]
+  ;
+  match_context_rule:
+    [ [ "["; largs = LIST0 match_hyps SEP ";"; "|-"; mp = match_pattern; "]";
+        "->"; te = tactic_expr -> Pat (largs, mp, te)
+      | IDENT "_"; "->"; te = tactic_expr -> All te ] ]
+  ;
+  match_context_list:
+    [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl
+      | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ]
+  ;
+  match_rule:
+    [ [ "["; mp = match_pattern; "]"; "->"; te = tactic_expr -> Pat ([],mp,te)
+      | IDENT "_"; "->"; te = tactic_expr -> All te ] ]
+  ;
+  match_list:
+    [ [ mrl = LIST1 match_rule SEP "|" -> mrl
+      | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ]
+  ;
+  tactic_expr:
+    [ [ ta = tactic_expr5 -> ta ] ]
+  ;
+  tactic_expr5:
+    [ [ ta0 = tactic_expr5; ";"; ta1 = tactic_expr4 -> TacThen (ta0, ta1)
+      | ta = tactic_expr5; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" ->
+          TacThens (ta, lta)
+      | y = tactic_expr4 -> y ] ]
+  ;
+  tactic_expr4:
+    [ [ ta = tactic_expr3 -> ta ] ]
+  ;
+  tactic_expr3:
+    [ [ IDENT "Try"; ta = tactic_expr3 -> TacTry ta
+      | IDENT "Do"; n = int_or_var; ta = tactic_expr3 -> TacDo (n,ta)
+      | IDENT "Repeat"; ta = tactic_expr3 -> TacRepeat ta
+      | IDENT "Progress"; ta = tactic_expr3 -> TacProgress ta
+      | IDENT "Info"; tc = tactic_expr3 -> TacInfo tc
+      | ta = tactic_expr2 -> ta ] ]
+  ;
+  tactic_expr2:
+    [ [ ta0 = tactic_atom; "Orelse"; ta1 = tactic_expr3 -> TacOrelse (ta0,ta1)
+      | ta = tactic_atom -> ta ] ]
+  ;
+  tactic_atom:
+    [ [ IDENT "Fun"; it = LIST1 input_fun ; "->"; body = tactic_expr ->
+          TacFun (it,body)
+      | IDENT "Rec"; rc = rec_clause ->
+	  warning "'Rec f ...' is obsolete; use 'Rec f ... In f' instead";
+	  TacLetRecIn ([rc],TacArg (Reference (Libnames.Ident (fst rc))))
+      | IDENT "Rec"; rc = rec_clause; rcl = LIST0 rec_clause SEP "And";
+	  [IDENT "In" | "in"]; body = tactic_expr -> TacLetRecIn (rc::rcl,body)
+      | IDENT "Let"; llc = LIST1 let_clause SEP "And"; IDENT "In";
+          u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u)
+
+      | IDENT "Match"; IDENT "Context"; IDENT "With"; mrl = match_context_list
+        -> TacMatchContext (false,mrl)
+      | IDENT "Match"; IDENT "Reverse"; IDENT "Context"; IDENT "With"; mrl = match_context_list
+        -> TacMatchContext (true,mrl)
+      |	IDENT "Match"; c = constrarg; IDENT "With"; mrl = match_list ->
+        TacMatch (TacArg(ConstrMayEval c),mrl)
+(*To do: put Abstract in Refiner*)
+      | IDENT "Abstract"; tc = tactic_expr -> TacAbstract (tc,None)
+      | IDENT "Abstract"; tc = tactic_expr; "using";  s = base_ident ->
+          TacAbstract (tc,Some s)
+(*End of To do*)
+      | IDENT "First" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacFirst l
+      | IDENT "Solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacSolve l
+      | IDENT "Idtac" ; s = [ s = STRING -> s | -> ""] -> TacId s
+      | IDENT "Fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
+	  s = [ s = STRING -> s | -> ""] -> TacFail (n,s)
+      | st = simple_tactic -> TacAtom (loc,st)
+      | "("; a = tactic_expr; ")" -> a
+      | a = tactic_arg -> TacArg a
+    ] ]
+  ;
+  (* Tactic arguments *)
+  tactic_arg:
+    [ [ ta = tactic_arg1 -> ta ] ]
+  ;
+  tactic_letarg:
+    (* Cannot be merged with tactic_arg1, since then "In"/"And" are 
+       parsed as lqualid! *)
+    [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr ->
+	  ConstrMayEval (ConstrEval (rtc,c))
+      | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" ->
+	  ConstrMayEval (ConstrContext (id,c))
+      | IDENT "Check"; c = Constr.constr ->
+	  ConstrMayEval (ConstrTypeOf c)
+      | IDENT "FreshId"; s = OPT STRING -> TacFreshId s
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
+      | r = reference -> Reference r
+      | ta = tactic_arg0 -> ta ] ]
+  ;
+  tactic_arg1:
+    [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr ->
+	  ConstrMayEval (ConstrEval (rtc,c))
+      | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" ->
+	  ConstrMayEval (ConstrContext (id,c))
+      | IDENT "Check"; c = Constr.constr ->
+	  ConstrMayEval (ConstrTypeOf c)
+      | IDENT "FreshId"; s = OPT STRING -> TacFreshId s
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
+      | r = reference; la = LIST1 tactic_arg0 -> TacCall (loc,r,la)
+      | r = reference -> Reference r
+      | ta = tactic_arg0 -> ta ] ]
+  ;
+  tactic_arg0:
+    [ [ "("; a = tactic_expr; ")" -> arg_of_expr a
+      | "()" -> TacVoid
+      | r = reference -> Reference r
+      | n = integer -> Integer n
+      | id = METAIDENT -> MetaIdArg (loc,id)
+      |	"?" -> ConstrMayEval (ConstrTerm (CHole loc))
+      | "?"; n = natural -> ConstrMayEval (ConstrTerm (CPatVar (loc,(false,Pattern.patvar_of_int n))))
+      |	"'"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ]
+  ;
+
+  (* Definitions for tactics *)
+  deftok:
+    [ [ IDENT "Meta"
+      | IDENT "Tactic" ] ]
+  ;
+  tacdef_body:
+    [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr ->
+	  (name, TacFun (it, body))
+      | name = identref; ":="; body = tactic_expr ->
+	  (name, body) ] ]
+  ;
+  tactic:
+    [ [ tac = tactic_expr -> tac ] ]
+  ;
+  Vernac_.command: 
+    [ [ deftok; "Definition"; b = tacdef_body ->
+          VernacDeclareTacticDefinition (false, [b])
+      | IDENT "Recursive"; deftok; "Definition"; 
+        l = LIST1 tacdef_body SEP "And" ->
+          VernacDeclareTacticDefinition (true, l) ] ]
+  ;
+  END
diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4
new file mode 100644
index 00000000..9c8d1675
--- /dev/null
+++ b/parsing/g_ltacnew.ml4
@@ -0,0 +1,189 @@
+(************************************************************************)
+(*  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: g_ltacnew.ml4,v 1.22.2.2 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pp
+open Util
+open Ast
+open Topconstr
+open Rawterm
+open Tacexpr
+open Vernacexpr
+open Ast
+open Pcoq
+open Prim
+open Tactic
+
+type let_clause_kind =
+  | LETTOPCLAUSE of Names.identifier * constr_expr
+  | LETCLAUSE of
+      (Names.identifier Util.located * raw_tactic_expr option * raw_tactic_arg)
+
+let fail_default_value = Genarg.ArgArg 0
+
+let out_letin_clause loc = function
+  | LETTOPCLAUSE _ -> user_err_loc (loc, "", (str "Syntax Error"))
+  | LETCLAUSE (id,c,d) -> (id,c,d)
+
+let make_letin_clause loc = List.map (out_letin_clause loc)
+
+let arg_of_expr = function
+    TacArg a -> a
+  | e -> Tacexp (e:raw_tactic_expr)
+    
+(* Tactics grammar rules *)
+
+let tactic_expr = Gram.Entry.create "tactic:tactic_expr"
+
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: tactic Vernac_.command tactic_expr tactic_arg;
+
+  tactic_expr:
+    [ "5" LEFTA
+      [ ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1)
+      | ta = tactic_expr; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" ->
+          TacThens (ta, lta) ]
+    | "4"
+      [ ]
+    | "3" RIGHTA
+      [ IDENT "try"; ta = tactic_expr -> TacTry ta
+      | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta)
+      | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta
+      | IDENT "progress"; ta = tactic_expr -> TacProgress ta
+      | IDENT "info"; tc = tactic_expr -> TacInfo tc
+(*To do: put Abstract in Refiner*)
+      | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None)
+      | IDENT "abstract"; tc = NEXT; "using";  s = base_ident ->
+          TacAbstract (tc,Some s) ]
+(*End of To do*)
+    | "2" RIGHTA
+      [ ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ]
+    | "1" RIGHTA
+      [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr ->
+          TacFun (it,body)
+      | "let"; IDENT "rec"; rcl = LIST1 rec_clause SEP "with"; "in";
+          body = tactic_expr -> TacLetRecIn (rcl,body)
+      | "let"; llc = LIST1 let_clause SEP "with"; "in";
+          u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u)
+      | "match"; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
+          TacMatchContext (false,mrl)
+      | "match"; IDENT "reverse"; IDENT "goal"; "with";
+        mrl = match_context_list; "end" ->
+          TacMatchContext (true,mrl)
+      |	"match"; c = tactic_expr; "with"; mrl = match_list; "end" ->
+          TacMatch (c,mrl)
+      | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacFirst l
+      | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacSolve l
+      | IDENT "idtac"; s = [ s = STRING -> s | -> ""] -> TacId s		
+      | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
+	  s = [ s = STRING -> s | -> ""] -> TacFail (n,s)
+      | st = simple_tactic -> TacAtom (loc,st)
+      | a = may_eval_arg -> TacArg(a)
+      | IDENT "constr"; ":"; c = Constr.constr ->
+          TacArg(ConstrMayEval(ConstrTerm c))
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> 
+	  TacArg(IntroPattern ipat)
+      | r = reference; la = LIST1 tactic_arg ->
+          TacArg(TacCall (loc,r,la))
+      | r = reference -> TacArg (Reference r) ]
+    | "0"
+      [ "("; a = tactic_expr; ")" -> a
+      | a = tactic_atom -> TacArg a ] ]
+  ;
+  (* Tactic arguments *)
+  tactic_arg:
+    [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
+      | a = may_eval_arg -> a
+      | a = tactic_atom -> a
+      | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ]
+  ;
+  may_eval_arg:
+    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
+	  ConstrMayEval (ConstrEval (rtc,c))
+      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
+	  ConstrMayEval (ConstrContext (id,c))
+      | IDENT "type"; IDENT "of"; c = Constr.constr ->
+	  ConstrMayEval (ConstrTypeOf c)
+      | IDENT "fresh"; s = OPT STRING ->
+	  TacFreshId s ] ]
+  ;
+  tactic_atom:
+    [ [ id = METAIDENT -> MetaIdArg (loc,id)
+      | r = reference -> Reference r
+      | "()" -> TacVoid ] ]
+  ;
+  input_fun:
+    [ [ "_" -> None 
+      | l = base_ident -> Some l ] ]
+  ;
+  let_clause:
+    [ [ id = identref; ":="; te = tactic_expr ->
+          LETCLAUSE (id, None, arg_of_expr te)
+      | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr ->
+          LETCLAUSE (id, None, arg_of_expr (TacFun(args,te))) ] ]
+  ;
+  rec_clause:
+    [ [ name = identref; it = LIST1 input_fun; ":="; body = tactic_expr ->
+          (name,(it,body)) ] ]
+  ;
+  match_pattern:
+    [ [ IDENT "context";  oid = OPT Constr.ident;
+          "["; pc = Constr.lconstr_pattern; "]" ->
+        Subterm (oid, pc)
+      | pc = Constr.lconstr_pattern -> Term pc ] ]
+  ;
+  match_hyps:
+    [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp) ] ]
+  ;
+  match_context_rule:
+    [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
+        "=>"; te = tactic_expr -> Pat (largs, mp, te)
+      | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
+        "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te)
+      | "_"; "=>"; te = tactic_expr -> All te ] ]
+  ;
+  match_context_list:
+    [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl
+      | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ]
+  ;
+  match_rule:
+    [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te)
+      | "_"; "=>"; te = tactic_expr -> All te ] ]
+  ;
+  match_list:
+    [ [ mrl = LIST1 match_rule SEP "|" -> mrl
+      | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ]
+  ;
+
+  (* Definitions for tactics *)
+(*
+  deftok:
+    [ [ IDENT "Meta"
+      | IDENT "Tactic" ] ]
+  ;
+*)
+  tacdef_body:
+    [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr ->
+	  (name, TacFun (it, body))
+      | name = identref; ":="; body = tactic_expr ->
+	  (name, body) ] ]
+  ;
+  tactic:
+    [ [ tac = tactic_expr -> tac ] ]
+  ;
+  Vernac_.command: 
+    [ [ IDENT "Ltac";
+        l = LIST1 tacdef_body SEP "with" ->
+          VernacDeclareTacticDefinition (true, l) ] ]
+  ;
+  END
diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4
new file mode 100644
index 00000000..dd4ef517
--- /dev/null
+++ b/parsing/g_minicoq.ml4
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  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: g_minicoq.ml4,v 1.17.6.1 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Univ
+open Term
+open Environ
+
+let lexer =
+  {Token.func = Lexer.func; Token.using = Lexer.add_token;
+   Token.removing = (fun _ -> ()); Token.tparse = Lexer.tparse;
+   Token.text = Lexer.token_text}
+;;
+
+type command =
+  | Definition of identifier * constr option * constr
+  | Parameter of identifier * constr
+  | Variable of identifier * constr
+  | Inductive of 
+      (identifier * constr) list *
+      (identifier * constr * (identifier * constr) list) list
+  | Check of constr
+
+let gram = Grammar.create lexer
+
+let term = Grammar.Entry.create gram "term"
+let name = Grammar.Entry.create gram "name"
+let nametype = Grammar.Entry.create gram "nametype"
+let inductive = Grammar.Entry.create gram "inductive"
+let constructor = Grammar.Entry.create gram "constructor"
+let command = Grammar.Entry.create gram "command"
+
+let path_of_string s = make_path [] (id_of_string s)
+
+EXTEND
+  name: 
+  [ [ id = IDENT -> Name (id_of_string id)
+    | "_" -> Anonymous
+  ] ];
+  nametype: 
+  [ [ id = IDENT; ":"; t = term -> (id_of_string id, t) 
+  ] ];
+  term: 
+  [ [ id = IDENT -> 
+	mkVar (id_of_string id) 
+    | IDENT "Rel"; n = INT ->
+	mkRel (int_of_string n)
+    | "Set" ->
+	mkSet
+    | "Prop" ->
+	mkProp
+    | "Type" ->
+	mkType (new_univ())
+    | "Const"; id = IDENT ->
+	mkConst (path_of_string id, [||])
+    | "Ind"; id = IDENT; n = INT ->
+	let n = int_of_string n in
+	mkMutInd ((path_of_string id, n), [||])
+    | "Construct"; id = IDENT; n = INT; i = INT ->
+	let n = int_of_string n and i = int_of_string i in
+	mkMutConstruct (((path_of_string id, n), i), [||])
+    | "["; na = name; ":"; t = term; "]"; c = term ->
+	mkLambda (na,t,c)
+    | "("; na = name; ":"; t = term; ")"; c = term ->
+	mkProd (na,t,c)
+    | c1 = term; "->"; c2 = term ->
+	mkArrow c1 c2
+    | "("; id = IDENT; cl = LIST1 term; ")" ->
+	let c = mkVar (id_of_string id) in
+	mkApp (c, Array.of_list cl)
+    | "("; cl = LIST1 term; ")" ->
+	begin match cl with
+	  | [c] -> c
+	  | c::cl -> mkApp (c, Array.of_list cl)
+	end
+    | "("; c = term; "::"; t = term; ")" ->
+	mkCast (c, t)
+    | "<"; p = term; ">"; 
+	IDENT "Case"; c = term; ":"; "Ind"; id = IDENT; i = INT;
+	"of"; bl = LIST0 term; "end" ->
+	  let ind = (path_of_string id,int_of_string i) in
+	  let nc = List.length bl in
+	  let dummy_pats = Array.create nc RegularPat in
+	  let dummy_ci = [||],(ind,[||],nc,None,dummy_pats) in
+	  mkMutCase (dummy_ci, p, c, Array.of_list bl)
+  ] ];
+  command: 
+  [ [ "Definition"; id = IDENT; ":="; c = term; "." ->
+	Definition (id_of_string id, None, c)
+    | "Definition"; id = IDENT; ":"; t = term; ":="; c = term; "." ->
+	Definition (id_of_string id, Some t, c)
+    | "Parameter"; id = IDENT; ":"; t = term; "." ->
+	Parameter (id_of_string id, t)
+    | "Variable"; id = IDENT; ":"; t = term; "." ->
+	Variable (id_of_string id, t)
+    | "Inductive"; "["; params = LIST0 nametype SEP ";"; "]"; 
+      inds = LIST1 inductive SEP "with" ->
+	Inductive (params, inds)
+    | IDENT "Check"; c = term; "." ->
+	Check c
+    | EOI -> raise End_of_file
+  ] ];
+  inductive: 
+  [ [ id = IDENT; ":"; ar = term; ":="; constrs = LIST0 constructor SEP "|" ->
+        (id_of_string id,ar,constrs)
+  ] ];
+  constructor:
+  [ [ id = IDENT; ":"; c = term -> (id_of_string id,c) ] ];
+END
+
+(* Pretty-print. *)
+
+let print_univers = ref false
+let print_casts = ref false
+
+let print_type u =
+  if !print_univers then (str "Type" ++ pr_uni u)
+  else (str "Type")
+
+let print_name = function
+  | Anonymous -> (str "_")
+  | Name id -> pr_id id
+
+let print_rel bv n = print_name (List.nth bv (pred n))
+
+let rename bv = function
+  | Anonymous -> Anonymous
+  | Name id as na -> 
+      let idl = 
+	List.fold_left 
+	  (fun l n -> match n with Name x -> x::l | _ -> l) [] bv 
+      in
+      if List.mem na bv then Name (next_ident_away id idl) else na
+
+let rec pp bv t =
+  match kind_of_term t with
+  | Sort (Prop Pos) -> (str "Set")
+  | Sort (Prop Null) -> (str "Prop")
+  | Sort (Type u) -> print_type u
+  | Lambda (na, t, c) ->
+      (str"[" ++ print_name na ++ str":" ++ pp bv t ++ str"]" ++ pp (na::bv) c)
+  | Prod (Anonymous, t, c) ->
+      (pp bv t ++ str"->" ++ pp (Anonymous::bv) c)
+  | Prod (na, t, c) ->
+      (str"(" ++ print_name na ++ str":" ++ pp bv t ++ str")" ++ pp (na::bv) c)
+  | Cast (c, t) ->
+      if !print_casts then 
+	(str"(" ++ pp bv c ++ str"::" ++ pp bv t ++ str")")
+      else 
+	pp bv c
+  | App(h, v) ->
+      (str"(" ++ pp bv h ++ spc () ++
+         prvect_with_sep (fun () -> (spc ())) (pp bv) v ++ str")")
+  | Const (sp, _) ->
+      (str"Const " ++ pr_id (basename sp))
+  | Ind ((sp,i), _) ->
+      (str"Ind " ++ pr_id (basename sp) ++ str" " ++ int i)
+  | Construct (((sp,i),j), _) ->
+      (str"Construct " ++ pr_id (basename sp) ++ str" " ++ int i ++ 
+	 str" " ++ int j)
+  | Var id -> pr_id id
+  | Rel n -> print_rel bv n
+  | _ -> (str"<???>")
+
+let pr_term _ ctx = pp (fold_rel_context (fun _ (n,_,_) l -> n::l) ctx [])
+
diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli
new file mode 100644
index 00000000..e19b1163
--- /dev/null
+++ b/parsing/g_minicoq.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  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: g_minicoq.mli,v 1.8.16.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Environ
+(*i*)
+
+val term : constr Grammar.Entry.e
+
+type command =
+  | Definition of identifier * constr option * constr
+  | Parameter of identifier * constr
+  | Variable of identifier * constr
+  | Inductive of 
+      (identifier * constr) list *
+      (identifier * constr * (identifier * constr) list) list
+  | Check of constr
+
+val command : command Grammar.Entry.e
+
+val pr_term : path_kind -> env -> constr -> std_ppcmds
diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4
new file mode 100644
index 00000000..0b542608
--- /dev/null
+++ b/parsing/g_module.ml4
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  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: g_module.ml4,v 1.6.2.1 2004/07/16 19:30:39 herbelin Exp $ *) 
+
+open Pp
+open Ast
+open Pcoq
+open Prim
+open Module
+open Util
+open Topconstr
+
+(* Grammar rules for module expressions and types *)
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: module_expr module_type;
+ 
+  module_expr:
+    [ [ qid = qualid -> CMEident qid
+      | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2)
+      | "("; me = module_expr; ")" -> me
+(* ... *)
+      ] ]
+  ;
+
+  with_declaration:
+    [ [ "Definition"; id = identref; ":="; c = Constr.constr ->
+          CWith_Definition (id,c)
+      | IDENT "Module"; id = identref; ":="; qid = qualid ->
+	  CWith_Module (id,qid)
+      ] ]
+  ;
+  
+  module_type:
+    [ [ qid = qualid -> CMTEident qid
+(* ... *)
+      | mty = module_type; "with"; decl = with_declaration -> 
+	  CMTEwith (mty,decl) ] ]
+  ;
+END
diff --git a/parsing/g_natsyntax.ml b/parsing/g_natsyntax.ml
new file mode 100644
index 00000000..e43142ba
--- /dev/null
+++ b/parsing/g_natsyntax.ml
@@ -0,0 +1,229 @@
+(************************************************************************)
+(*  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: g_natsyntax.ml,v 1.19.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+(* This file to allow writing (3) for (S (S (S O))) 
+   and still write (S y) for (S y) *)
+
+open Pcoq
+open Pp
+open Util
+open Names
+open Coqast
+open Ast
+open Coqlib
+open Termast
+open Extend
+
+let ast_O = ast_of_ref glob_O
+let ast_S = ast_of_ref glob_S
+
+(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
+let nat_of_int n dloc =
+  let ast_O = set_loc dloc ast_O in
+  let ast_S = set_loc dloc ast_S in
+  let rec mk_nat n =
+    if n <= 0 then 
+      ast_O
+    else 
+      Node(dloc,"APPLIST", [ast_S; mk_nat (n-1)])
+  in 
+  mk_nat n
+
+let pat_nat_of_int n dloc =
+  let ast_O = set_loc dloc ast_O in
+  let ast_S = set_loc dloc ast_S in
+  let rec mk_nat n =
+    if n <= 0 then 
+      ast_O
+    else 
+      Node(dloc,"PATTCONSTRUCT", [ast_S; mk_nat (n-1)])
+  in 
+  mk_nat n
+
+let nat_of_string s dloc = 
+  nat_of_int (int_of_string s) dloc
+
+let pat_nat_of_string s dloc = 
+  pat_nat_of_int (int_of_string s) dloc
+    
+exception Non_closed_number
+
+let rec int_of_nat_rec astS astO p =
+  match p with
+    | Node (_,"APPLIST", [b; a]) when alpha_eq(b,astS) ->
+	(int_of_nat_rec astS astO a)+1
+    | a when alpha_eq(a,astO) -> 1  
+          (***** YES, 1, non 0 ... to print the successor of p *)
+    | _ -> raise Non_closed_number
+	  
+let int_of_nat p =
+  try 
+    Some (int_of_nat_rec ast_S ast_O p)
+  with
+    Non_closed_number -> None
+
+let pr_S a = hov 0 (str "S" ++ brk (1,1) ++ a)
+
+let rec pr_external_S std_pr = function
+  | Node (l,"APPLIST", [b; a]) when alpha_eq (b,ast_S) ->
+      str"(" ++ pr_S (pr_external_S std_pr a) ++ str")"
+  | p -> std_pr p
+
+(* Declare the primitive printer *)
+
+(* Prints not p, but the SUCCESSOR of p !!!!! *)
+let nat_printer std_pr p =
+  match (int_of_nat p) with
+    | Some i -> str "(" ++ str (string_of_int i) ++ str ")"
+    | None -> str "(" ++ pr_S (pr_external_S std_pr p) ++ str ")"
+
+let _ = Esyntax.Ppprim.add ("nat_printer", nat_printer)
+(*
+(* Declare the primitive parser *)
+
+let unat = create_univ_if_new "nat"
+
+let number = create_constr_entry unat "number" 
+let pat_number = create_constr_entry unat "pat_number"
+ 
+let _ = 
+  Gram.extend number None
+    [None, None,
+     [[Gramext.Stoken ("INT", "")],
+      Gramext.action nat_of_string]]
+
+let _ = 
+  Gram.extend pat_number None
+    [None, None,
+     [[Gramext.Stoken ("INT", "")],
+      Gramext.action pat_nat_of_string]]
+*)
+
+(*i*)
+open Rawterm
+open Libnames
+open Bignat
+open Coqlib
+open Symbols
+open Pp
+open Util
+open Names
+(*i*)
+
+(**********************************************************************)
+(* Parsing via scopes *)
+(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
+
+let nat_of_int dloc n =
+  match n with
+  | POS n ->
+      if less_than (of_string "5000") n & Options.is_verbose () then begin
+	warning ("You may experiment stack overflow and segmentation fault\
+                  \nwhile parsing numbers in nat greater than 5000");
+	flush_all ()
+      end;
+      let ref_O = RRef (dloc, glob_O) in
+      let ref_S = RRef (dloc, glob_S) in
+      let rec mk_nat acc n =
+	if is_nonzero n then 
+	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
+	else 
+	  acc
+      in 
+      mk_nat ref_O n
+  | NEG n ->
+      user_err_loc (dloc, "nat_of_int",
+        str "Cannot interpret a negative number as a number of type nat")
+
+let pat_nat_of_int dloc n name =
+  match n with
+  | POS n -> 
+      let rec mk_nat n name =
+	if is_nonzero n then 
+	  PatCstr (dloc,path_of_S,[mk_nat (sub_1 n) Anonymous],name)
+	else 
+	  PatCstr (dloc,path_of_O,[],name)
+      in 
+      mk_nat n name
+  | NEG n ->
+      user_err_loc (dloc, "pat_nat_of_int",
+        str "Unable to interpret a negative number in type nat")
+
+(************************************************************************)
+(* Printing via scopes *)
+
+exception Non_closed_number
+
+let rec int_of_nat = function
+  | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
+  | RRef (_,z) when z = glob_O -> zero
+  | _ -> raise Non_closed_number
+	  
+let uninterp_nat p =
+  try 
+    Some (POS (int_of_nat p))
+  with
+    Non_closed_number -> None
+
+let rec int_of_nat_pattern = function
+  | PatCstr (_,s,[a],_) when ConstructRef s = glob_S ->
+      add_1 (int_of_nat_pattern a)
+  | PatCstr (_,z,[],_) when ConstructRef z = glob_O -> zero
+  | _ -> raise Non_closed_number
+	  
+let uninterp_nat_pattern p =
+  try 
+    Some (POS (int_of_nat_pattern p))
+  with
+    Non_closed_number -> None
+
+(************************************************************************)
+(* Declare the primitive parsers and printers *)
+
+let _ =
+  Symbols.declare_numeral_interpreter "nat_scope"
+    (glob_nat,["Coq";"Init";"Datatypes"])
+    (nat_of_int,Some pat_nat_of_int)
+    ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, None)
+
+(************************************************************************)
+(* Old ast printing *)
+
+open Coqast
+open Ast
+open Termast
+
+let _ = if !Options.v7 then
+let ast_O = ast_of_ref glob_O in
+let ast_S = ast_of_ref glob_S in
+
+let rec int_of_nat = function
+  | Node (_,"APPLIST", [b; a]) when alpha_eq(b,ast_S) -> (int_of_nat a) + 1
+  | a when alpha_eq(a,ast_O) -> 0
+  | _ -> raise Non_closed_number
+in
+(* Prints not p, but the SUCCESSOR of p !!!!! *)
+let nat_printer_S p =
+  try 
+    Some (int (int_of_nat p + 1))
+  with
+    Non_closed_number -> None
+in
+let nat_printer_O _ =
+  Some (int 0)
+in
+(* Declare the primitive printers *)
+let _ =
+  Esyntax.declare_primitive_printer "nat_printer_S" "nat_scope" nat_printer_S
+in
+let _ = 
+  Esyntax.declare_primitive_printer "nat_printer_O" "nat_scope" nat_printer_O
+in
+()
diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli
new file mode 100644
index 00000000..1471aed2
--- /dev/null
+++ b/parsing/g_natsyntax.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  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: g_natsyntax.mli,v 1.3.16.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for naturals. *)
diff --git a/parsing/g_natsyntaxnew.mli b/parsing/g_natsyntaxnew.mli
new file mode 100644
index 00000000..50d38133
--- /dev/null
+++ b/parsing/g_natsyntaxnew.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  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: g_natsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for naturals. *)
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
new file mode 100644
index 00000000..ce6d4e2f
--- /dev/null
+++ b/parsing/g_prim.ml4
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  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: g_prim.ml4,v 1.22.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+open Coqast
+open Pcoq
+open Names
+open Libnames
+open Topconstr
+open Prim
+
+let _ = reset_all_grammars()
+
+open Nametab
+let local_id_of_string = id_of_string
+let local_make_dirpath = make_dirpath
+let local_make_qualid l id' = make_qualid (local_make_dirpath l) id'
+let local_make_short_qualid id = make_short_qualid id
+let local_make_posint = int_of_string
+let local_make_negint n = - int_of_string n
+let local_make_path l a = encode_kn (local_make_dirpath l) a
+let local_make_binding loc a b =
+  match a with
+    | Nvar (_,id) -> Slam(loc,Some id,b)
+    | Nmeta (_,s) -> Smetalam(loc,s,b)
+    | _ -> failwith "Slam expects a var or a metavar"
+let local_append l id = l@[id]
+
+GEXTEND Gram
+  GLOBAL: ident natural integer bigint string preident ast
+    astlist qualid reference dirpath identref name base_ident var hyp;
+
+ (* Compatibility: Prim.var is a synonym of Prim.ident *)
+  var:
+    [ [ id = ident -> id ] ]
+  ;
+  hyp:
+    [ [ id = ident -> id ] ]
+  ;
+  metaident:
+    [ [ s = METAIDENT -> Nmeta (loc,s) ] ]
+  ;
+  preident:
+    [ [ s = IDENT -> s ] ]
+  ;
+  base_ident:
+    [ [ s = IDENT -> local_id_of_string s ] ]
+  ;
+  name:
+    [ [ IDENT "_" -> (loc, Anonymous)
+      | id = base_ident -> (loc, Name id) ] ]
+  ;
+  identref:
+    [ [ id = base_ident -> (loc,id) ] ]
+  ;
+  ident:
+    [ [ id = base_ident -> id ] ]
+  ;
+  natural:
+    [ [ i = INT -> local_make_posint i ] ]
+  ;
+  bigint:
+    [ [ i = INT -> Bignat.POS (Bignat.of_string i)
+      | "-"; i = INT -> Bignat.NEG (Bignat.of_string i) ] ]
+  ;
+  integer:
+    [ [ i = INT      -> local_make_posint i
+      | "-"; i = INT -> local_make_negint i ] ]
+  ;
+  field:
+    [ [ s = FIELD -> local_id_of_string s ] ]
+  ;
+  dirpath:
+    [ [ id = base_ident; l = LIST0 field ->
+        local_make_dirpath (local_append l id) ] ]
+  ;
+  fields:
+    [ [ id = field; (l,id') = fields -> (local_append l id,id')
+      | id = field -> ([],id)
+      ] ]
+  ;
+  basequalid:
+    [ [ id = base_ident; (l,id')=fields -> local_make_qualid (local_append l id) id'
+      | id = base_ident -> local_make_short_qualid id
+      ] ]
+  ;
+  qualid:
+    [ [ qid = basequalid -> loc, qid ] ]
+  ;
+  reference:
+    [ [ id = base_ident; (l,id') = fields ->
+        Qualid (loc, local_make_qualid (local_append l id) id')
+      | id = base_ident -> Ident (loc,id)
+      ] ]
+  ;
+  string:
+    [ [ s = STRING -> s ] ]
+  ;
+  astpath:
+    [ [ id = base_ident; (l,a) = fields ->
+          Path(loc, local_make_path (local_append l id) a)
+      | id = base_ident -> Nvar(loc, id)
+      ] ]
+  ;
+  (* ast *)
+  ast:
+    [ [ id = metaident -> id
+      | p = astpath -> p
+      | s = INT -> Num(loc, local_make_posint s)
+      | s = STRING -> Str(loc, s)
+      | "{"; s = METAIDENT; "}" -> Id(loc,s)
+      | "("; nname = IDENT; l = LIST0 ast; ")" -> Node(loc,nname,l)
+      | "("; METAIDENT "$LIST"; id = metaident; ")" -> Node(loc,"$LIST",[id])
+      | "("; METAIDENT "$STR"; id = metaident; ")" -> Node(loc,"$STR",[id])
+      | "("; METAIDENT "$VAR"; id = metaident; ")" -> Node(loc,"$VAR",[id])
+      | "("; METAIDENT "$ID"; id = metaident; ")" -> Node(loc,"$ID",[id])
+      | "("; METAIDENT "$ABSTRACT"; l = LIST0 ast;")"->Node(loc,"$ABSTRACT",l)
+      | "("; METAIDENT "$PATH"; id = metaident; ")" -> Node(loc,"$PATH",[id])
+      | "("; METAIDENT "$NUM"; id = metaident; ")" -> Node(loc,"$NUM",[id])
+      | "["; "<>"; "]"; b = ast -> Slam(loc,None,b)
+      | "["; a = ast; "]"; b = ast -> local_make_binding loc a b
+
+(*
+      | "["; ido = astidoption; "]"; b = ast -> Slam(loc,ido,b)
+      | "["; id = METAIDENT; "]"; b = ast -> Smetalam(loc,id,b)
+*)
+      | "'"; a = ast -> Node(loc,"$QUOTE",[a]) ] ]
+  ;
+  astlist:
+    [ [ l = LIST0 ast -> l ] ]
+  ;
+END
diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4
new file mode 100644
index 00000000..c1875634
--- /dev/null
+++ b/parsing/g_primnew.ml4
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  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: g_primnew.ml4,v 1.4.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+open Coqast
+open Pcoq
+open Names
+open Libnames
+open Topconstr
+
+let _ =
+  if not !Options.v7 then
+    Pcoq.reset_all_grammars()
+let _ =
+  if not !Options.v7 then
+  let f = Gram.Unsafe.clear_entry in
+  f Prim.bigint;
+  f Prim.qualid;
+  f Prim.ast;
+  f Prim.reference
+
+let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "<>"; "<<"; ">>"; "'"]
+let _ = 
+  if not !Options.v7 then
+    List.iter (fun s -> Lexer.add_token("",s)) prim_kw
+
+open Prim
+
+open Nametab
+let local_id_of_string = id_of_string
+let local_make_dirpath = make_dirpath
+let local_make_qualid l id' = make_qualid (local_make_dirpath l) id'
+let local_make_short_qualid id = make_short_qualid id
+let local_make_posint = int_of_string
+let local_make_negint n = - int_of_string n
+let local_make_path l a = encode_kn (local_make_dirpath l) a
+let local_make_binding loc a b =
+  match a with
+    | Nvar (_,id) -> Slam(loc,Some id,b)
+    | Nmeta (_,s) -> Smetalam(loc,s,b)
+    | _ -> failwith "Slam expects a var or a metavar"
+let local_append l id = l@[id]
+
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: bigint qualid reference ne_string;
+  field:
+    [ [ s = FIELD -> local_id_of_string s ] ]
+  ;
+  fields:
+    [ [ id = field; (l,id') = fields -> (local_append l id,id')
+      | id = field -> ([],id)
+      ] ]
+  ;
+  basequalid:
+    [ [ id = base_ident; (l,id')=fields ->
+          local_make_qualid (local_append l id) id'
+      | id = base_ident -> local_make_short_qualid id
+      ] ]
+  ;
+  reference:
+    [ [ id = base_ident; (l,id') = fields ->
+        Qualid (loc, local_make_qualid (local_append l id) id')
+      | id = base_ident -> Ident (loc,id)
+      ] ]
+  ;
+  qualid:
+    [ [ qid = basequalid -> loc, qid ] ]
+  ;
+  ne_string:
+    [ [ s = STRING -> 
+        if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s
+    ] ]
+  ;
+  bigint: (* Negative numbers are dealt with specially *)
+    [ [ i = INT -> Bignat.POS (Bignat.of_string i) ] ]
+  ;
+END
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
new file mode 100644
index 00000000..5262b785
--- /dev/null
+++ b/parsing/g_proofs.ml4
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  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: g_proofs.ml4,v 1.33.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Pcoq
+open Pp
+open Tactic
+open Util
+open Vernac_
+open Topconstr
+open Vernacexpr
+open Prim
+open Constr
+
+let thm_token = Gram.Entry.create "vernac:thm_token"
+
+(* Proof commands *)
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command;
+
+  destruct_location :
+  [ [ IDENT "Conclusion"  -> Tacexpr.ConclLocation ()
+    | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis"
+	-> Tacexpr.HypLocation discard ] ]
+  ;
+  opt_hintbases:
+  [ [ -> []
+    | ":"; l = LIST1 IDENT -> l ] ]
+  ;
+  command:
+    [ [ IDENT "Goal"; c = Constr.constr -> VernacGoal c
+      | "Proof" -> VernacProof (Tacexpr.TacId "")
+      | "Proof"; "with"; ta = tactic -> VernacProof ta
+      | IDENT "Abort" -> VernacAbort None
+      | IDENT "Abort"; IDENT "All" -> VernacAbortAll
+      | IDENT "Abort"; id = identref -> VernacAbort (Some id)
+      | IDENT "Admitted" -> VernacEndProof Admitted
+      | "Qed" -> VernacEndProof (Proved (true,None))
+      | IDENT "Save" -> VernacEndProof (Proved (true,None))
+      | IDENT "Defined" -> VernacEndProof (Proved (false,None))
+      |	IDENT "Defined"; id=identref -> 
+	  VernacEndProof (Proved (false,Some (id,None)))
+      | IDENT "Save"; tok = thm_token; id = identref ->
+	  VernacEndProof (Proved (true,Some (id,Some tok)))
+      | IDENT "Save"; id = identref ->
+	  VernacEndProof (Proved (true,Some (id,None)))
+      | IDENT "Suspend" -> VernacSuspend
+      | IDENT "Resume" -> VernacResume None
+      | IDENT "Resume"; id = identref -> VernacResume (Some id)
+      | IDENT "Restart" -> VernacRestart
+      | "Proof"; c = Constr.constr -> VernacExactProof c
+      | IDENT "Undo" -> VernacUndo 1
+      | IDENT "Undo"; n = natural -> VernacUndo n
+      | IDENT "Focus" -> VernacFocus None
+      | IDENT "Focus"; n = natural -> VernacFocus (Some n)
+      | IDENT "Unfocus" -> VernacUnfocus
+      | IDENT "Show" -> VernacShow (ShowGoal None)
+      | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n))
+      | IDENT "Show"; IDENT "Implicits"; n = natural ->
+	  VernacShow (ShowGoalImplicitly (Some n))
+      | IDENT "Show"; IDENT "Implicits" -> VernacShow (ShowGoalImplicitly None)
+      | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode
+      | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript
+      | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials
+      | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree
+      | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames
+      | IDENT "Show"; "Proof" -> VernacShow ShowProof
+      | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false)
+      | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
+      | IDENT "Explain"; "Proof"; l = LIST0 integer ->
+	  VernacShow (ExplainProof l)
+      | IDENT "Explain"; "Proof"; IDENT "Tree"; l = LIST0 integer -> 
+	  VernacShow (ExplainTree l)
+      | IDENT "Go"; n = natural -> VernacGo (GoTo n)
+      | IDENT "Go"; IDENT "top" -> VernacGo GoTop
+      | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev
+      | IDENT "Go"; IDENT "next" -> VernacGo GoNext
+      | IDENT "Guarded" -> VernacCheckGuard
+(* Hints for Auto and EAuto *)
+
+      | IDENT "HintDestruct"; 
+	  local = locality;
+          dloc = destruct_location;
+          id  = base_ident;
+          hyptyp = Constr.constr_pattern;
+          pri = natural;
+          "["; tac = tactic; "]" -> 
+	    VernacHints(local,[],HintsDestruct (id,pri,dloc,hyptyp,tac))
+
+      | IDENT "Hint"; local = locality; hintname = base_ident; 
+	  dbnames = opt_hintbases; ":="; h = hint
+          -> VernacHints (local,dbnames, h hintname)
+	  
+      | IDENT "Hints"; local = locality; 
+	  (dbnames,h) = hints -> VernacHints (local,dbnames, h)
+	  
+
+(*This entry is not commented, only for debug*)
+      | IDENT "PrintConstr"; c = Constr.constr -> 
+	  VernacExtend ("PrintConstr",
+	    [Genarg.in_gen Genarg.rawwit_constr c])
+      ] ];
+
+  locality:
+    [ [ IDENT "Local" -> true | -> false ] ]
+  ;
+  hint:
+    [ [ IDENT "Resolve"; c = Constr.constr -> fun name -> HintsResolve [Some name, c]
+      | IDENT "Immediate"; c = Constr.constr -> fun name -> HintsImmediate [Some name, c]
+      | IDENT "Unfold"; qid = global -> fun name -> HintsUnfold [Some name,qid]
+      | IDENT "Constructors"; c = global -> fun n ->
+          HintsConstructors (Some n,[c])
+      | IDENT "Extern"; n = natural; c = Constr.constr ; tac = tactic ->
+	  fun name -> HintsExtern (Some name,n,c,tac) ] ]
+  ;
+  hints:
+    [ [ IDENT "Resolve"; l = LIST1 global; dbnames = opt_hintbases ->
+         (dbnames, 
+	  HintsResolve
+	    (List.map (fun qid -> (None, CAppExpl(loc,(None,qid),[]))) l))
+      | IDENT "Immediate"; l = LIST1 global; dbnames = opt_hintbases ->
+        (dbnames, 
+	 HintsImmediate
+	   (List.map (fun qid-> (None, CAppExpl (loc,(None,qid),[]))) l))
+      | IDENT "Unfold"; l = LIST1 global; dbnames = opt_hintbases ->
+        (dbnames, HintsUnfold (List.map (fun qid -> (None,qid)) l)) ] ]
+    ;
+  END
diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4
new file mode 100644
index 00000000..04bf7a8b
--- /dev/null
+++ b/parsing/g_proofsnew.ml4
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  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: g_proofsnew.ml4,v 1.9.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Pcoq
+open Pp
+open Tactic
+open Util
+open Vernac_
+open Topconstr
+open Vernacexpr
+open Prim
+open Constr
+
+let thm_token = G_vernacnew.thm_token
+
+(* Proof commands *)
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command;
+
+  destruct_location :
+  [ [ IDENT "Conclusion"  -> Tacexpr.ConclLocation ()
+    | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis"
+	-> Tacexpr.HypLocation discard ] ]
+  ;
+  opt_hintbases:
+  [ [ -> []
+    | ":"; l = LIST1 IDENT -> l ] ]
+  ;
+  command:
+    [ [ IDENT "Goal"; c = Constr.lconstr -> VernacGoal c
+      | IDENT "Proof" -> VernacNop
+      | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta
+      | IDENT "Abort" -> VernacAbort None
+      | IDENT "Abort"; IDENT "All" -> VernacAbortAll
+      | IDENT "Abort"; id = identref -> VernacAbort (Some id)
+      | IDENT "Existential"; n = natural; c = constr_body ->
+	  VernacSolveExistential (n,c)
+      | IDENT "Admitted" -> VernacEndProof Admitted
+      | IDENT "Qed" -> VernacEndProof (Proved (true,None))
+      | IDENT "Save" -> VernacEndProof (Proved (true,None))
+      | IDENT "Save"; tok = thm_token; id = identref ->
+	  VernacEndProof (Proved (true,Some (id,Some tok)))
+      | IDENT "Save"; id = identref ->
+	  VernacEndProof (Proved (true,Some (id,None)))
+      | IDENT "Defined" -> VernacEndProof (Proved (false,None))
+      |	IDENT "Defined"; id=identref -> 
+	  VernacEndProof (Proved (false,Some (id,None)))
+      | IDENT "Suspend" -> VernacSuspend
+      | IDENT "Resume" -> VernacResume None
+      | IDENT "Resume"; id = identref -> VernacResume (Some id)
+      | IDENT "Restart" -> VernacRestart
+      | IDENT "Proof"; c = Constr.lconstr -> VernacExactProof c
+      | IDENT "Undo" -> VernacUndo 1
+      | IDENT "Undo"; n = natural -> VernacUndo n
+      | IDENT "Focus" -> VernacFocus None
+      | IDENT "Focus"; n = natural -> VernacFocus (Some n)
+      | IDENT "Unfocus" -> VernacUnfocus
+      | IDENT "Show" -> VernacShow (ShowGoal None)
+      | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n))
+      | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural ->
+	  VernacShow (ShowGoalImplicitly n)
+      | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode
+      | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript
+      | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials
+      | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree
+      | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames
+      | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof
+      | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false)
+      | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
+      | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer ->
+	  VernacShow (ExplainProof l)
+      | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> 
+	  VernacShow (ExplainTree l)
+      | IDENT "Go"; n = natural -> VernacGo (GoTo n)
+      | IDENT "Go"; IDENT "top" -> VernacGo GoTop
+      | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev
+      | IDENT "Go"; IDENT "next" -> VernacGo GoNext
+      | IDENT "Guarded" -> VernacCheckGuard
+(* Hints for Auto and EAuto *)
+      | IDENT "Hint"; local = locality; h = hint;
+        dbnames = opt_hintbases ->
+	  VernacHints (local,dbnames, h)
+	  
+
+(*This entry is not commented, only for debug*)
+      | IDENT "PrintConstr"; c = Constr.constr -> 
+	  VernacExtend ("PrintConstr",
+	    [Genarg.in_gen Genarg.rawwit_constr c])
+      ] ];
+
+  locality:
+    [ [ IDENT "Local" -> true | -> false ] ]
+  ;
+  hint:
+    [ [ IDENT "Resolve"; lc = LIST1 Constr.constr ->
+          HintsResolve (List.map (fun c -> (None, c)) lc)
+      | IDENT "Immediate"; lc = LIST1 Constr.constr ->
+          HintsImmediate (List.map (fun c -> (None,c)) lc)
+      | IDENT "Unfold"; lqid = LIST1 global ->
+          HintsUnfold (List.map (fun g -> (None,g)) lqid)
+      | IDENT "Constructors"; lc = LIST1 global ->
+          HintsConstructors (None,lc)
+      | IDENT "Extern"; n = natural; c = Constr.constr_pattern ; "=>";
+          tac = tactic ->
+	  HintsExtern (None,n,c,tac)
+      | IDENT"Destruct"; 
+          id = base_ident; ":=";
+          pri = natural;
+          dloc = destruct_location;
+          hyptyp = Constr.constr_pattern;
+          "=>"; tac = tactic ->
+            HintsDestruct(id,pri,dloc,hyptyp,tac) ] ]
+    ;
+  constr_body:
+    [ [ ":="; c = lconstr -> c
+      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c,t) ] ]
+  ;
+END
diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml
new file mode 100644
index 00000000..8f5aad33
--- /dev/null
+++ b/parsing/g_rsyntax.ml
@@ -0,0 +1,332 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+open Coqast
+open Ast
+open Pp
+open Util
+open Names
+open Pcoq
+open Extend
+open Topconstr
+open Libnames
+
+(**********************************************************************)
+(* Parsing with Grammar                                               *)
+(**********************************************************************)
+
+let get_r_sign loc =
+  let mkid id =
+    mkRefC (Qualid (loc,Libnames.make_short_qualid id))
+  in
+  ((mkid (id_of_string "R0"),
+    mkid (id_of_string "R1"),
+    mkid (id_of_string "Rplus"),
+    mkid (id_of_string "Rmult"),
+    mkid (id_of_string "NRplus"),
+    mkid (id_of_string "NRmult")))
+
+let get_r_sign_ast loc =
+  let mkid id =
+    Termast.ast_of_ref (Nametab.locate (Libnames.make_short_qualid id))
+  in
+  ((mkid (id_of_string "R0"),
+    mkid (id_of_string "R1"),
+    mkid (id_of_string "Rplus"), 
+    mkid (id_of_string "Rmult"),
+    mkid (id_of_string "NRplus"),
+    mkid (id_of_string "NRmult")))
+
+(* We have the following interpretation:
+  [| 0 |] = 0
+  [| 1 |] = 1
+  [| 2 |] = 1 + 1
+  [| 3 |] = 1 + (1 + 1)
+  [| 2n |] = 2 * [| n |]         for n >= 2
+  [| 2n+1 |] = 1 + 2 * [| n |]   for n >= 2
+  [| -n |] = - [| n |]           for n >= 0
+*)
+
+let int_decomp n = 
+let div2 k = 
+let x = k mod 2 in
+let y = k - x in (x,y/2) in
+let rec list_ch m =
+if m< 2 then [m]
+else let (x1,x2) = div2 m in x1::(list_ch x2)
+in list_ch n
+
+let _ = if !Options.v7 then
+let r_of_int n dloc =
+  let (a0,a1,plus,mult,_,_) = get_r_sign dloc in
+  let list_ch = int_decomp n in
+  let a2 = mkAppC (plus, [a1; a1]) in
+  let rec mk_r l =
+    match l with
+    | [] -> failwith "Error r_of_int"
+    | [a] -> if a=1 then a1 else a0
+    | [a;b] -> if a==1 then mkAppC (plus, [a1; a2]) else a2
+    | a::l' -> if a=1 then mkAppC (plus, [a1; mkAppC (mult, [a2; mk_r l'])]) else mkAppC (mult, [a2; mk_r l'])
+  in mk_r list_ch
+in
+let r_of_string s dloc = 
+  r_of_int (int_of_string s) dloc
+in
+let rsyntax_create name =
+  let e =
+    Pcoq.create_constr_entry (Pcoq.get_univ "rnatural") name in
+  Pcoq.Gram.Unsafe.clear_entry e;
+  e
+in
+let rnumber = rsyntax_create "rnumber"
+in
+let _ = 
+  Gram.extend rnumber None
+    [None, None,
+     [[Gramext.Stoken ("INT", "")],
+      Gramext.action r_of_string]]
+in ()
+
+(**********************************************************************)
+(* Old ast printing                                                   *)
+(**********************************************************************)
+
+exception Non_closed_number
+
+let _ = if !Options.v7 then
+let int_of_r p =
+  let (a0,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in
+  let rec int_of_r_rec p = 
+    match p with
+  | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) & alpha_eq(c,a1) -> 2
+  | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) ->
+      (match c with
+      |	Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,mult) -> 1 + int_of_r_rec c
+      |	Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> 3
+      |	_ -> raise Non_closed_number)
+  | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,mult) ->
+      (match a with
+      |	Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) ->
+	  (match c with
+	  | g when alpha_eq(g,a1) -> raise Non_closed_number
+	  | g when alpha_eq(g,a0) -> raise Non_closed_number
+	  | _ -> 2 * int_of_r_rec c)
+      |	_ -> raise Non_closed_number)
+  | a when alpha_eq(a,a0) -> 0
+  | a when alpha_eq(a,a1) -> 1
+  | _ -> raise Non_closed_number in
+  try 
+    Some (int_of_r_rec p)
+  with
+    Non_closed_number -> None
+in
+let replace_plus p = 
+  let (_,_,_,_,astnrplus,_) = get_r_sign_ast dummy_loc in
+  ope ("REXPR",[ope("APPLIST",[astnrplus;p])])
+in
+let replace_mult p = 
+  let (_,_,_,_,_,astnrmult) = get_r_sign_ast dummy_loc in
+  ope ("REXPR",[ope("APPLIST",[astnrmult;p])])
+in
+let rec r_printer_odd std_pr p =
+  let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in
+  match (int_of_r (ope("APPLIST",[plus;a1;p]))) with
+    | Some i -> str (string_of_int i)
+    | None -> std_pr (replace_plus p)
+in
+let rec r_printer_odd_outside std_pr p =
+  let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in
+  match (int_of_r (ope("APPLIST",[plus;a1;p]))) with
+    | Some i -> str"``" ++ str (string_of_int i) ++ str"``"
+    | None -> std_pr (replace_plus p)
+in
+let rec r_printer_even std_pr p =
+  let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in
+  match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with
+    | Some i -> str (string_of_int i)
+    | None -> std_pr (replace_mult p)
+in
+let rec r_printer_even_outside std_pr p =
+  let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in
+  match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with
+    | Some i -> str"``" ++ str (string_of_int i) ++ str"``"
+    | None -> std_pr (replace_mult p)
+in
+let _ = Esyntax.Ppprim.add ("r_printer_odd", r_printer_odd) in
+let _ = Esyntax.Ppprim.add ("r_printer_odd_outside", r_printer_odd_outside) in
+let _ = Esyntax.Ppprim.add ("r_printer_even", r_printer_even) in
+let _ = Esyntax.Ppprim.add ("r_printer_even_outside", r_printer_even_outside)
+in ()
+
+(**********************************************************************)
+(* Parsing R via scopes                                               *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+open Bignat
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
+
+(* TODO: temporary hack *)
+let make_path dir id = Libnames.encode_kn dir (id_of_string id)
+
+let glob_R = ConstRef (make_path rdefinitions "R")
+let glob_R1 = ConstRef (make_path rdefinitions "R1")
+let glob_R0 = ConstRef (make_path rdefinitions "R0")
+let glob_Ropp = ConstRef (make_path rdefinitions "Ropp")
+let glob_Rplus = ConstRef (make_path rdefinitions "Rplus")
+let glob_Rmult = ConstRef (make_path rdefinitions "Rmult")
+
+(* V7 *)
+let r_of_posint dloc n =
+  let ref_R0 = RRef (dloc, glob_R0) in
+  let ref_R1 = RRef (dloc, glob_R1) in
+  let ref_Rplus = RRef (dloc, glob_Rplus) in
+  let ref_Rmult = RRef (dloc, glob_Rmult) in
+  let a2 = RApp(dloc, ref_Rplus, [ref_R1; ref_R1]) in
+  let list_ch = int_decomp n in
+  let rec mk_r l =
+    match l with
+    | [] -> failwith "Error r_of_posint"
+    | [a] -> if a=1 then ref_R1 else ref_R0
+    | a::[b] -> if a==1 then RApp (dloc, ref_Rplus, [ref_R1; a2]) else a2
+    | a::l' -> if a=1 then RApp (dloc, ref_Rplus, [ref_R1; RApp (dloc, ref_Rmult, [a2; mk_r l'])]) else RApp (dloc, ref_Rmult, [a2; mk_r l'])
+  in mk_r list_ch
+
+(* int_of_string o bigint_to_string : temporary hack ... *)
+(* utiliser les bigint de caml ? *)
+let r_of_int2 dloc z =
+  match z with
+  | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (int_of_string (bigint_to_string (POS n)))]) 
+  | POS n -> r_of_posint dloc (int_of_string (bigint_to_string z))
+
+(* V8 *)
+let two = mult_2 one
+let three = add_1 two
+let four = mult_2 two
+
+(* Unary representation of strictly positive numbers *)
+let rec small_r dloc n =
+  if is_one n then RRef (dloc, glob_R1)
+  else RApp(dloc,RRef (dloc,glob_Rplus),
+            [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+
+let r_of_posint dloc n =
+  let r1 = RRef (dloc, glob_R1) in
+  let r2 = small_r dloc two in
+  let rec r_of_pos n =
+    if less_than n four then small_r dloc n
+    else
+      let (q,r) = div2_with_rest n in
+      let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
+      if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in
+  if is_nonzero n then r_of_pos n else RRef(dloc,glob_R0)
+
+let r_of_int dloc z =
+  match z with
+  | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc n]) 
+  | POS n -> r_of_posint dloc n
+
+(**********************************************************************)
+(* Printing R via scopes                                              *)
+(**********************************************************************)
+
+let bignat_of_r =
+(* for numbers > 1 *)
+let rec bignat_of_pos = function
+  (* 1+1 *)
+  | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)])
+      when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
+  (* 1+(1+1) *)
+  | RApp (_,RRef (_,p1), [RRef (_,o1);
+      RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])])
+      when p1 = glob_Rplus & p2 = glob_Rplus &
+           o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
+  (* (1+1)*b *)
+  | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult ->
+      if bignat_of_pos a <> two then raise Non_closed_number;
+      mult_2 (bignat_of_pos b)
+  (* 1+(1+1)*b *)
+  | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])])
+      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  -> 
+      if bignat_of_pos a <> two then raise Non_closed_number;
+        add_1 (mult_2 (bignat_of_pos b))
+  | _ -> raise Non_closed_number
+in
+let bignat_of_r = function
+  | RRef (_,a) when a = glob_R0 -> zero
+  | RRef (_,a) when a = glob_R1 -> one
+  | r -> bignat_of_pos r
+in
+bignat_of_r
+
+let bigint_of_r = function
+  | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> NEG (bignat_of_r a)
+  | a -> POS (bignat_of_r a)
+
+let uninterp_r p =
+  try
+    Some (bigint_of_r p)
+  with Non_closed_number ->
+    None
+
+let _ = Symbols.declare_numeral_interpreter "R_scope"
+  (glob_R,["Coq";"Reals";"Rdefinitions"])
+  ((if !Options.v7 then r_of_int2 else r_of_int),None)
+  ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0);
+    RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);RRef(dummy_loc,glob_R1)],
+    uninterp_r,
+    None)
+
+(************************************************************************)
+(* Old ast printers via scope *)
+
+let _ = if !Options.v7 then
+let bignat_of_pos p =
+  let (_,one,plus,_,_,_) = get_r_sign_ast dummy_loc in
+  let rec transl = function
+    | Node (_,"APPLIST",[p; o; a]) when alpha_eq(p,plus) & alpha_eq(o,one)
+        -> add_1(transl a)
+    | a when alpha_eq(a,one) -> Bignat.one
+    | _ -> raise Non_closed_number
+  in transl p
+in
+let bignat_option_of_pos p =
+  try 
+    Some (bignat_of_pos p)
+  with Non_closed_number -> 
+    None
+in
+let r_printer_Rplus1 p =
+  match bignat_option_of_pos p with
+    | Some n -> Some (str (Bignat.to_string (add_1 n)))
+    | None -> None
+in
+let r_printer_Ropp p =
+  match bignat_option_of_pos p with
+    | Some n -> Some (str "-" ++ str (Bignat.to_string n))
+    | None -> None
+in
+let r_printer_R1 _ =
+  Some (int 1)
+in
+let r_printer_R0 _ =
+  Some (int 0)
+in
+(* Declare pretty-printers for integers *)
+let _ =
+  Esyntax.declare_primitive_printer "r_printer_Ropp" "R_scope" (r_printer_Ropp)
+in let _ =
+  Esyntax.declare_primitive_printer "r_printer_Rplus1" "R_scope" (r_printer_Rplus1)
+in let _ =
+  Esyntax.declare_primitive_printer "r_printer_R1" "R_scope" (r_printer_R1)
+in let _ =
+  Esyntax.declare_primitive_printer "r_printer_R0" "R_scope" r_printer_R0
+in ()
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
new file mode 100644
index 00000000..2e067215
--- /dev/null
+++ b/parsing/g_tactic.ml4
@@ -0,0 +1,367 @@
+(************************************************************************)
+(*  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: g_tactic.ml4,v 1.83.2.2 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Pp
+open Ast
+open Pcoq
+open Util
+open Tacexpr
+open Rawterm
+open Genarg
+open Constr
+open Prim
+open Tactic
+
+let tactic_kw =
+  [ "using"; "Orelse"; "Proof"; "Qed"; "And"; "()"; "|-" ]
+let _ =
+  if !Options.v7 then
+    List.iter (fun s -> Lexer.add_token ("",s)) tactic_kw
+
+(* Functions overloaded by quotifier *)
+
+let induction_arg_of_constr c =
+  try ElimOnIdent (Topconstr.constr_loc c,snd (coerce_to_id c))
+  with _ -> ElimOnConstr c
+
+let local_compute = [FBeta;FIota;FDeltaBut [];FZeta]
+
+let error_oldelim _ = error "OldElim no longer supported"
+
+let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2)
+
+(* Auxiliary grammar rules *)
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: simple_tactic constrarg bindings constr_with_bindings 
+  quantified_hypothesis red_expr int_or_var castedopenconstr
+  simple_intropattern;
+
+  int_or_var:
+    [ [ n = integer  -> Genarg.ArgArg n
+      | id = identref -> Genarg.ArgVar id ] ]
+  ;
+  autoarg_depth:
+  [ [ n = OPT natural -> n ] ]
+  ;
+  autoarg_adding:
+  [ [ IDENT "Adding" ; "["; l = LIST1 global; "]" -> l | -> [] ] ]
+  ;
+  autoarg_destructing:
+  [ [ IDENT "Destructing" -> true | -> false ] ]
+  ;
+  autoarg_usingTDB:
+  [ [ "Using"; "TDB"  -> true | -> false ] ]
+  ;
+  autoargs:
+  [ [ a0 = autoarg_depth; l = autoarg_adding; 
+      a2 = autoarg_destructing; a3 = autoarg_usingTDB -> (a0,l,a2,a3) ] ]
+  ;
+  (* Either an hypothesis or a ltac ref (variable or pattern patvar) *)
+  id_or_ltac_ref:
+    [ [ id = base_ident -> AI (loc,id)
+      | "?"; n = natural -> AI (loc,Pattern.patvar_of_int n) ] ]
+  ;
+  (* Either a global ref or a ltac ref (variable or pattern patvar) *)
+  global_or_ltac_ref:
+    [ [ qid = global -> qid
+      | "?"; n = natural -> Libnames.Ident (loc,Pattern.patvar_of_int n) ] ]
+  ;
+  (* An identifier or a quotation meta-variable *)
+  id_or_meta:
+    [ [ id = identref -> AI id 
+
+      (* This is used in quotations *)
+      | id = METAIDENT -> MetaId (loc,id) ] ]
+  ;
+  (* A number or a quotation meta-variable *)
+  num_or_meta:
+    [ [ n = integer -> AI n
+      |	id = METAIDENT -> MetaId (loc,id)
+      ] ]
+  ;
+  constrarg:
+    [ [ IDENT "Inst"; id = identref; "["; c = constr; "]" ->
+        ConstrContext (id, c)
+      | IDENT "Eval"; rtc = Tactic.red_expr; "in"; c = constr ->
+        ConstrEval (rtc,c) 
+      | IDENT "Check"; c = constr -> ConstrTypeOf c
+      | c = constr -> ConstrTerm c ] ]
+  ;
+  castedopenconstr:
+    [ [ c = constr -> c ] ]
+  ;
+  induction_arg:
+    [ [ n = natural -> ElimOnAnonHyp n
+      | c = constr -> induction_arg_of_constr c
+    ] ]
+  ;
+  quantified_hypothesis:
+    [ [ id = base_ident -> NamedHyp id
+      | n = natural -> AnonHyp n ] ]
+  ;
+  conversion:
+    [ [ nl = LIST1 integer; c1 = constr; "with"; c2 = constr ->
+         (Some (nl,c1), c2)
+      |	c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2)
+      | c = constr -> (None, c) ] ]
+  ;
+  pattern_occ:
+    [ [ nl = LIST0 integer; c = constr -> (nl,c) ] ]
+  ;
+  intropatterns:
+    [ [ l = LIST0 simple_intropattern -> l ]]
+  ;
+  simple_intropattern:
+    [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc
+      | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc]
+      | IDENT "_" -> IntroWildcard
+      | id = base_ident -> IntroIdentifier id
+      ] ]
+  ;
+  simple_binding:
+    [ [ id = base_ident; ":="; c = constr -> (loc, NamedHyp id, c)
+      | n = natural; ":="; c = constr -> (loc, AnonHyp n, c) ] ]
+  ;
+  bindings:
+    [ [ c1 = constr; ":="; c2 = constr; bl = LIST0 simple_binding ->
+          ExplicitBindings
+            ((join_to_constr loc c2,NamedHyp (snd(coerce_to_id c1)), c2) :: bl)
+      | n = natural; ":="; c = constr; bl = LIST0 simple_binding ->
+	  ExplicitBindings ((join_to_constr loc c,AnonHyp n, c) :: bl)
+      | c1 = constr; bl = LIST0 constr ->
+	  ImplicitBindings (c1 :: bl) ] ]
+  ;
+  constr_with_bindings:
+    [ [ c = constr; l = with_bindings -> (c, l) ] ]
+  ;
+  with_bindings:
+    [ [ "with"; bl = bindings -> bl | -> NoBindings ] ]
+  ;
+  unfold_occ:
+    [ [ nl = LIST0 integer; c = global_or_ltac_ref -> (nl,c) ] ]
+  ;
+  red_flag:
+    [ [ IDENT "Beta" -> FBeta
+      | IDENT "Delta" -> FDeltaBut []
+      | IDENT "Iota" -> FIota
+      | IDENT "Zeta" -> FZeta
+      | IDENT "Delta"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FConst idl
+      | IDENT "Delta"; "-"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FDeltaBut idl
+    ] ]
+  ;
+  red_tactic:
+    [ [ IDENT "Red" -> Red false
+      | IDENT "Hnf" -> Hnf
+      | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
+      | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
+      | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta])
+      | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul
+      | IDENT "Fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl ] ]
+  ;
+  (* This is [red_tactic] including possible extensions *)
+  red_expr:
+    [ [ IDENT "Red" -> Red false
+      | IDENT "Hnf" -> Hnf
+      | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
+      | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
+      | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta])
+      | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul
+      | IDENT "Fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl
+      | s = IDENT; c = constr -> ExtraRedExpr (s,c) ] ]
+  ;
+  hypident:
+    [ [ id = id_or_meta -> id,[],(InHyp,ref None)
+      | "("; "Type"; "of"; id = id_or_meta; ")" ->
+          id,[],(InHypTypeOnly,ref None)
+    ] ]
+  ;
+  clause:
+    [ [ "in"; idl = LIST1 hypident ->
+        {onhyps=Some idl;onconcl=false; concl_occs=[]}
+      | -> {onhyps=Some[];onconcl=true;concl_occs=[]} ] ]
+  ;
+  simple_clause:
+    [ [ "in"; idl = LIST1 id_or_meta -> idl
+      | -> [] ] ]
+  ;
+  pattern_occ_hyp_tail_list:
+    [ [ pl = pattern_occ_hyp_list -> pl
+      | -> {onhyps=Some[];onconcl=false; concl_occs=[]} ] ]
+  ;
+  pattern_occ_hyp_list:
+    [ [ nl = LIST1 natural; IDENT "Goal" ->
+          {onhyps=Some[];onconcl=true;concl_occs=nl}
+      | nl = LIST1 natural; id = id_or_meta; cls = pattern_occ_hyp_tail_list
+        -> {cls with
+            onhyps=option_app(fun l -> (id,nl,(InHyp,ref None))::l)
+              cls.onhyps} 
+      | IDENT "Goal" -> {onhyps=Some[];onconcl=true;concl_occs=[]}
+      | id = id_or_meta; cls = pattern_occ_hyp_tail_list ->
+         {cls with
+          onhyps=option_app(fun l -> (id,[],(InHyp,ref None))::l)
+            cls.onhyps} ] ]
+  ;
+  clause_pattern:
+    [ [ "in"; p = pattern_occ_hyp_list -> p 
+      | -> {onhyps=None; onconcl=true; concl_occs=[] } ] ]
+  ;
+  fixdecl:
+    [ [ id = base_ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ]
+  ;
+  cofixdecl:
+    [ [ id = base_ident; ":"; c = constr -> (id,c) ] ]
+  ;
+  hintbases:
+    [ [ "with"; "*" -> None
+      | "with"; l = LIST1 IDENT -> Some l
+      | -> Some [] ] ]
+  ;
+  eliminator:
+    [ [ "using"; el = constr_with_bindings -> el ] ]
+  ;
+  with_names:
+    [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ]
+  ;
+  simple_tactic:
+    [ [ 
+      (* Basic tactics *)
+        IDENT "Intros"; IDENT "until"; id = quantified_hypothesis -> 
+	  TacIntrosUntil id
+      | IDENT "Intros"; pl = intropatterns -> TacIntroPattern pl
+      | IDENT "Intro"; id = base_ident; IDENT "after"; id2 = identref ->
+	  TacIntroMove (Some id, Some id2)
+      | IDENT "Intro"; IDENT "after"; id2 = identref ->
+	  TacIntroMove (None, Some id2)
+      | IDENT "Intro"; id = base_ident -> TacIntroMove (Some id,None)
+      | IDENT "Intro" -> TacIntroMove (None, None)
+
+      | IDENT "Assumption" -> TacAssumption
+      | IDENT "Exact"; c = constr -> TacExact c
+
+      | IDENT "Apply"; cl = constr_with_bindings -> TacApply cl
+      | IDENT "Elim"; cl = constr_with_bindings; el = OPT eliminator ->
+          TacElim (cl,el)
+      | IDENT "OldElim"; c = constr ->
+	  (* TacOldElim c *) error_oldelim ()
+      | IDENT "ElimType"; c = constr -> TacElimType c
+      | IDENT "Case"; cl = constr_with_bindings -> TacCase cl
+      | IDENT "CaseType"; c = constr -> TacCaseType c
+      | IDENT "Fix"; n = natural -> TacFix (None,n)
+      | IDENT "Fix"; id = base_ident; n = natural -> TacFix (Some id,n)
+      | IDENT "Fix"; id = base_ident; n = natural; "with"; fd = LIST0 fixdecl ->
+	  TacMutualFix (id,n,fd)
+      | IDENT "Cofix" -> TacCofix None
+      | IDENT "Cofix"; id = base_ident -> TacCofix (Some id)
+      | IDENT "Cofix"; id = base_ident; "with"; fd = LIST0 cofixdecl ->
+	  TacMutualCofix (id,fd)
+
+      | IDENT "Cut"; c = constr -> TacCut c
+      | IDENT "Assert"; c = constr -> TacTrueCut (Names.Anonymous,c)
+      | IDENT "Assert"; c = constr; ":"; t = constr ->
+          TacTrueCut (Names.Name (snd(coerce_to_id c)),t)
+      | IDENT "Assert"; c = constr; ":="; b = constr ->
+          TacForward (false,Names.Name (snd (coerce_to_id c)),b)
+      | IDENT "Pose"; c = constr; ":="; b = constr ->
+	  TacForward (true,Names.Name (snd(coerce_to_id c)),b)
+      | IDENT "Pose"; b = constr -> TacForward (true,Names.Anonymous,b)
+      | IDENT "Generalize"; lc = LIST1 constr -> TacGeneralize lc
+      | IDENT "Generalize"; IDENT "Dependent"; c = constr -> TacGeneralizeDep c
+      | IDENT "LetTac"; (_,na) = name; ":="; c = constr; p = clause_pattern
+        -> TacLetTac (na,c,p)
+      | IDENT "Instantiate"; n = natural; c = constr; cls = clause -> 
+	    TacInstantiate (n,c,cls)
+      | IDENT "Specialize"; n = OPT natural; lcb = constr_with_bindings ->
+	  TacSpecialize (n,lcb)
+      | IDENT "LApply"; c = constr -> TacLApply c
+
+      (* Derived basic tactics *)
+      | IDENT "Induction"; h = quantified_hypothesis -> TacSimpleInduction (h,ref [])
+      | IDENT "NewInduction"; c = induction_arg; el = OPT eliminator;
+          ids = with_names -> TacNewInduction (c,el,(ids,ref []))
+      | IDENT "Double"; IDENT "Induction"; h1 = quantified_hypothesis;
+	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
+      | IDENT "Destruct"; h = quantified_hypothesis -> TacSimpleDestruct h
+      | IDENT "NewDestruct"; c = induction_arg; el = OPT eliminator; 
+          ids = with_names -> TacNewDestruct (c,el,(ids,ref []))
+      | IDENT "Decompose"; IDENT "Record" ; c = constr -> TacDecomposeAnd c
+      | IDENT "Decompose"; IDENT "Sum"; c = constr -> TacDecomposeOr c
+      | IDENT "Decompose"; "["; l = LIST1 global_or_ltac_ref; "]"; c = constr
+        -> TacDecompose (l,c)
+
+      (* Automation tactic *)
+      | IDENT "Trivial"; db = hintbases -> TacTrivial db
+      | IDENT "Auto"; n = OPT natural; db = hintbases -> TacAuto (n, db)
+
+      | IDENT "AutoTDB"; n = OPT natural -> TacAutoTDB n
+      | IDENT "CDHyp"; id = identref -> TacDestructHyp (true,id)
+      | IDENT "DHyp";  id = identref -> TacDestructHyp (false,id)
+      | IDENT "DConcl"  -> TacDestructConcl
+      | IDENT "SuperAuto"; l = autoargs -> TacSuperAuto l
+      | IDENT "Auto"; n = OPT natural; IDENT "Decomp"; p = OPT natural ->
+	  TacDAuto (n, p)
+
+      (* Context management *)
+      | IDENT "Clear"; l = LIST1 id_or_ltac_ref -> TacClear l
+      | IDENT "ClearBody"; l = LIST1 id_or_ltac_ref -> TacClearBody l
+      | IDENT "Move"; id1 = id_or_ltac_ref; IDENT "after"; 
+	  id2 = id_or_ltac_ref -> TacMove (true,id1,id2)
+      | IDENT "Rename"; id1 = id_or_ltac_ref; IDENT "into"; 
+	  id2 = id_or_ltac_ref -> TacRename (id1,id2)
+
+      (* Constructors *)
+      | IDENT "Left"; bl = with_bindings -> TacLeft bl
+      | IDENT "Right"; bl = with_bindings -> TacRight bl
+      | IDENT "Split"; bl = with_bindings -> TacSplit (false,bl)
+      | IDENT "Exists"; bl = bindings -> TacSplit (true,bl)
+      | IDENT "Exists" -> TacSplit (true,NoBindings)
+      | IDENT "Constructor"; n = num_or_meta; l = with_bindings ->
+	  TacConstructor (n,l)
+      | IDENT "Constructor"; t = OPT tactic -> TacAnyConstructor t
+
+      (* Equivalence relations *)
+      | IDENT "Reflexivity" -> TacReflexivity
+      | IDENT "Symmetry"; cls = clause -> TacSymmetry cls
+      | IDENT "Transitivity"; c = constr -> TacTransitivity c
+
+      (* Equality and inversion *)
+      | IDENT "Dependent"; k =
+	  [ IDENT "Simple"; IDENT "Inversion" -> SimpleInversion
+	  | IDENT "Inversion" -> FullInversion
+	  | IDENT "Inversion_clear" -> FullInversionClear ];
+	  hyp = quantified_hypothesis; 
+	  ids = with_names; co = OPT ["with"; c = constr -> c] ->
+	    TacInversion (DepInversion (k,co,ids),hyp)
+      | IDENT "Simple"; IDENT "Inversion";
+	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
+	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
+      | IDENT "Inversion"; 
+	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
+	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
+      | IDENT "Inversion_clear"; 
+	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
+	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
+      | IDENT "Inversion"; hyp = quantified_hypothesis; 
+	  "using"; c = constr; cl = simple_clause ->
+	    TacInversion (InversionUsing (c,cl), hyp)
+
+      (* Conversion *)
+      | r = red_tactic; cl = clause -> TacReduce (r, cl)
+      (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
+      | IDENT "Change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl)
+
+    ] ]
+  ;
+END;;
diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4
new file mode 100644
index 00000000..2070b40e
--- /dev/null
+++ b/parsing/g_tacticnew.ml4
@@ -0,0 +1,401 @@
+(************************************************************************)
+(*  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: g_tacticnew.ml4,v 1.35.2.2 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Pp
+open Ast
+open Pcoq
+open Util
+open Tacexpr
+open Rawterm
+open Genarg
+
+let compute = Cbv all_flags
+
+let tactic_kw =
+  [ "->"; "<-" ]
+let _ = 
+  if not !Options.v7 then
+    List.iter (fun s -> Lexer.add_token("",s)) tactic_kw
+
+(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
+(* admissible notation "(x t)" *)
+let lpar_id_coloneq =
+  Gram.Entry.of_parser "lpar_id_coloneq"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+              | [_; ("IDENT",s)] ->
+                  (match Stream.npeek 3 strm with
+	            | [_; _; ("", ":=")] ->
+                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+                        Names.id_of_string s
+	            | _ -> raise Stream.Failure)
+	      | _ -> raise Stream.Failure)
+	| _ -> raise Stream.Failure)
+
+(* idem for (x:=t) and (1:=t) *)
+let test_lpar_idnum_coloneq =
+  Gram.Entry.of_parser "test_lpar_idnum_coloneq"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+              | [_; (("IDENT"|"INT"),_)] ->
+                  (match Stream.npeek 3 strm with
+                    | [_; _; ("", ":=")] -> ()
+                    | _ -> raise Stream.Failure)
+              | _ -> raise Stream.Failure)
+        | _ -> raise Stream.Failure)
+
+(* idem for (x:t) *)
+let lpar_id_colon =
+  Gram.Entry.of_parser "lpar_id_colon"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+              | [_; ("IDENT",id)] ->
+                  (match Stream.npeek 3 strm with
+                    | [_; _; ("", ":")] ->
+                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+                        Names.id_of_string id
+                    | _ -> raise Stream.Failure)
+              | _ -> raise Stream.Failure)
+        | _ -> raise Stream.Failure)
+
+open Constr
+open Prim
+open Tactic
+
+let mk_fix_tac (loc,id,bl,ann,ty) =
+  let n =
+    match bl,ann with
+        [([_],_)], None -> 0
+      | _, Some x ->
+          let ids = List.map snd (List.flatten (List.map fst bl)) in
+          (try list_index (snd x) ids
+          with Not_found -> error "no such fix variable")
+      | _ -> error "cannot guess decreasing argument of fix" in
+  (id,n,Topconstr.CProdN(loc,bl,ty))
+
+let mk_cofix_tac (loc,id,bl,ann,ty) =
+  let _ = option_app (fun (aloc,_) ->
+    Util.user_err_loc
+      (aloc,"Constr:mk_cofix_tac",
+       Pp.str"Annotation forbidden in cofix expression")) ann in
+  (id,Topconstr.CProdN(loc,bl,ty))
+
+(* Functions overloaded by quotifier *)
+let induction_arg_of_constr c =
+  try ElimOnIdent (Topconstr.constr_loc c,snd(coerce_to_id c))
+  with _ -> ElimOnConstr c
+
+let local_compute = [FBeta;FIota;FDeltaBut [];FZeta]
+
+let error_oldelim _ = error "OldElim no longer supported"
+
+let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2)
+
+(* Auxiliary grammar rules *)
+
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
+  bindings red_expr int_or_var castedopenconstr simple_intropattern;
+
+  int_or_var:
+    [ [ n = integer  -> Genarg.ArgArg n
+      | id = identref -> Genarg.ArgVar id ] ]
+  ;
+  (* An identifier or a quotation meta-variable *)
+  id_or_meta:
+    [ [ id = identref -> AI id 
+
+      (* This is used in quotations *)
+      | id = METAIDENT -> MetaId (loc,id) ] ]
+  ;
+  (* A number or a quotation meta-variable *)
+  num_or_meta:
+    [ [ n = integer -> AI n
+      |	id = METAIDENT -> MetaId (loc,id)
+      ] ]
+  ;
+  castedopenconstr:
+    [ [ c = constr -> c ] ]
+  ;
+  induction_arg:
+    [ [ n = natural -> ElimOnAnonHyp n
+      | c = constr -> induction_arg_of_constr c
+    ] ]
+  ;
+  quantified_hypothesis:
+    [ [ id = base_ident -> NamedHyp id
+      | n = natural -> AnonHyp n ] ]
+  ;
+  conversion:
+    [ [ c = constr -> (None, c)
+      | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2)
+      | c1 = constr; "at"; nl = LIST1 integer; "with"; c2 = constr ->
+	  (Some (nl,c1), c2) ] ]
+  ;
+  occurrences:
+    [ [ "at"; nl = LIST1 integer -> nl
+      | -> [] ] ]
+  ;
+  pattern_occ:
+    [ [ c = constr; nl = occurrences -> (nl,c) ] ]
+  ;
+  unfold_occ:
+    [ [ c = global; nl = occurrences -> (nl,c) ] ]
+  ;
+  intropatterns:
+    [ [ l = LIST0 simple_intropattern -> l ]]
+  ;
+  simple_intropattern:
+    [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc
+      | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc]
+      | "_" -> IntroWildcard
+      | id = base_ident -> IntroIdentifier id
+      ] ]
+  ;
+  simple_binding:
+    [ [ "("; id = base_ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c)
+      | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ]
+  ;
+  bindings:
+    [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding ->
+          ExplicitBindings bl
+      | bl = LIST1 constr -> ImplicitBindings bl ] ]
+  ;
+  constr_with_bindings:
+    [ [ c = constr; l = with_bindings -> (c, l) ] ]
+  ;
+  with_bindings:
+    [ [ "with"; bl = bindings -> bl | -> NoBindings ] ]
+  ;
+  red_flag:
+    [ [ IDENT "beta" -> FBeta
+      | IDENT "delta" -> FDeltaBut []
+      | IDENT "iota" -> FIota
+      | IDENT "zeta" -> FZeta
+      | IDENT "delta"; "["; idl = LIST1 global; "]" -> FConst idl
+      | IDENT "delta"; "-"; "["; idl = LIST1 global; "]" -> FDeltaBut idl
+    ] ]
+  ;
+  red_tactic:
+    [ [ IDENT "red" -> Red false
+      | IDENT "hnf" -> Hnf
+      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
+      | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
+      | IDENT "compute" -> compute
+      | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
+      | IDENT "fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "pattern"; pl = LIST1 pattern_occ SEP","-> Pattern pl ] ]
+  ;
+  (* This is [red_tactic] including possible extensions *)
+  red_expr:
+    [ [ IDENT "red" -> Red false
+      | IDENT "hnf" -> Hnf
+      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
+      | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
+      | IDENT "compute" -> compute
+      | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul
+      | IDENT "fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl
+      | s = IDENT; c = constr -> ExtraRedExpr (s,c) ] ]
+  ;
+  hypident:
+    [ [ id = id_or_meta -> id,(InHyp,ref None)
+      | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" ->
+          id,(InHypTypeOnly,ref None)
+      | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" ->
+          id,(InHypValueOnly,ref None)
+    ] ]
+  ;
+  hypident_occ:
+    [ [ (id,l)=hypident; occs=occurrences -> (id,occs,l) ] ]
+  ;
+  clause:
+    [ [ "in"; "*"; occs=occurrences ->
+        {onhyps=None;onconcl=true;concl_occs=occs}
+      | "in"; "*"; "|-"; (b,occs)=concl_occ ->
+          {onhyps=None; onconcl=b; concl_occs=occs}
+      | "in"; hl=LIST0 hypident_occ SEP","; "|-"; (b,occs)=concl_occ ->
+          {onhyps=Some hl; onconcl=b; concl_occs=occs}
+      | "in"; hl=LIST0 hypident_occ SEP"," ->
+          {onhyps=Some hl; onconcl=false; concl_occs=[]}
+      | -> {onhyps=Some[];onconcl=true; concl_occs=[]} ] ]
+  ;
+  concl_occ:
+    [ [ "*"; occs = occurrences -> (true,occs)
+      | -> (false, []) ] ]
+  ;
+  simple_clause:
+    [ [ "in"; idl = LIST1 id_or_meta -> idl
+      | -> [] ] ]
+  ;
+  fixdecl:
+    [ [ "("; id = base_ident; bl=LIST0 Constr.binder; ann=fixannot;
+        ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ]
+  ;
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
+      | -> None ] ]
+  ;
+  hintbases:
+    [ [ "with"; "*" -> None
+      | "with"; l = LIST1 IDENT -> Some l
+      | -> Some [] ] ]
+  ;
+  eliminator:
+    [ [ "using"; el = constr_with_bindings -> el ] ]
+  ;
+  with_names:
+    [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ]
+  ;
+  simple_tactic:
+    [ [ 
+      (* Basic tactics *)
+        IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> 
+	  TacIntrosUntil id
+      | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl
+      | IDENT "intro"; id = base_ident; IDENT "after"; id2 = identref ->
+	  TacIntroMove (Some id, Some id2)
+      | IDENT "intro"; IDENT "after"; id2 = identref ->
+	  TacIntroMove (None, Some id2)
+      | IDENT "intro"; id = base_ident -> TacIntroMove (Some id, None)
+      | IDENT "intro" -> TacIntroMove (None, None)
+
+      | IDENT "assumption" -> TacAssumption
+      | IDENT "exact"; c = constr -> TacExact c
+
+      | IDENT "apply"; cl = constr_with_bindings -> TacApply cl
+      | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator ->
+          TacElim (cl,el)
+      | IDENT "elimtype"; c = constr -> TacElimType c
+      | IDENT "case"; cl = constr_with_bindings -> TacCase cl
+      | IDENT "casetype"; c = constr -> TacCaseType c
+      | "fix"; n = natural -> TacFix (None,n)
+      | "fix"; id = base_ident; n = natural -> TacFix (Some id,n)
+      | "fix"; id = base_ident; n = natural; "with"; fd = LIST1 fixdecl ->
+	  TacMutualFix (id,n,List.map mk_fix_tac fd)
+      | "cofix" -> TacCofix None
+      | "cofix"; id = base_ident -> TacCofix (Some id)
+      | "cofix"; id = base_ident; "with"; fd = LIST1 fixdecl ->
+	  TacMutualCofix (id,List.map mk_cofix_tac fd)
+
+      | IDENT "cut"; c = constr -> TacCut c
+      | IDENT "assert"; id = lpar_id_colon; t = lconstr; ")" ->
+          TacTrueCut (Names.Name id,t)
+      | IDENT "assert"; id = lpar_id_coloneq; b = lconstr; ")" ->
+          TacForward (false,Names.Name id,b)
+      | IDENT "assert"; c = constr -> TacTrueCut (Names.Anonymous,c)
+      | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" ->
+	  TacForward (true,Names.Name id,b)
+      | IDENT "pose"; b = constr -> TacForward (true,Names.Anonymous,b)
+      | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc
+      | IDENT "generalize"; IDENT "dependent"; c = constr ->
+          TacGeneralizeDep c
+      | IDENT "set"; id = lpar_id_coloneq; c = lconstr; ")";
+          p = clause -> TacLetTac (Names.Name id,c,p)
+      | IDENT "set"; c = constr; p = clause ->
+          TacLetTac (Names.Anonymous,c,p)
+      | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")";
+	  cls = clause ->
+            TacInstantiate (n,c,cls)
+	    
+      | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings ->
+	  TacSpecialize (n,lcb)
+      | IDENT "lapply"; c = constr -> TacLApply c
+
+      (* Derived basic tactics *)
+      | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
+          TacSimpleInduction (h,ref [])
+      | IDENT "induction"; c = induction_arg; ids = with_names; 
+	  el = OPT eliminator -> TacNewInduction (c,el,(ids,ref []))
+      | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
+	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
+      | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis ->
+          TacSimpleDestruct h
+      | IDENT "destruct"; c = induction_arg; ids = with_names; 
+	  el = OPT eliminator -> TacNewDestruct (c,el,(ids,ref []))
+      | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c
+      | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c
+      | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr
+        -> TacDecompose (l,c)
+
+      (* Automation tactic *)
+      | IDENT "trivial"; db = hintbases -> TacTrivial db
+      | IDENT "auto"; n = OPT natural; db = hintbases -> TacAuto (n, db)
+
+(* Obsolete since V8.0
+      | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n
+      | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id)
+      | IDENT "dhyp";  id = identref -> TacDestructHyp (false,id)
+      | IDENT "dconcl"  -> TacDestructConcl
+      | IDENT "superauto"; l = autoargs -> TacSuperAuto l
+*)
+      | IDENT "auto"; n = OPT natural; IDENT "decomp"; p = OPT natural ->
+	  TacDAuto (n, p)
+
+      (* Context management *)
+      | IDENT "clear"; l = LIST1 id_or_meta -> TacClear l
+      | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l
+      | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> 
+	  TacMove (true,id1,id2)
+      | IDENT "rename"; id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> 
+	  TacRename (id1,id2)
+
+      (* Constructors *)
+      | IDENT "left"; bl = with_bindings -> TacLeft bl
+      | IDENT "right"; bl = with_bindings -> TacRight bl
+      | IDENT "split"; bl = with_bindings -> TacSplit (false,bl)
+      | "exists"; bl = bindings -> TacSplit (true,bl)
+      | "exists" -> TacSplit (true,NoBindings)
+      | IDENT "constructor"; n = num_or_meta; l = with_bindings ->
+	  TacConstructor (n,l)
+      | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t
+
+      (* Equivalence relations *)
+      | IDENT "reflexivity" -> TacReflexivity
+      | IDENT "symmetry"; cls = clause -> TacSymmetry cls
+      | IDENT "transitivity"; c = constr -> TacTransitivity c
+
+      (* Equality and inversion *)
+      | IDENT "dependent"; k =
+	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
+	  | IDENT "inversion" -> FullInversion
+	  | IDENT "inversion_clear" -> FullInversionClear ];
+	  hyp = quantified_hypothesis; 
+	  ids = with_names; co = OPT ["with"; c = constr -> c] ->
+	    TacInversion (DepInversion (k,co,ids),hyp)
+      | IDENT "simple"; IDENT "inversion";
+	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
+	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
+      | IDENT "inversion"; 
+	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
+	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
+      | IDENT "inversion_clear"; 
+	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
+	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
+      | IDENT "inversion"; hyp = quantified_hypothesis; 
+	  "using"; c = constr; cl = simple_clause ->
+	    TacInversion (InversionUsing (c,cl), hyp)
+
+      (* Conversion *)
+      | r = red_tactic; cl = clause -> TacReduce (r, cl)
+      (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
+      | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl)
+    ] ]
+  ;
+END;;
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
new file mode 100644
index 00000000..e2eecf55
--- /dev/null
+++ b/parsing/g_vernac.ml4
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  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: g_vernac.ml4,v 1.93.2.2 2004/07/16 20:51:12 herbelin Exp $ *)
+
+open Names
+open Topconstr
+open Vernacexpr
+open Pcoq
+open Pp
+open Tactic
+open Util
+open Constr
+open Vernac_
+open Prim
+open Decl_kinds
+
+open Genarg
+
+let evar_constr loc = CHole loc
+
+let class_rawexpr = G_basevernac.class_rawexpr
+let thm_token = G_proofs.thm_token
+
+(* Rem: do not join the different GEXTEND into one, it breaks native *)
+(* compilation on PowerPC and Sun architectures *)
+
+let filter_com (b,e) =
+  let (b,e) = unloc (b,e) in
+  Pp.comments := List.filter (fun ((b',e'),s) -> b'<b || e'>e) !Pp.comments 
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: vernac gallina_ext;
+  vernac:
+    (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
+    (* "." is still in the stream and discard_to_dot works correctly         *)
+    [ [ g = gallina; "." -> g 
+      | g = gallina_ext; "." -> g
+      | c = command; "." -> c 
+      | c = syntax; "." -> c
+      | n = natural; ":"; tac = Tactic.tactic; "." -> VernacSolve (n,tac,true) 
+      | n = natural; ":"; tac = Tactic.tactic; "!!" -> VernacSolve (n,tac,false)
+      | n = natural; ":"; v = check_command; "." -> v (Some n)
+      | "["; l = vernac_list_tail -> VernacList l
+
+      (* For translation from V7 to V8 *)
+      | IDENT "V7only"; v = vernac ->
+          filter_com loc; VernacV7only v
+      | IDENT "V8only"; v = vernac -> VernacV8only v
+
+(*
+      (* This is for "Grammar vernac" rules *)
+      | id = METAIDENT -> VernacVar (Names.id_of_string id)
+*)
+    ] ]
+  ;
+    
+  check_command:
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = constr ->
+          fun g -> VernacCheckMayEval (Some r, g, c)
+      | IDENT "Check"; c = constr ->
+	  fun g -> VernacCheckMayEval (None, g, c) ] ]
+  ;
+  vernac: FIRST
+    [ [ IDENT "Time"; v = vernac  -> VernacTime v ] ]
+  ;
+  vernac: LAST
+    [ [ tac = Tactic.tactic; "." -> VernacSolve (1,tac,true)
+      | tac = Tactic.tactic; "!!" -> VernacSolve (1,tac,false)
+      | IDENT "Existential"; n = natural; c = constr_body ->
+	  VernacSolveExistential (n,c)
+    ] ]
+  ;
+  constr_body:
+    [ [ ":="; c = constr; ":"; t = constr -> CCast(loc,c,t)
+      | ":"; t = constr; ":="; c = constr -> CCast(loc,c,t)
+      | ":="; c = constr -> c ] ]
+  ;
+  vernac_list_tail:
+    [ [ v = located_vernac; l = vernac_list_tail -> v :: l
+      | "]"; "." -> [] ] ]
+  ;
+  located_vernac:
+    [ [ v = vernac -> loc, v ] ]
+  ;
+END
+
+let test_plurial_form = function
+  | [_,([_],_)] ->
+      Options.if_verbose warning
+      "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
+  | _ -> ()
+
+(* Gallina declarations *)
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: gallina gallina_ext thm_token;
+
+  thm_token:
+    [ [ "Theorem" -> Theorem
+      | IDENT "Lemma" -> Lemma
+      | IDENT "Fact" -> Fact
+      | IDENT "Remark" -> Remark ] ]
+  ;
+  def_token:
+    [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition)
+      | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition)
+      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, SubClass)
+      | IDENT "Local"; IDENT "SubClass"  ->
+	  Class.add_subclass_hook, (Local, SubClass) ] ] 
+  ;
+  assumption_token:
+    [ [ "Hypothesis" -> (Local, Logical)
+      | "Variable" -> (Local, Definitional)
+      | "Axiom" -> (Global, Logical)
+      | "Parameter" -> (Global, Definitional)
+      | IDENT "Conjecture" -> (Global,Conjectural) ] ]
+  ;
+  assumptions_token:
+    [ [ IDENT "Hypotheses" -> (Local, Logical)
+      | IDENT "Variables" -> (Local, Definitional)
+      | IDENT "Parameters" -> (Global, Definitional) ] ]
+  ;
+  of_type_with_opt_coercion:
+    [ [ ":>" -> true
+      | ":"; ">" -> true
+      | ":" -> false ] ]
+  ;
+  params:
+    [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion; 
+        c = constr -> (coe,(idl,c))
+    ] ]
+  ;
+  ne_params_list:
+    [ [ ll = LIST1 params SEP ";" -> ll ] ]
+  ;
+  name_comma_list_tail:
+    [ [ ","; nal = LIST1 name SEP "," -> nal | -> [] ] ]
+  ;
+  ident_comma_list_tail:
+    [ [ ","; nal = LIST1 identref SEP "," -> nal | -> [] ] ]
+  ;
+  decl_notation:
+    [ [ "where"; ntn = STRING; ":="; c = constr; 
+         scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ]
+  ;
+  type_option:
+    [ [ ":"; c = constr -> c 
+      | -> evar_constr loc ] ]
+  ;
+  opt_casted_constr:
+    [ [ c = constr;  ":"; t = constr -> CCast(loc,c,t)
+      | c = constr -> c ] ]
+  ;
+  vardecls:
+    [ [ na = name; nal = name_comma_list_tail; c = type_option
+          -> LocalRawAssum (na::nal,c)
+      | na = name; "="; c = opt_casted_constr ->
+          LocalRawDef (na,c)
+      | na = name; ":="; c = opt_casted_constr ->
+          LocalRawDef (na,c)
+    ] ]
+  ;
+  binders:
+    [ [ "["; bl = LIST1 vardecls SEP ";"; "]" -> bl ] ]
+  ;
+  binders_list:
+    [ [ bls = LIST0 binders -> List.flatten bls ] ]
+  ;
+  reduce:
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
+      | -> None ] ]
+  ;
+  def_body:
+    [ [ bl = binders_list; ":="; red = reduce; c = constr; ":"; t = constr ->
+          DefineBody (bl, red, c, Some t)
+      | bl = binders_list; ":"; t = constr; ":="; red = reduce; c = constr ->
+          DefineBody (bl, red, c, Some t)
+      | bl = binders_list; ":="; red = reduce; c = constr ->
+          DefineBody (bl, red, c, None)
+      | bl = binders_list; ":"; t = constr ->
+          ProveBody (bl, t) ] ]
+  ;
+  gallina:
+    (* Definition, Theorem, Variable, Axiom, ... *)
+    [ [ thm = thm_token; id = identref; ":"; c = constr ->
+         VernacStartTheoremProof (thm, id, ([], c), false, (fun _ _ -> ()))
+      | (f,d) = def_token; id = identref; b = def_body -> 
+          VernacDefinition (d, id, b, f)
+      | stre = assumption_token; bl = ne_params_list -> 
+	  VernacAssumption (stre, bl)
+      | stre = assumptions_token; bl = ne_params_list ->
+	  test_plurial_form bl;
+	  VernacAssumption (stre, bl)
+      ] ]
+  ;
+  (* Gallina inductive declarations *)
+  finite_token:
+    [ [ "Inductive" -> true
+      | "CoInductive" -> false ] ]
+  ;
+  record_token:
+    [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ]
+  ;
+  constructor:
+    [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion;
+        c = constr -> List.map (fun id -> (coe,(id,c))) idl ] ]
+  ;
+  constructor_list:
+    [ [ "|"; l = LIST1 constructor SEP "|" -> List.flatten l
+      | l = LIST1 constructor SEP "|" -> List.flatten l
+      |  -> [] ] ]
+  ;
+  block_old_style:
+    [ [ ind = oneind_old_style; "with"; indl = block_old_style -> ind :: indl
+      | ind = oneind_old_style -> [ind] ] ]
+  ;
+  oneind_old_style:
+    [ [ id = identref; ":"; c = constr; ":="; lc = constructor_list ->
+          (id,c,lc) ] ]
+  ;
+  oneind:
+    [ [ id = identref; indpar = simple_binders_list; ":"; c = constr; 
+        ":="; lc = constructor_list; ntn = OPT decl_notation ->
+	  (id,ntn,indpar,c,lc) ] ]
+  ;
+  simple_binders_list:
+    [ [ bl = ne_simple_binders_list -> bl
+      |  -> [] ] ]
+  ;
+  opt_coercion:
+    [ [ ">" -> true
+      |  -> false ] ]
+  ;
+  onescheme:
+    [ [ id = identref; ":="; dep = dep; ind = global; IDENT "Sort";
+        s = sort -> (id,dep,ind,s) ] ]
+  ;
+  schemes:
+    [ [ recl = LIST1 onescheme SEP "with" -> recl ] ]
+  ;
+  dep:
+    [ [ IDENT "Induction"; IDENT "for" -> true
+      | IDENT "Minimality"; IDENT "for" -> false ] ]
+  ;
+  onerec:
+    [ [ id = base_ident; bl = ne_fix_binders; ":"; type_ = constr;
+        ":="; def = constr; ntn = OPT decl_notation ->
+          let ni = List.length (List.flatten (List.map fst bl)) - 1 in
+          let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in
+	  ((id, ni, bl, type_, def), ntn) ] ]
+  ;
+  specifrec:
+    [ [ l = LIST1 onerec SEP "with" -> l ] ]
+  ;
+  onecorec:
+    [ [ id = base_ident; ":"; c = constr; ":="; def = constr ->
+          (id,[],c,def) ] ]
+  ;
+  specifcorec:
+    [ [ l = LIST1 onecorec SEP "with" -> l ] ]
+  ;
+  record_field:
+    [ [ id = name; oc = of_type_with_opt_coercion; t = constr ->
+          (oc,AssumExpr (id,t))
+      | id = name; oc = of_type_with_opt_coercion; t = constr;
+	":="; b = constr ->
+	  (oc,DefExpr (id,b,Some t))
+      | id = name; ":="; b = constr ->
+	  (false,DefExpr (id,b,None)) ] ]
+  ;
+  fields:
+    [ [ fs = LIST0 record_field SEP ";" -> fs ] ]
+  ;
+  simple_binders:
+    [ [ "["; bll = LIST1 vardecls SEP ";"; "]" -> bll ] ]
+  ;
+  ne_simple_binders_list:
+    [ [ bll = LIST1 simple_binders -> (List.flatten bll) ] ]
+  ;
+  fix_params:
+    [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c)
+      | idl = LIST1 name SEP "," -> (idl, evar_constr dummy_loc)
+    ] ]
+  ;
+  fix_binders:
+    [ [ "["; bll = LIST1 fix_params SEP ";"; "]" -> bll ] ]
+  ;
+  ne_fix_binders:
+    [ [ bll = LIST1 fix_binders -> List.flatten bll ] ]
+  ;
+  rec_constructor:
+    [ [ c = identref -> Some c
+      |  -> None ] ]
+  ;
+  gallina_ext:
+    [ [ IDENT "Mutual"; bl = ne_simple_binders_list ; f = finite_token;
+        indl = block_old_style ->
+	  let indl' = List.map (fun (id,ar,c) -> (id,None,bl,ar,c)) indl in
+	  VernacInductive (f,indl')
+      | b = record_token; oc = opt_coercion; name = identref;
+	ps = simple_binders_list; ":";
+	s = constr; ":="; c = rec_constructor; "{"; fs = fields; "}" ->
+	  VernacRecord (b,(oc,name),ps,s,c,fs)
+    ] ]
+  ;
+  gallina:
+    [ [ IDENT "Mutual"; f = finite_token; indl = LIST1 oneind SEP "with" ->
+          VernacInductive (f,indl)
+      | f = finite_token; indl = LIST1 oneind SEP "with" ->
+          VernacInductive (f,indl)
+      | "Fixpoint"; recs = specifrec -> VernacFixpoint recs
+      | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint corecs
+      | IDENT "Scheme"; l = schemes -> VernacScheme l
+      | f = finite_token; s = csort; id = identref;
+	indpar = simple_binders_list; ":="; lc = constructor_list -> 
+          VernacInductive (f,[id,None,indpar,s,lc]) ] ]
+  ;
+  csort:
+    [ [ s = sort -> CSort (loc,s) ] ]
+  ;
+  gallina_ext:
+    [ [ 
+(* Sections *)
+	IDENT "Section"; id = identref -> VernacBeginSection id
+      | IDENT "Chapter"; id = identref -> VernacBeginSection id ] ]
+  ;
+  module_vardecls:
+    [ [ id = identref; idl = ident_comma_list_tail; ":";
+        mty = Module.module_type -> (id::idl,mty) ] ]
+  ;
+  module_binders:
+    [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ]
+  ;
+  module_binders_list:
+    [ [ bls = LIST0 module_binders -> List.flatten bls ] ]
+  ;
+  of_module_type:
+    [ [ ":"; mty = Module.module_type -> (mty, true) 
+      | "<:"; mty = Module.module_type -> (mty, false) ] ]
+  ;
+  is_module_type:
+    [ [ ":="; mty = Module.module_type -> mty ] ]
+  ;
+  is_module_expr:
+    [ [ ":="; mexpr = Module.module_expr -> mexpr ] ]
+  ;
+  gallina_ext:
+    [ [ 
+	  (* Interactive module declaration *)
+	IDENT "Module"; id = identref; 
+	bl = module_binders_list; mty_o = OPT of_module_type; 
+	mexpr_o = OPT is_module_expr ->
+	  VernacDefineModule (id, bl, mty_o, mexpr_o)
+	  
+      | IDENT "Module"; "Type"; id = identref; 
+	bl = module_binders_list; mty_o = OPT is_module_type ->
+	  VernacDeclareModuleType (id, bl, mty_o)
+	  
+      | IDENT "Declare"; IDENT "Module"; id = identref; 
+	bl = module_binders_list; mty_o = OPT of_module_type; 
+	mexpr_o = OPT is_module_expr ->
+	  VernacDeclareModule (id, bl, mty_o, mexpr_o)
+
+	  (* This end a Section a Module or a Module Type *)
+
+      | IDENT "End"; id = identref -> VernacEndSegment id
+
+
+(* Transparent and Opaque *)
+      | IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
+      | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l)
+
+(* Canonical structure *)
+      | IDENT "Canonical"; IDENT "Structure"; qid = global ->
+	  VernacCanonical qid
+      | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body ->
+          let s = Ast.coerce_global_to_id qid in
+	  VernacDefinition 
+	    ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook)
+      (* Rem: LOBJECT, OBJCOERCION, LOBJCOERCION have been removed
+         (they were unused and undocumented) *)
+
+(* Coercions *)
+      | IDENT "Coercion"; qid = global; d = def_body ->
+          let s = Ast.coerce_global_to_id qid in
+	  VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+      | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
+           let s = Ast.coerce_global_to_id qid in
+	  VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+      | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref;
+         ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> 
+	   VernacIdentityCoercion (Local, f, s, t)
+      | IDENT "Identity"; IDENT "Coercion"; f = identref; ":";
+         s = class_rawexpr; ">->"; t = class_rawexpr -> 
+	   VernacIdentityCoercion (Global, f, s, t)
+      | IDENT "Coercion"; IDENT "Local"; qid = global; ":";
+	 s = class_rawexpr; ">->"; t = class_rawexpr -> 
+	  VernacCoercion (Local, qid, s, t)
+      | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
+         t = class_rawexpr ->
+	  VernacCoercion (Global, qid, s, t)
+      | IDENT "Class"; IDENT "Local"; c = global ->
+	  Pp.warning "Class is obsolete"; VernacNop
+      | IDENT "Class"; c = global ->
+	  Pp.warning "Class is obsolete"; VernacNop
+
+(* Implicit *)
+(*
+      | IDENT "Syntactic"; "Definition"; id = identref; ":="; c = constr;
+         n = OPT [ "|"; n = natural -> n ] ->
+	   VernacSyntacticDefinition (id,c,n)
+*)
+      | IDENT "Syntactic"; "Definition"; id = ident; ":="; c = constr;
+         n = OPT [ "|"; n = natural -> n ] ->
+	   let c = match n with
+	     | Some n ->
+		 let l = list_tabulate (fun _ -> (CHole (loc),None)) n in
+		 CApp (loc,(None,c),l)
+	     | None -> c in
+	   VernacSyntacticDefinition (id,c,false,true)
+      | IDENT "Implicits"; qid = global; "["; l = LIST0 natural; "]" ->
+	  let l = List.map (fun n -> ExplByPos n) l in
+	  VernacDeclareImplicits (qid,Some l)
+      | IDENT "Implicits"; qid = global -> VernacDeclareImplicits (qid,None)
+
+      | IDENT "Implicit"; ["Variable"; "Type" | IDENT "Variables"; "Type"];
+	   idl = LIST1 identref SEP ","; ":"; c = constr -> VernacReserve (idl,c)
+
+      (* For compatibility *)
+      | IDENT "Implicit"; IDENT "Arguments"; IDENT "On" ->
+	  VernacSetOption
+	    (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue true)
+      | IDENT "Implicit"; IDENT "Arguments"; IDENT "Off" ->
+	  VernacSetOption
+	    (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue false)
+  ] ]
+  ;
+END
+
+(* Modules management *)   
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command;
+
+  export_token:
+    [ [ IDENT "Import" -> false
+      | IDENT "Export" -> true
+      |  -> false ] ]
+  ;
+  specif_token:
+    [ [ IDENT "Implementation" -> Some false
+      | IDENT "Specification" -> Some true
+      |  -> None ] ]
+  ;
+  command:
+    [ [ "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ];
+	s = [ s = STRING -> s | s = IDENT -> s ] ->
+	  VernacLoad (verbosely, s)
+(*      | "Compile";
+	verbosely =
+          [ IDENT "Verbose" -> "Verbose"
+          | -> "" ];
+	IDENT "Module";
+	only_spec =
+          [ IDENT "Specification" -> "Specification"
+          | -> "" ];
+	mname = [ s = STRING -> s | s = IDENT -> s ];
+	fname = OPT [ s = STRING -> s | s = IDENT -> s ] -> ExtraVernac
+          let fname = match fname with Some s -> s | None -> mname in
+            <:ast< (CompileFile ($STR $verbosely) ($STR $only_spec)
+                      ($STR $mname) ($STR $fname))>>
+*)
+      | IDENT "Read"; IDENT "Module"; qidl = LIST1 global ->
+	  VernacRequire (None, None, qidl)
+      | IDENT "Require"; export = export_token; specif = specif_token;
+        qidl = LIST1 global -> VernacRequire (Some export, specif, qidl)
+(*      | IDENT "Require"; export = export_token; specif = specif_token;
+        id = identref; filename = STRING -> 
+	  VernacRequireFrom (export, specif, id, filename) *)
+      | IDENT "Require"; export = export_token; specif = specif_token;
+        filename = STRING -> 
+	  VernacRequireFrom (Some export, specif, filename)
+      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 STRING ->
+	  VernacDeclareMLModule l
+      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
+      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl)
+  ] 
+]
+  ;
+END
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command;
+
+  command:
+    [ [ 
+
+(* State management *)
+        IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
+      | IDENT "Write"; IDENT "State"; s = STRING -> VernacWriteState s
+      | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s
+      | IDENT "Restore"; IDENT "State"; s = STRING -> VernacRestoreState s
+
+(* Resetting *)
+      | IDENT "Reset"; id = identref -> VernacResetName id
+      | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial
+      | IDENT "Back" -> VernacBack 1
+      | IDENT "Back"; n = natural -> VernacBack n
+
+(* Tactic Debugger *)
+      |	IDENT "Debug"; IDENT "On" -> VernacDebug true
+      |	IDENT "Debug"; IDENT "Off" -> VernacDebug false
+
+ ] ];
+    END
+;;
diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4
new file mode 100644
index 00000000..8a99a51e
--- /dev/null
+++ b/parsing/g_vernacnew.ml4
@@ -0,0 +1,729 @@
+(************************************************************************)
+(*  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: g_vernacnew.ml4,v 1.63.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Coqast
+open Topconstr
+open Vernacexpr
+open Pcoq
+open Tactic
+open Decl_kinds
+open Genarg
+open Extend
+open Ppextend
+open Goptions
+
+open Prim
+open Constr
+open Vernac_
+open Module
+
+
+let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
+let _ = 
+  if not !Options.v7 then
+    List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw
+
+(* Rem: do not join the different GEXTEND into one, it breaks native *)
+(* compilation on PowerPC and Sun architectures *)
+
+let check_command = Gram.Entry.create "vernac:check_command"
+let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr"
+let thm_token = Gram.Entry.create "vernac:thm_token"
+let def_body = Gram.Entry.create "vernac:def_body"
+
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: vernac gallina_ext;
+  vernac:
+    (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
+    (* "." is still in the stream and discard_to_dot works correctly         *)
+    [ [ g = gallina; "." -> g 
+      | g = gallina_ext; "." -> g
+      | c = command; "." -> c 
+      | c = syntax; "." -> c
+      | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
+    ] ]
+  ;
+  vernac: FIRST
+    [ [ IDENT "Time"; v = vernac  -> VernacTime v ] ]
+  ;
+  vernac: LAST
+    [ [ gln = OPT[n=natural; ":" -> n];
+        tac = subgoal_command -> tac gln ] ]
+  ;
+  subgoal_command:
+    [ [ c = check_command; "." -> c
+      | tac = Tactic.tactic;
+        use_dft_tac = [ "." -> false | "..." -> true ] ->
+          (fun g ->
+            let g = match g with Some gl -> gl | _ -> 1 in
+            VernacSolve(g,tac,use_dft_tac)) ] ]
+  ;
+  located_vernac:
+    [ [ v = vernac -> loc, v ] ]
+  ;
+END
+
+
+let test_plurial_form = function
+  | [(_,([_],_))] ->
+      Options.if_verbose warning
+   "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
+  | _ -> ()
+
+let no_coercion loc (c,x) =
+  if c then Util.user_err_loc
+    (loc,"no_coercion",Pp.str"no coercion allowed here");
+  x
+
+(* Gallina declarations *)
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: gallina gallina_ext thm_token def_body;
+
+  gallina:
+      (* Definition, Theorem, Variable, Axiom, ... *)
+    [ [ thm = thm_token; id = identref; (* bl = LIST0 binder; *) ":";
+        c = lconstr ->
+          let bl = [] in
+          VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ()))
+      | (f,d) = def_token; id = identref; b = def_body -> 
+          VernacDefinition (d, id, b, f)
+      | stre = assumption_token; bl = assum_list -> 
+	  VernacAssumption (stre, bl)
+      | stre = assumptions_token; bl = assum_list ->
+	  test_plurial_form bl;
+	  VernacAssumption (stre, bl)
+      (* Gallina inductive declarations *)
+      | f = finite_token;
+        indl = LIST1 inductive_definition SEP "with" ->
+          VernacInductive (f,indl)
+      | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint recs
+      | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
+          VernacCoFixpoint corecs
+      | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ]
+  ;
+  gallina_ext:
+    [ [ b = record_token; oc = opt_coercion; name = identref;
+        ps = LIST0 binder_let; ":";
+	s = lconstr; ":="; cstr = OPT identref; "{";
+        fs = LIST0 record_field SEP ";"; "}" ->
+	  VernacRecord (b,(oc,name),ps,s,cstr,fs)
+(* Non port�é ?
+      | f = finite_token; s = csort; id = identref;
+        indpar = LIST0 simple_binder; ":="; lc = constructor_list -> 
+          VernacInductive (f,[id,None,indpar,s,lc])
+*)
+    ] ]
+  ;
+  thm_token:
+    [ [ "Theorem" -> Theorem
+      | IDENT "Lemma" -> Lemma
+      | IDENT "Fact" -> Fact
+      | IDENT "Remark" -> Remark ] ]
+  ;
+  def_token:
+    [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition)
+      | IDENT "Let" -> (fun _ _ -> ()), (Local, Definition)
+      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, SubClass)
+      | IDENT "Local"; IDENT "SubClass"  ->
+          Class.add_subclass_hook, (Local, SubClass) ] ] 
+  ;
+  assumption_token:
+    [ [ "Hypothesis" -> (Local, Logical)
+      | "Variable" -> (Local, Definitional)
+      | "Axiom" -> (Global, Logical)
+      | "Parameter" -> (Global, Definitional)
+      | IDENT "Conjecture" -> (Global, Conjectural) ] ]
+  ;
+  assumptions_token:
+    [ [ IDENT "Hypotheses" -> (Local, Logical)
+      | IDENT "Variables" -> (Local, Definitional)
+      | IDENT "Axioms" -> (Global, Logical)
+      | IDENT "Parameters" -> (Global, Definitional) ] ]
+  ;
+  finite_token:
+    [ [ "Inductive" -> true
+      | "CoInductive" -> false ] ]
+  ;
+  record_token:
+    [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ]
+  ;
+  (* Simple definitions *)
+  def_body:
+    [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr ->
+      (match c with
+          CCast(_,c,t) -> DefineBody (bl, red, c, Some t)
+        | _ -> DefineBody (bl, red, c, None))
+      | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
+          DefineBody (bl, red, c, Some t)
+      | bl = LIST0 binder_let; ":"; t = lconstr ->
+          ProveBody (bl, t) ] ]
+  ;
+  reduce:
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
+      | -> None ] ]
+  ;
+  decl_notation:
+    [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; 
+         scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ]
+    ;
+  (* Inductives and records *)
+  inductive_definition:
+    [ [ id = identref; indpar = LIST0 binder_let; ":"; c = lconstr; 
+        ":="; lc = constructor_list; ntn = decl_notation ->
+	  (id,ntn,indpar,c,lc) ] ]
+  ;
+  constructor_list:
+    [ [ "|"; l = LIST1 constructor SEP "|" -> l
+      | l = LIST1 constructor SEP "|" -> l
+      |  -> [] ] ]
+  ;
+(*
+  csort:
+    [ [ s = sort -> CSort (loc,s) ] ]
+  ;
+*)
+  opt_coercion:
+    [ [ ">" -> true
+      |  -> false ] ]
+  ;
+  (* (co)-fixpoints *)
+  rec_definition:
+    [ [ id = base_ident; bl = LIST1 binder_let;
+        annot = OPT rec_annotation; type_ = type_cstr; 
+	":="; def = lconstr; ntn = decl_notation ->
+          let names = List.map snd (names_of_local_assums bl) in
+          let ni =
+            match annot with
+                Some id ->
+                  (try list_index (Name id) names - 1
+                  with Not_found ->  Util.user_err_loc
+                      (loc,"Fixpoint",
+                       Pp.str "No argument named " ++ Nameops.pr_id id))
+              | None -> 
+                  if List.length names > 1 then
+                    Util.user_err_loc
+                      (loc,"Fixpoint",
+                       Pp.str "the recursive argument needs to be specified");
+                  0 in
+	  ((id, ni, bl, type_, def),ntn) ] ]
+  ;
+  corec_definition:
+    [ [ id = base_ident; bl = LIST0 binder_let; c = type_cstr; ":=";
+        def = lconstr ->
+          (id,bl,c ,def) ] ]
+  ;
+  rec_annotation:
+    [ [ "{"; IDENT "struct"; id=IDENT; "}" -> id_of_string id ] ]
+  ;
+  type_cstr:
+    [ [ ":"; c=lconstr -> c 
+      | -> CHole loc ] ]
+  ;
+  (* Inductive schemes *)
+  scheme:
+    [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global;
+        IDENT "Sort"; s = sort ->
+          (id,dep,ind,s) ] ]
+  ;
+  dep_scheme:
+    [ [ IDENT "Induction" -> true
+      | IDENT "Minimality" -> false ] ]
+  ;
+  (* Various Binders *)
+(*
+  (* ... without coercions *)
+  binder_nodef:
+    [ [ b = binder_let ->
+      (match b with
+          LocalRawAssum(l,ty) -> (l,ty)
+        | LocalRawDef _ ->
+            Util.user_err_loc
+              (loc,"fix_param",Pp.str"defined binder not allowed here")) ] ]
+  ;
+*)
+  (* ... with coercions *)
+  record_field:
+    [ [ id = name -> (false,AssumExpr(id,CHole loc))
+      | id = name; oc = of_type_with_opt_coercion; t = lconstr ->
+         (oc,AssumExpr (id,t))
+      | id = name; oc = of_type_with_opt_coercion;
+             t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t))
+      | id = name; ":="; b = lconstr ->
+         match b with
+             CCast(_,b,t) -> (false,DefExpr(id,b,Some t))
+           | _ -> (false,DefExpr(id,b,None)) ] ]
+  ;
+  assum_list:
+    [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ]
+  ;
+  assum_coe:
+    [ [ "("; a = simple_assum_coe; ")" -> a ] ]
+  ;
+  simple_assum_coe:
+    [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> 
+        (oc,(idl,c)) ] ]
+  ;
+  constructor:
+    [ [ id = identref; l = LIST0 binder_let; 
+        coe = of_type_with_opt_coercion; c = lconstr ->
+	  (coe,(id,G_constrnew.mkCProdN loc l c))
+      | id = identref; l = LIST0 binder_let ->
+	  (false,(id,G_constrnew.mkCProdN loc l (CHole loc))) ] ]
+  ;
+  of_type_with_opt_coercion:
+    [ [ ":>" -> true
+      | ":"; ">" -> true
+      | ":" -> false ] ]
+  ;
+END
+
+
+(* Modules and Sections *)
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: gallina_ext module_expr module_type;
+
+  gallina_ext:
+    [ [ (* Interactive module declaration *)
+	IDENT "Module"; id = identref; 
+	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
+	mexpr_o = OPT is_module_expr ->
+	  VernacDefineModule (id, bl, mty_o, mexpr_o)
+	  
+      | IDENT "Module"; "Type"; id = identref; 
+	bl = LIST0 module_binder; mty_o = OPT is_module_type ->
+	  VernacDeclareModuleType (id, bl, mty_o)
+	  
+      | IDENT "Declare"; IDENT "Module"; id = identref; 
+	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
+	mexpr_o = OPT is_module_expr ->
+	  VernacDeclareModule (id, bl, mty_o, mexpr_o)
+      (* Section beginning *)
+      | IDENT "Section"; id = identref -> VernacBeginSection id
+      | IDENT "Chapter"; id = identref -> VernacBeginSection id
+
+      (* This end a Section a Module or a Module Type *)
+      | IDENT "End"; id = identref -> VernacEndSegment id
+
+      (* Requiring an already compiled module *)
+      | IDENT "Require"; export = export_token; specif = specif_token;
+        qidl = LIST1 global ->
+          VernacRequire (export, specif, qidl)
+      | IDENT "Require"; export = export_token; specif = specif_token;
+        filename = ne_string -> 
+	  VernacRequireFrom (export, specif, filename)
+      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
+      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ]
+  ;
+  export_token:
+    [ [ IDENT "Import" -> Some false
+      | IDENT "Export" -> Some true
+      |  -> None ] ]
+  ;
+  specif_token:
+    [ [ IDENT "Implementation" -> Some false
+      | IDENT "Specification" -> Some true
+      |  -> None ] ]
+  ;
+  of_module_type:
+    [ [ ":"; mty = module_type -> (mty, true) 
+      | "<:"; mty = module_type -> (mty, false) ] ]
+  ;
+  is_module_type:
+    [ [ ":="; mty = module_type -> mty ] ]
+  ;
+  is_module_expr:
+    [ [ ":="; mexpr = module_expr -> mexpr ] ]
+  ;
+
+  (* Module binder  *)
+  module_binder:
+    [ [ "("; idl = LIST1 identref; ":"; mty = module_type; ")" ->
+          (idl,mty) ] ]
+  ;
+
+  (* Module expressions *)
+  module_expr:
+    [ [ qid = qualid -> CMEident qid
+      | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2)
+      | "("; me = module_expr; ")" -> me
+(* ... *)
+      ] ]
+  ;
+  with_declaration:
+    [ [ "Definition"; id = identref; ":="; c = Constr.lconstr ->
+          CWith_Definition (id,c)
+      | IDENT "Module"; id = identref; ":="; qid = qualid ->
+	  CWith_Module (id,qid)
+      ] ]
+  ;
+  module_type:
+    [ [ qid = qualid -> CMTEident qid
+(* ... *)
+      | mty = module_type; "with"; decl = with_declaration -> 
+	  CMTEwith (mty,decl) ] ]
+  ;
+END
+
+(* Extensions: implicits, coercions, etc. *)   
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: gallina_ext;
+
+  gallina_ext:
+    [ [ (* Transparent and Opaque *)
+        IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
+      | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l)
+
+      (* Canonical structure *)
+      | IDENT "Canonical"; IDENT "Structure"; qid = global ->
+	  VernacCanonical qid
+      | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body ->
+          let s = Ast.coerce_global_to_id qid in
+	  VernacDefinition 
+	    ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook)
+
+      (* Coercions *)
+      | IDENT "Coercion"; qid = global; d = def_body ->
+          let s = Ast.coerce_global_to_id qid in
+	  VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+      | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
+           let s = Ast.coerce_global_to_id qid in
+	  VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+      | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref;
+         ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> 
+	   VernacIdentityCoercion (Local, f, s, t)
+      | IDENT "Identity"; IDENT "Coercion"; f = identref; ":";
+         s = class_rawexpr; ">->"; t = class_rawexpr -> 
+	   VernacIdentityCoercion (Global, f, s, t)
+      | IDENT "Coercion"; IDENT "Local"; qid = global; ":";
+	 s = class_rawexpr; ">->"; t = class_rawexpr -> 
+	  VernacCoercion (Local, qid, s, t)
+      | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
+         t = class_rawexpr ->
+	  VernacCoercion (Global, qid, s, t)
+
+      (* Implicit *)
+      | IDENT "Implicit"; IDENT "Arguments"; qid = global; 
+         pos = OPT [ "["; l = LIST0 ident; "]" -> l ] ->
+	   let pos = option_app (List.map (fun id -> ExplByName id)) pos in
+	   VernacDeclareImplicits (qid,pos)
+
+      | IDENT "Implicit"; ["Type" | IDENT "Types"];
+	   idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ]
+  ;
+END
+
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command check_command class_rawexpr;
+
+  command:
+    [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l
+
+      (* System directory *)
+      | IDENT "Pwd" -> VernacChdir None
+      | IDENT "Cd" -> VernacChdir None
+      | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir)
+
+      (* Toplevel control *)
+      | IDENT "Drop" -> VernacToplevelControl Drop
+      | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop
+      | IDENT "Quit" -> VernacToplevelControl Quit
+
+      | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ];
+	s = [ s = ne_string -> s | s = IDENT -> s ] ->
+	  VernacLoad (verbosely, s)
+      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
+	  VernacDeclareMLModule l
+
+      (* Dump of the universe graph - to file or to stdout *) 
+      | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string ->
+	  VernacPrint (PrintUniverses fopt)
+
+      | IDENT "Locate"; l = locatable -> VernacLocate l
+
+      (* Managing load paths *)
+      | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath ->
+	  VernacAddLoadPath (false, dir, alias)
+      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; 
+	  alias = as_dirpath -> VernacAddLoadPath (true, dir, alias)
+      | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string ->
+	  VernacRemoveLoadPath dir
+
+       (* For compatibility *)
+      | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath ->
+	  VernacAddLoadPath (false, dir, alias)
+      | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath ->
+	  VernacAddLoadPath (true, dir, alias)
+      | IDENT "DelPath"; dir = ne_string ->
+	  VernacRemoveLoadPath dir
+
+      (* Type-Checking (pas dans le refman) *)
+      | "Type"; c = lconstr -> VernacGlobalCheck c
+
+      (* Printing (careful factorization of entries) *)
+      | IDENT "Print"; p = printable -> VernacPrint p
+      | IDENT "Print"; qid = global -> VernacPrint (PrintName qid)
+      | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> 
+	  VernacPrint (PrintModuleType qid)
+      | IDENT "Print"; IDENT "Module"; qid = global -> 
+	  VernacPrint (PrintModule qid)
+      | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
+      | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid)
+
+      (* Searching the environment *)
+      | IDENT "Search"; qid = global; l = in_or_out_modules -> 
+	  VernacSearch (SearchHead qid, l)
+      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchPattern c, l)
+      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchRewrite c, l)
+      | IDENT "SearchAbout"; 
+	  sl = [ "["; l = LIST1 [ r = global -> SearchRef r
+                                | s = ne_string -> SearchString s ]; "]" -> l 
+   		 | qid = global -> [SearchRef qid] ];
+	  l = in_or_out_modules -> 
+	  VernacSearch (SearchAbout sl, l)
+
+      | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
+	  VernacAddMLPath (false, dir)
+      | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
+	  VernacAddMLPath (true, dir)
+
+      (* Pour intervenir sur les tables de param�ètres *)
+      | "Set"; table = IDENT; field = IDENT; v = option_value ->
+  	  VernacSetOption (SecondaryTable (table,field),v)
+      | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
+  	  VernacAddOption (SecondaryTable (table,field),lv)
+      | "Set"; table = IDENT; field = IDENT ->
+  	  VernacSetOption (SecondaryTable (table,field),BoolValue true)
+      | IDENT "Unset"; table = IDENT; field = IDENT ->
+  	  VernacUnsetOption (SecondaryTable (table,field))
+      | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
+  	  VernacRemoveOption (SecondaryTable (table,field),lv)
+      | "Set"; table = IDENT; value = option_value ->
+  	  VernacSetOption (PrimaryTable table, value)
+      | "Set"; table = IDENT ->
+  	  VernacSetOption (PrimaryTable table, BoolValue true)
+      | IDENT "Unset"; table = IDENT ->
+  	  VernacUnsetOption (PrimaryTable table)
+
+      | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT ->
+	  VernacPrintOption (SecondaryTable (table,field))
+      | IDENT "Print"; IDENT "Table"; table = IDENT ->
+	  VernacPrintOption (PrimaryTable table)
+
+      | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> VernacAddOption (SecondaryTable (table,field), v)
+
+      (* Un value global ci-dessous va �être cach�é par un field au dessus! *)
+      | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
+          VernacAddOption (PrimaryTable table, v)
+
+      | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> VernacMemOption (SecondaryTable (table,field), v)
+      | IDENT "Test"; table = IDENT; field = IDENT ->
+          VernacPrintOption (SecondaryTable (table,field))
+      | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value ->
+          VernacMemOption (PrimaryTable table, v)
+      | IDENT "Test"; table = IDENT ->
+          VernacPrintOption (PrimaryTable table)
+
+      | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
+        -> VernacRemoveOption (SecondaryTable (table,field), v)
+      | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
+	  VernacRemoveOption (PrimaryTable table, v) ] ]
+  ;
+  check_command: (* TODO: rapprocher Eval et Check *)
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr ->
+          fun g -> VernacCheckMayEval (Some r, g, c)
+      | IDENT "Check"; c = lconstr ->
+	  fun g -> VernacCheckMayEval (None, g, c) ] ]
+  ;
+  printable:
+    [ [ IDENT "Term"; qid = global -> PrintName qid
+      | IDENT "All" -> PrintFullContext
+      | IDENT "Section"; s = global -> PrintSectionContext s
+      | IDENT "Grammar"; ent = IDENT ->
+          (* This should be in "syntax" section but is here for factorization*)
+	  PrintGrammar ("", ent)
+      | IDENT "LoadPath" -> PrintLoadPath
+      | IDENT "Modules" -> PrintModules
+
+      | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
+      | IDENT "ML"; IDENT "Modules" -> PrintMLModules
+      | IDENT "Graph" -> PrintGraph
+      | IDENT "Classes" ->  PrintClasses
+      | IDENT "Coercions" -> PrintCoercions
+      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
+         -> PrintCoercionPaths (s,t)
+      | IDENT "Tables" -> PrintTables
+(* Obsolete: was used for cooking V6.3 recipes ??
+      | IDENT "Proof"; qid = global -> PrintOpaqueName qid
+*)
+      | IDENT "Hint" -> PrintHintGoal
+      | IDENT "Hint"; qid = global -> PrintHint qid
+      | IDENT "Hint"; "*" -> PrintHintDb
+      | IDENT "HintDb"; s = IDENT -> PrintHintDbName s
+      | IDENT "Scopes" -> PrintScopes
+      | IDENT "Scope"; s = IDENT -> PrintScope s
+      | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s
+      | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ]
+  ;
+  class_rawexpr:
+    [ [ IDENT "Funclass" -> FunClass
+      | IDENT "Sortclass" -> SortClass
+      | qid = global -> RefClass qid ] ]
+  ;
+  locatable:
+    [ [ qid = global -> LocateTerm qid
+      | IDENT "File"; f = ne_string -> LocateFile f
+      | IDENT "Library"; qid = global -> LocateLibrary  qid
+      | s = ne_string -> LocateNotation s ] ]
+  ;
+  option_value:
+    [ [ n  = integer   -> IntValue n
+      | s  = STRING    -> StringValue s ] ]
+  ;
+  option_ref_value:
+    [ [ id = global   -> QualidRefValue id
+      | s  = STRING   -> StringRefValue s ] ]
+  ;
+  as_dirpath:
+    [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
+  ;
+  in_or_out_modules:
+    [ [ IDENT "inside"; l = LIST1 global -> SearchInside l
+      | IDENT "outside"; l = LIST1 global -> SearchOutside l
+      | -> SearchOutside [] ] ]
+  ;
+  comment:
+    [ [ c = constr -> CommentConstr c
+      | s = STRING -> CommentString s
+      | n = natural -> CommentInt n ] ]
+  ;
+END;
+
+if not !Options.v7 then
+GEXTEND Gram
+  command:
+    [ [ 
+(* State management *)
+        IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
+      | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s
+      | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s
+      | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s
+
+(* Resetting *)
+      | IDENT "Reset"; id = identref -> VernacResetName id
+      | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial
+      | IDENT "Back" -> VernacBack 1
+      | IDENT "Back"; n = natural -> VernacBack n
+
+(* Tactic Debugger *)
+      |	IDENT "Debug"; IDENT "On" -> VernacDebug true
+      |	IDENT "Debug"; IDENT "Off" -> VernacDebug false
+
+ ] ];
+    END
+;;
+
+(* Grammar extensions *)
+	  
+if not !Options.v7 then
+GEXTEND Gram
+  GLOBAL: syntax;
+
+  syntax:
+   [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> 
+         VernacOpenCloseScope (local,true,sc)
+
+     | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> 
+         VernacOpenCloseScope (local,false,sc)
+
+     | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
+	 VernacDelimiters (sc,key)
+
+     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; 
+       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
+
+     | IDENT "Arguments"; IDENT "Scope"; qid = global;
+         "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl)
+
+     | IDENT "Infix"; local = locality;
+	 op = ne_string; ":="; p = global; 
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
+         VernacInfix (local,(op,modl),p,None,sc)
+     | IDENT "Notation"; local = locality; id = ident; ":="; c = constr;
+	 b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
+           VernacSyntacticDefinition (id,c,local,b)
+     | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
+           VernacNotation (local,c,Some(s,modl),None,sc)
+
+     | IDENT "Tactic"; IDENT "Notation"; s = ne_string; 
+	 pil = LIST0 production_item; ":="; t = Tactic.tactic -> 
+	   VernacTacticGrammar ["",(s,pil),t]
+
+     | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; 
+	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]
+	 -> VernacSyntaxExtension (local,Some(s,l),None)
+
+     (* "Print" "Grammar" should be here but is in "command" entry in order 
+        to factorize with other "Print"-based vernac entries *)
+  ] ]
+  ;
+  locality:
+    [ [ IDENT "Local" -> true | -> false ] ]
+  ;
+  level:
+    [ [ IDENT "level"; n = natural -> NumLevel n
+      | IDENT "next"; IDENT "level" -> NextLevel ] ]
+  ;
+  syntax_modifier:
+    [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
+      | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; 
+        lev = level -> SetItemLevel (x::l,lev)
+      | "at"; IDENT "level"; n = natural -> SetLevel n
+      | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
+      | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA
+      | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA
+      | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ)
+      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
+      | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ]
+  ;
+  syntax_extension_type:
+    [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference
+      | IDENT "bigint" -> ETBigint
+    ] ]
+  ;
+  opt_scope:
+    [ [ "_" -> None | sc = IDENT -> Some sc ] ]
+  ;
+  production_item:
+    [[ s = ne_string -> VTerm s
+     | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] ->
+	 VNonTerm (loc,NtShort nt,po) ]]
+  ;
+END
+
+(* Reinstall tactic and vernac extensions *)
+let _ = 
+  if not !Options.v7 then
+    Egrammar.reset_extend_grammars_v8()
diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml
new file mode 100644
index 00000000..27eead96
--- /dev/null
+++ b/parsing/g_zsyntax.ml
@@ -0,0 +1,406 @@
+(************************************************************************)
+(*  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: g_zsyntax.ml,v 1.16.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Coqast
+open Pcoq
+open Pp
+open Util
+open Names
+open Ast
+open Extend
+open Topconstr
+open Libnames
+open Bignat
+
+(**********************************************************************)
+(* V7 parsing via Grammar *)
+
+let get_z_sign loc =
+  let mkid id =
+    mkRefC (Qualid (loc,Libnames.make_short_qualid id))
+  in
+  ((mkid (id_of_string "xI"),
+    mkid (id_of_string "xO"),
+    mkid (id_of_string "xH")),
+   (mkid (id_of_string "ZERO"), 
+    mkid (id_of_string "POS"),
+    mkid (id_of_string "NEG")))
+
+let pos_of_bignat xI xO xH x =
+  let rec pos_of x =
+    match div2_with_rest x with
+      | (q, true) when is_nonzero q -> mkAppC (xI, [pos_of q])
+      | (q, false) -> mkAppC (xO, [pos_of q])
+      | (_, true) -> xH
+  in 
+  pos_of x
+    
+let z_of_string pos_or_neg s dloc = 
+  let ((xI,xO,xH),(aZERO,aPOS,aNEG)) = get_z_sign dloc in
+  let v = Bignat.of_string s in
+  if is_nonzero v then
+    if pos_or_neg then
+      mkAppC (aPOS, [pos_of_bignat xI xO xH v])
+    else 
+      mkAppC (aNEG, [pos_of_bignat xI xO xH v])
+  else 
+    aZERO
+
+(* Declare the primitive parser with Grammar and without the scope mechanism *)
+let zsyntax_create name =
+  let e =
+    Pcoq.create_constr_entry (Pcoq.get_univ "znatural") name in
+  Pcoq.Gram.Unsafe.clear_entry e;
+  e
+
+let number = zsyntax_create "number" 
+
+let negnumber = zsyntax_create "negnumber"
+ 
+let _ =
+  Gram.extend number None
+    [None, None,
+     [[Gramext.Stoken ("INT", "")],
+      Gramext.action (z_of_string true)]]
+    
+let _ =
+  Gram.extend negnumber None
+    [None, None,
+     [[Gramext.Stoken ("INT", "")],
+      Gramext.action (z_of_string false)]]
+
+(**********************************************************************)
+(* Old v7 ast printing *)
+
+open Coqlib
+
+exception Non_closed_number
+
+let get_z_sign_ast loc =
+  let ast_of_id id = 
+    Termast.ast_of_ref
+      (reference_of_constr
+	(gen_constant_in_modules "Z-printer" zarith_base_modules id))
+  in
+  ((ast_of_id "xI",
+    ast_of_id "xO",
+    ast_of_id "xH"),
+   (ast_of_id "ZERO", 
+    ast_of_id "POS",
+    ast_of_id "NEG"))
+
+let _ = if !Options.v7 then
+let rec bignat_of_pos c1 c2 c3 p =
+  match p with
+    | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c1) ->
+        mult_2 (bignat_of_pos c1 c2 c3 a)
+    | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c2) ->
+        add_1 (mult_2 (bignat_of_pos c1 c2 c3 a))
+    | a when alpha_eq(a,c3) -> Bignat.one
+    | _ -> raise Non_closed_number
+in
+let bignat_option_of_pos xI xO xH p =
+  try 
+    Some (bignat_of_pos xO xI xH p)
+  with Non_closed_number -> 
+    None
+in
+let pr_pos a = hov 0 (str "POS" ++ brk (1,1) ++ a) in
+let pr_neg a = hov 0 (str "NEG" ++ brk (1,1) ++ a) in
+
+let inside_printer posneg std_pr p =
+  let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in
+  match (bignat_option_of_pos xI xO xH p) with
+    | Some n -> 
+	if posneg then 
+	  (str (Bignat.to_string n))
+	else 
+	  (str "(-" ++ str (Bignat.to_string n) ++ str ")")
+    | None -> 
+	let pr = if posneg then pr_pos else pr_neg in
+	str "(" ++ pr (std_pr (ope("ZEXPR",[p]))) ++ str ")"
+in
+let outside_zero_printer std_pr p = str "`0`"
+in
+let outside_printer posneg std_pr p =
+  let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in
+  match (bignat_option_of_pos xI xO xH p) with
+    | Some n -> 
+	if posneg then 
+	  (str "`" ++ str (Bignat.to_string n) ++ str "`")
+	else 
+	  (str "`-" ++ str (Bignat.to_string n) ++ str "`")
+      | None -> 
+	  let pr = if posneg then pr_pos else pr_neg in
+	  str "(" ++ pr (std_pr p) ++ str ")"
+in
+(* For printing with Syntax and without the scope mechanism *)
+let _ = Esyntax.Ppprim.add ("positive_printer", (outside_printer true)) in
+let _ = Esyntax.Ppprim.add ("negative_printer", (outside_printer false)) in
+let _ = Esyntax.Ppprim.add ("positive_printer_inside", (inside_printer true))in
+let _ = Esyntax.Ppprim.add ("negative_printer_inside", (inside_printer false))
+in ()
+
+(**********************************************************************)
+(* Parsing positive via scopes                                        *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let positive_module = ["Coq";"NArith";"BinPos"]
+
+(* TODO: temporary hack *)
+let make_path dir id = Libnames.encode_kn dir id
+
+let positive_path = 
+  make_path (make_dir positive_module) (id_of_string "positive")
+let glob_positive = IndRef (positive_path,0)
+let path_of_xI = ((positive_path,0),1)
+let path_of_xO = ((positive_path,0),2)
+let path_of_xH = ((positive_path,0),3)
+let glob_xI = ConstructRef path_of_xI
+let glob_xO = ConstructRef path_of_xO
+let glob_xH = ConstructRef path_of_xH
+
+let pos_of_bignat dloc x =
+  let ref_xI = RRef (dloc, glob_xI) in
+  let ref_xH = RRef (dloc, glob_xH) in
+  let ref_xO = RRef (dloc, glob_xO) in
+  let rec pos_of x =
+    match div2_with_rest x with
+      | (q,false) -> RApp (dloc, ref_xO,[pos_of q])
+      | (q,true) when is_nonzero q -> RApp (dloc,ref_xI,[pos_of q])
+      | (q,true) -> ref_xH
+  in 
+  pos_of x
+
+let interp_positive dloc = function
+  | POS n when is_nonzero n -> pos_of_bignat dloc n
+  | _ ->
+      user_err_loc (dloc, "interp_positive",
+        str "Only strictly positive numbers in type \"positive\"!")
+
+let rec pat_pos_of_bignat dloc x name =
+  match div2_with_rest x with
+    | (q,false) -> 
+        PatCstr (dloc,path_of_xO,[pat_pos_of_bignat dloc q Anonymous],name)
+    | (q,true) when is_nonzero q -> 
+        PatCstr (dloc,path_of_xI,[pat_pos_of_bignat dloc q Anonymous],name)
+    | (q,true) ->
+        PatCstr (dloc,path_of_xH,[],name)
+
+let pat_interp_positive dloc = function
+  | POS n -> pat_pos_of_bignat dloc n
+  | NEG n ->
+      user_err_loc (dloc, "interp_positive",
+        str "No negative number in type \"positive\"!")
+
+(**********************************************************************)
+(* Printing positive via scopes                                       *)
+(**********************************************************************)
+
+let rec bignat_of_pos = function
+  | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
+  | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | RRef (_, a) when a = glob_xH -> Bignat.one
+  | _ -> raise Non_closed_number
+
+let uninterp_positive p =
+  try 
+    Some (POS (bignat_of_pos p))
+  with Non_closed_number -> 
+    None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for positive *)
+(************************************************************************)
+
+let _ = Symbols.declare_numeral_interpreter "positive_scope"
+  (glob_positive,positive_module)
+  (interp_positive,Some pat_interp_positive)
+  ([RRef (dummy_loc, glob_xI); 
+    RRef (dummy_loc, glob_xO); 
+    RRef (dummy_loc, glob_xH)],
+   uninterp_positive,
+   None)
+
+(**********************************************************************)
+(* Parsing N via scopes                                               *)
+(**********************************************************************)
+
+let binnat_module = ["Coq";"NArith";"BinNat"]
+let n_path = make_path (make_dir binnat_module)
+  (id_of_string (if !Options.v7 then "entier" else "N"))
+let glob_n = IndRef (n_path,0)
+let path_of_N0 = ((n_path,0),1)
+let path_of_Npos = ((n_path,0),2)
+let glob_N0 = ConstructRef path_of_N0
+let glob_Npos = ConstructRef path_of_Npos
+
+let n_of_posint dloc pos_or_neg n = 
+  if is_nonzero n then
+    RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n])
+  else 
+    RRef (dloc, glob_N0)
+
+let n_of_int dloc n =
+  match n with
+  | POS n -> n_of_posint dloc true n 
+  | NEG n -> 
+      user_err_loc (dloc, "",
+        str "No negative number in type N")
+
+let pat_n_of_binnat dloc n name = 
+  if is_nonzero n then
+    PatCstr (dloc, path_of_Npos, [pat_pos_of_bignat dloc n Anonymous], name)
+  else 
+    PatCstr (dloc, path_of_N0, [], name)
+
+let pat_n_of_int dloc n name =
+  match n with
+  | POS n -> pat_n_of_binnat dloc n name
+  | NEG n ->
+      user_err_loc (dloc, "",
+        str "No negative number in type N")
+
+(**********************************************************************)
+(* Printing N via scopes                                              *)
+(**********************************************************************)
+
+let bignat_of_n = function
+  | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> POS (bignat_of_pos a)
+  | RRef (_, a) when a = glob_N0 -> POS (Bignat.zero)
+  | _ -> raise Non_closed_number
+
+let uninterp_n p =
+  try Some (bignat_of_n p)
+  with Non_closed_number -> None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for N *)
+
+let _ = Symbols.declare_numeral_interpreter "N_scope"
+  (glob_n,binnat_module)
+  (n_of_int,Some pat_n_of_int)
+  ([RRef (dummy_loc, glob_N0); 
+    RRef (dummy_loc, glob_Npos)],
+  uninterp_n,
+  None)
+   
+(**********************************************************************)
+(* Parsing Z via scopes                                               *)
+(**********************************************************************)
+
+let fast_integer_module = ["Coq";"ZArith";"BinInt"]
+let z_path = make_path (make_dir fast_integer_module) (id_of_string "Z")
+let glob_z = IndRef (z_path,0)
+let path_of_ZERO = ((z_path,0),1)
+let path_of_POS = ((z_path,0),2)
+let path_of_NEG = ((z_path,0),3)
+let glob_ZERO = ConstructRef path_of_ZERO
+let glob_POS = ConstructRef path_of_POS
+let glob_NEG = ConstructRef path_of_NEG
+
+let z_of_posint dloc pos_or_neg n = 
+  if is_nonzero n then
+    let sgn = if pos_or_neg then glob_POS else glob_NEG in
+    RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n])
+  else 
+    RRef (dloc, glob_ZERO)
+
+let z_of_int dloc z =
+  match z with
+  | POS n -> z_of_posint dloc true n 
+  | NEG n -> z_of_posint dloc false n 
+
+let pat_z_of_posint dloc pos_or_neg n name = 
+  if is_nonzero n then
+    let sgn = if pos_or_neg then path_of_POS else path_of_NEG in
+    PatCstr (dloc, sgn, [pat_pos_of_bignat dloc n Anonymous], name)
+  else 
+    PatCstr (dloc, path_of_ZERO, [], name)
+
+let pat_z_of_int dloc n name =
+  match n with
+  | POS n -> pat_z_of_posint dloc true n name
+  | NEG n -> pat_z_of_posint dloc false n name
+
+(**********************************************************************)
+(* Printing Z via scopes                                              *)
+(**********************************************************************)
+
+let bigint_of_z = function
+  | RApp (_, RRef (_,b),[a]) when b = glob_POS -> POS (bignat_of_pos a)
+  | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> NEG (bignat_of_pos a)
+  | RRef (_, a) when a = glob_ZERO -> POS (Bignat.zero)
+  | _ -> raise Non_closed_number
+
+let uninterp_z p =
+  try
+    Some (bigint_of_z p)
+  with Non_closed_number -> None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for Z *)
+
+let _ = Symbols.declare_numeral_interpreter "Z_scope"
+  (glob_z,fast_integer_module)
+  (z_of_int,Some pat_z_of_int)
+  ([RRef (dummy_loc, glob_ZERO); 
+    RRef (dummy_loc, glob_POS); 
+    RRef (dummy_loc, glob_NEG)],
+  uninterp_z,
+  None)
+   
+(************************************************************************)
+(* Old V7 ast Printers *)
+
+open Esyntax
+
+let _ = if !Options.v7 then
+let bignat_of_pos p =
+  let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in
+  let c1 = xO in
+  let c2 = xI in
+  let c3 = xH in
+  let rec transl = function
+    | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c1) -> mult_2(transl a)
+    | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c2) -> add_1(mult_2(transl a))
+    | a when alpha_eq(a,c3) -> Bignat.one
+    | _ -> raise Non_closed_number
+  in transl p
+in
+let bignat_option_of_pos p =
+  try 
+    Some (bignat_of_pos p)
+  with Non_closed_number -> 
+    None
+in
+let z_printer posneg p =
+  match bignat_option_of_pos p with
+    | Some n -> 
+	if posneg then 
+	  Some (str (Bignat.to_string n))
+	else 
+	  Some (str "-" ++ str (Bignat.to_string n))
+    | None -> None
+in
+let z_printer_ZERO _ =
+  Some (int 0)
+in
+(* Declare pretty-printers for integers *)
+let _ =
+  declare_primitive_printer "z_printer_POS" "Z_scope" (z_printer true) in
+let _ =
+  declare_primitive_printer "z_printer_NEG" "Z_scope" (z_printer false) in
+let _ =
+  declare_primitive_printer "z_printer_ZERO" "Z_scope" z_printer_ZERO in
+()
diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli
new file mode 100644
index 00000000..6a7aeb14
--- /dev/null
+++ b/parsing/g_zsyntax.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  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: g_zsyntax.mli,v 1.6.6.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for integers. *)
diff --git a/parsing/g_zsyntaxnew.mli b/parsing/g_zsyntaxnew.mli
new file mode 100644
index 00000000..51bb6d41
--- /dev/null
+++ b/parsing/g_zsyntaxnew.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  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: g_zsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for integers. *)
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
new file mode 100644
index 00000000..bf5f3bfe
--- /dev/null
+++ b/parsing/lexer.ml4
@@ -0,0 +1,539 @@
+(************************************************************************)
+(*  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: lexer.ml4,v 1.24.2.6 2004/07/16 20:51:12 herbelin Exp $ i*)
+
+open Pp
+open Token
+
+(* Dictionaries: trees annotated with string options, each node being a map
+   from chars to dictionaries (the subtrees). A trie, in other words. *)
+
+module CharMap = Map.Make (struct type t = char let compare = compare end)
+
+type ttree = { 
+  node : string option;
+  branch : ttree CharMap.t }
+
+let empty_ttree = { node = None; branch = CharMap.empty }
+
+let ttree_add ttree str =
+  let rec insert tt i =
+    if i == String.length str then 
+      {node = Some str; branch = tt.branch}
+    else
+      let c = str.[i] in
+      let br =
+        match try Some (CharMap.find c tt.branch) with Not_found -> None with
+          | Some tt' ->
+              CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch)
+          | None ->
+              let tt' = {node = None; branch = CharMap.empty} in
+              CharMap.add c (insert tt' (i + 1)) tt.branch
+      in
+      { node = tt.node; branch = br }
+  in 
+  insert ttree 0
+
+(* Search a string in a dictionary: raises [Not_found]
+   if the word is not present. *)
+
+let ttree_find ttree str =
+  let rec proc_rec tt i =
+    if i == String.length str then
+      match tt.node with
+	| Some s -> s
+	| None -> raise Not_found
+    else 
+      proc_rec (CharMap.find str.[i] tt.branch) (i+1)
+  in 
+  proc_rec ttree 0
+
+(* Lexer conventions on tokens *)
+
+type error =
+  | Illegal_character
+  | Unterminated_comment
+  | Unterminated_string
+  | Undefined_token
+  | Bad_token of string
+
+exception Error of error
+
+let bad_token str = raise (Error (Bad_token str))
+
+let check_special_token str =
+  let rec loop_symb = parser
+    | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str
+    | [< _ = Stream.empty >] -> ()
+    | [< '_ ; s >] -> loop_symb s
+  in
+  loop_symb (Stream.of_string str)
+
+let check_ident str =
+  let first_letter = function
+      (''' | '0'..'9') -> false
+    | _ -> true in
+  let rec loop_id = parser
+    | [< ' ('$' | 'a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_'); s >] ->
+        loop_id s
+    (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
+    | [< ' ('\206' | '\207'); ' ('\128'..'\191'); s >] -> loop_id s
+    | [< ''\226'; 'c2; 'c3; s >] ->
+	  (match c2, c3 with
+	      (* utf8 letter-like unicode 2100-214F *) 
+	    | (('\132', '\128'..'\191') | ('\133', '\128'..'\143')) ->
+                loop_id s 
+		(* utf8 symbols (see [parse_226_tail]) *)
+	    | (('\134'..'\143' | '\152'..'\155' | '\159'
+               | '\164'..'\171'),_) ->
+		bad_token str
+	    | _ -> (* default to iso 8859-1 "â" *)
+		if !Options.v7 then loop_id [< 'c2; 'c3; s >]
+                else bad_token str)
+	(* iso 8859-1 accentuated letters *)
+    | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255'); s >] ->
+        if !Options.v7 then loop_id s else bad_token str
+    | [< _ = Stream.empty >] -> ()
+    | [< >] -> bad_token str
+  in
+  if String.length str > 0 && first_letter str.[0] then
+    loop_id (Stream.of_string str)
+  else
+    bad_token str
+
+let check_keyword str =
+  try check_special_token str
+  with Error _ -> check_ident str
+
+(* Keyword and symbol dictionary *)
+let token_tree = ref empty_ttree
+
+let find_keyword s = ttree_find !token_tree s
+
+let is_keyword s = 
+  try let _ = ttree_find !token_tree s in true with Not_found -> false
+
+let add_keyword str =
+  check_keyword str;
+  token_tree := ttree_add !token_tree str
+
+(* Adding a new token (keyword or special token). *)
+let add_token (con, str) = match con with
+  | "" -> add_keyword str
+  | "METAIDENT" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI"
+      -> ()
+  | _ ->
+      raise (Token.Error ("\
+the constructor \"" ^ con ^ "\" is not recognized by Lexer"))
+
+
+(* Freeze and unfreeze the state of the lexer *)
+type frozen_t = ttree
+
+let freeze () = !token_tree
+
+let unfreeze tt =
+  token_tree := tt
+
+let init () =
+  unfreeze empty_ttree
+
+let _ = init()
+
+(* Errors occuring while lexing (explained as "Lexer error: ...") *)
+let err loc str = Stdpp.raise_with_loc (Util.make_loc loc) (Error str)
+
+(* The string buffering machinery *)
+
+let buff = ref (String.create 80)
+
+let store len x =
+  if len >= String.length !buff then
+    buff := !buff ^ String.create (String.length !buff);
+  !buff.[len] <- x;
+  succ len
+
+let mstore len s =
+  let rec add_rec len i =
+    if i == String.length s then len else add_rec (store len s.[i]) (succ i)
+  in
+  add_rec len 0
+
+let get_buff len = String.sub !buff 0 len
+
+
+(* The classical lexer: idents, numbers, quoted strings, comments *)
+
+let rec ident_tail len strm =
+  if !Options.v7 then
+    match strm with parser
+      | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' | '@' as c); s >] ->
+          ident_tail (store len c) s
+      (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
+      | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] ->
+          ident_tail (store (store len c1) c2) s
+      (* iso 8859-1 accentuated letters *)
+      | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); s >] -> 
+          ident_tail (store len c) s
+      | [< >] -> len
+  else
+    match strm with parser
+      | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] ->
+          ident_tail (store len c) s
+      (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
+      | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] ->
+          ident_tail (store (store len c1) c2) s
+      | [< >] -> len
+
+
+let rec number len = parser
+  | [< ' ('0'..'9' as c); s >] -> number (store len c) s
+  | [< >] -> len
+
+let escape len c = store len c
+
+let rec string_v8 bp len = parser
+  | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] ->
+      if esc then string_v8 bp (store len '"') s else len
+  | [< 'c; s >] -> string_v8 bp (store len c) s 
+  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
+
+let rec string_v7 bp len = parser
+  | [< ''"' >] -> len
+  | [< ''\\'; c = (parser [< ' ('"' | '\\' as c) >] -> c | [< >] -> '\\'); s >]
+     -> string_v7 bp (escape len c) s
+  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
+  | [< 'c; s >] -> string_v7 bp (store len c) s 
+
+let string bp len s =
+  if !Options.v7 then string_v7 bp len s else string_v8 bp len s
+
+(* Hook for exporting comment into xml theory files *)
+let xml_output_comment = ref (fun _ -> ())
+let set_xml_output_comment f = xml_output_comment := f
+
+(* Utilities for comment translation *)
+let comment_begin = ref None
+let comm_loc bp = if !comment_begin=None then comment_begin := Some bp
+
+let current = Buffer.create 8192
+let between_com = ref true
+
+type com_state = int option * string * bool
+let restore_com_state (o,s,b) =
+  comment_begin := o; 
+  Buffer.clear current; Buffer.add_string current s; 
+  between_com := b
+let dflt_com = (None,"",true)
+let com_state () =
+  let s = (!comment_begin, Buffer.contents current, !between_com) in
+  restore_com_state dflt_com; s
+
+let real_push_char c = Buffer.add_char current c
+
+(* Add a char if it is between two commands, if it is a newline or
+   if the last char is not a space itself. *)
+let push_char c =
+  if
+    !between_com || List.mem c ['\n';'\r'] ||
+    (List.mem c [' ';'\t']&&
+     (Buffer.length current = 0 ||
+      not (let s = Buffer.contents current in
+	   List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r'])))
+  then
+    real_push_char c
+
+let push_string s = Buffer.add_string current s
+
+let null_comment s =
+  let rec null i =
+    i<0 || (List.mem s.[i] [' ';'\t';'\n';'\r'] && null (i-1)) in
+  null (String.length s - 1)
+
+let comment_stop ep =
+  let current_s = Buffer.contents current in
+  if !Options.xml_export && Buffer.length current > 0 &&
+    (!between_com || not(null_comment current_s)) then
+      !xml_output_comment current_s;
+  (if Options.do_translate() && Buffer.length current > 0 &&
+    (!between_com || not(null_comment current_s)) then
+    let bp = match !comment_begin with
+        Some bp -> bp
+      | None ->
+          msgerrnl(str"No begin location for comment '"++str current_s ++str"' ending at  "++int ep);
+          ep-1 in
+    Pp.comments := ((bp,ep),current_s) :: !Pp.comments);
+  Buffer.clear current;
+  comment_begin := None;
+  between_com := false
+
+(* Does not unescape!!! *)
+let rec comm_string bp = parser
+  | [< ''"' >] -> push_string "\""
+  | [< ''\\'; _ =
+           (parser [< ' ('"' | '\\' as c) >] ->
+             if c='"' then real_push_char c;
+             real_push_char c
+                 | [< >] -> real_push_char '\\'); s >]
+     -> comm_string bp s
+  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
+  | [< 'c; s >] -> real_push_char c; comm_string bp s 
+
+let rec comment bp = parser bp2
+  | [< ''(';
+       _ = (parser
+              | [< ''*'; s >] -> push_string "(*"; comment bp s
+              | [< >] -> push_string "(" ); 
+       s >] -> comment bp s
+  | [< ''*';
+       _ = parser
+         | [< '')' >] ep -> push_string "*)";
+         | [< s >] -> real_push_char '*'; comment bp s >] -> ()
+  | [< ''"'; s >] ->
+      if Options.do_translate() then (push_string"\"";comm_string bp2 s)
+      else ignore (string bp2 0 s);
+      comment bp s
+  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment
+  | [< '_ as z; s >] ep -> real_push_char z; comment bp s
+
+(* Parse a special token, using the [token_tree] *)
+
+let progress_special c = function
+  | None -> None
+  | Some tt -> try Some (CharMap.find c tt.branch) with Not_found -> None
+
+let rec special tt cs = match tt with
+  | None -> None
+  | Some tt ->
+      match
+	match Stream.peek cs with
+	  | Some c -> 
+	      (try Some (CharMap.find c tt.branch) with Not_found -> None)
+	  | None -> None
+      with
+	| Some _ as tt' -> Stream.junk cs; special tt' cs
+	| None -> tt.node
+
+let process_chars bp c cs =
+  let t =
+    try special (Some (CharMap.find c !token_tree.branch)) cs
+    with Not_found -> !token_tree.node
+  in
+  let ep = Stream.count cs in
+  match t with
+    | Some t -> (("", t), (bp, ep))
+    | None -> err (bp, ep) Undefined_token
+
+type token_226_tail =
+  | TokSymbol of string option
+  | TokIdent of string
+
+let parse_226_tail tk = parser
+  | [< ''\132' as c2; ' ('\128'..'\191' as c3);
+      (* utf8 letter-like unicode 2100-214F *)
+      len = ident_tail (store (store (store 0 '\226') c2) c3) >] ->
+      TokIdent (get_buff len) 
+  | [< ''\133' as c2; ' ('\128'..'\143' as c3);
+      (* utf8 letter-like unicode 2100-214F *)
+      len = ident_tail (store (store (store 0 '\226') c2) c3) >] ->
+      TokIdent (get_buff len) 
+  | [< ' ('\134'..'\143' | '\152'..'\155' | '\159' 
+         | '\164'..'\171' as c2); 'c3;
+      (* utf8 arrows A unicode 2190-21FF *)
+      (* utf8 mathematical operators unicode 2200-22FF *)
+      (* utf8 miscellaneous technical unicode 2300-23FF *)
+      (* utf8 miscellaneous symbols unicode 2600-26FF *)
+      (* utf8 Miscellaneous Mathematical Symbols-A unicode 27C0-27DF *)
+      (* utf8 Supplemental Arrows-A unicode 27E0-27FF *)
+      (* utf8 Supplemental Arrows-B unicode 2900-297F *)
+      (* utf8 Miscellaneous Mathematical Symbols-B unicode 2980-29FF *)
+      (* utf8 mathematical operators unicode 2A00-2AFF *)
+      t = special (progress_special c3 (progress_special c2 
+	(progress_special '\226' tk))) >] ->
+      TokSymbol t
+  | [< len = ident_tail (store 0 '\226') >] ->
+      TokIdent (get_buff len)
+
+
+(* Parse what follows a dot *)
+let parse_after_dot bp c strm =
+  if !Options.v7 then 
+    match strm with parser
+	 | [< ' ('_' | 'a'..'z' | 'A'..'Z' as c);
+              len = ident_tail (store 0 c) >] ->
+	     ("FIELD", get_buff len)
+	 (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
+	 | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); 
+	   len = ident_tail (store (store 0 c1) c2) >] ->
+	     ("FIELD", get_buff len)
+         (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *)
+	 | [< ''\226' as c1; t = parse_226_tail 
+	     (progress_special '.' (Some !token_tree)) >] ep ->
+	     (match t with
+	       | TokSymbol (Some t) -> ("", t)
+	       | TokSymbol None -> err (bp, ep) Undefined_token
+	       | TokIdent t -> ("FIELD", t))
+	 (* iso 8859-1 accentuated letters *)
+	 | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c);
+	   len = ident_tail (store 0 c) >] ->
+	     ("FIELD", get_buff len)
+	 | [< (t,_) = process_chars bp c >] -> t
+  else
+    match strm with parser
+	 | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
+              len = ident_tail (store 0 c) >] ->
+	     ("FIELD", get_buff len)
+	 (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
+	 | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); 
+	   len = ident_tail (store (store 0 c1) c2) >] ->
+	     ("FIELD", get_buff len)
+         (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *)
+	 | [< ''\226' as c1; t = parse_226_tail 
+	     (progress_special '.' (Some !token_tree)) >] ep ->
+	     (match t with
+	       | TokSymbol (Some t) -> ("", t)
+	       | TokSymbol None -> err (bp, ep) Undefined_token
+	       | TokIdent t -> ("FIELD", t))
+	 | [< (t,_) = process_chars bp c >] -> t
+
+
+(* Parse a token in a char stream *)
+
+let rec next_token = parser bp
+  | [< '' ' | '\t' | '\n' |'\r' as c; s >] ep ->
+      comm_loc bp; push_char c; next_token s
+  | [< ''$'; len = ident_tail (store 0 '$') >] ep -> 
+      comment_stop bp;
+      (("METAIDENT", get_buff len), (bp,ep))
+  | [< ''.' as c; t = parse_after_dot bp c >] ep ->
+      comment_stop bp;
+      if !Options.v7 & t=("",".") then between_com := true;
+      (t, (bp,ep))
+  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
+       len = ident_tail (store 0 c) >] ep ->
+      let id = get_buff len in 
+      comment_stop bp;
+      (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
+  (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
+  | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); 
+	   len = ident_tail (store (store 0 c1) c2) >] ep ->
+      let id = get_buff len in
+      comment_stop bp;
+      (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
+  (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *)
+  | [< ''\226' as c1; t = parse_226_tail (Some !token_tree) >] ep ->
+      comment_stop bp;
+      (match t with
+	| TokSymbol (Some t) -> ("", t), (bp, ep)
+	| TokSymbol None -> err (bp, ep) Undefined_token
+	| TokIdent id ->
+	    (try ("", find_keyword id) with Not_found -> ("IDENT", id)),
+	    (bp, ep))
+  (* iso 8859-1 accentuated letters *)
+  | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c) ; s >] ->
+      if !Options.v7 then
+	begin
+	  match s with parser
+	      [< len = ident_tail (store 0 c) >] ep ->
+		let id = get_buff len in
+		comment_stop bp;
+		(try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
+	end
+      else
+	begin
+	  match s with parser
+	      [< t = process_chars bp c >] -> comment_stop bp; t
+	end
+  | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep ->
+      comment_stop bp;
+      (("INT", get_buff len), (bp, ep))
+  | [< ''\"'; len = string bp 0 >] ep ->
+      comment_stop bp;
+      (("STRING", get_buff len), (bp, ep))
+  | [< ' ('(' as c);
+      t = parser
+        | [< ''*'; s >] ->
+            comm_loc bp;
+            push_string "(*";
+	    comment bp s;
+	    next_token s
+        | [< t = process_chars bp c >] -> comment_stop bp; t >] ->
+      t
+  | [< 'c; t = process_chars bp c >] -> comment_stop bp; t
+  | [< _ = Stream.empty >] -> comment_stop bp; (("EOI", ""), (bp, bp + 1))
+
+(* Location table system for creating tables associating a token count
+   to its location in a char stream (the source) *)
+
+let locerr () = invalid_arg "Lexer: location function"
+
+let tsz = 256   (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *)
+
+let loct_create () = ref [| [| |] |]
+
+let loct_func loct i =
+  match
+    if i < 0 || i/tsz >= Array.length !loct then None
+    else if !loct.(i/tsz) = [| |] then None
+    else !loct.(i/tsz).(i mod tsz)
+  with
+    | Some loc -> Util.make_loc loc
+    | _ -> locerr ()
+
+let loct_add loct i loc =
+  while i/tsz >= Array.length !loct do
+    let new_tmax = Array.length !loct * 2 in
+    let new_loct = Array.make new_tmax [| |] in
+    Array.blit !loct 0 new_loct 0 (Array.length !loct);
+    loct := new_loct;
+  done;
+  if !loct.(i/tsz) = [| |] then !loct.(i/tsz) <- Array.make tsz None;
+  !loct.(i/tsz).(i mod tsz) <- Some loc
+
+let current_location_table = ref (ref [| [| |] |])
+
+let location_function n =
+  loct_func !current_location_table n
+
+let func cs =
+  let loct = loct_create () in
+  let ts =
+    Stream.from
+      (fun i ->
+         let (tok, loc) = next_token cs in
+	 loct_add loct i loc; Some tok)
+  in
+  current_location_table := loct;
+  (ts, loct_func loct)
+
+type location_table = (int * int) option array array ref
+let location_table () = !current_location_table
+let restore_location_table t = current_location_table := t
+
+(* Names of tokens, for this lexer, used in Grammar error messages *)
+
+let token_text = function
+  | ("", t) -> "'" ^ t ^ "'"
+  | ("IDENT", "") -> "identifier"
+  | ("IDENT", t) -> "'" ^ t ^ "'"
+  | ("INT", "") -> "integer"
+  | ("INT", s) -> "'" ^ s ^ "'"
+  | ("STRING", "") -> "string"
+  | ("EOI", "") -> "end of input"
+  | (con, "") -> con
+  | (con, prm) -> con ^ " \"" ^ prm ^ "\"" 
+
+let tparse (p_con, p_prm) =
+  None
+  (*i was
+  if p_prm = "" then
+    (parser [< '(con, prm) when con = p_con >] -> prm)
+  else
+    (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm)
+  i*)
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
new file mode 100644
index 00000000..133bca65
--- /dev/null
+++ b/parsing/lexer.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  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: lexer.mli,v 1.20.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+open Pp
+open Util
+
+type error =
+  | Illegal_character
+  | Unterminated_comment
+  | Unterminated_string
+  | Undefined_token
+  | Bad_token of string
+
+exception Error of error
+
+val add_token : string * string -> unit
+val is_keyword : string -> bool
+
+val func : char Stream.t -> (string * string) Stream.t * (int -> loc)
+val location_function : int -> loc
+
+(* for coqdoc *)
+type location_table
+val location_table : unit -> location_table
+val restore_location_table : location_table -> unit
+
+val check_ident : string -> unit
+val check_keyword : string -> unit
+
+val tparse : string * string -> ((string * string) Stream.t -> string) option
+
+val token_text : string * string -> string
+
+type frozen_t
+val freeze : unit -> frozen_t
+val unfreeze : frozen_t -> unit
+val init : unit -> unit
+
+type com_state
+val com_state: unit -> com_state
+val restore_com_state: com_state -> unit
+
+val set_xml_output_comment : (string -> unit) -> unit
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
new file mode 100644
index 00000000..cda482af
--- /dev/null
+++ b/parsing/pcoq.ml4
@@ -0,0 +1,803 @@
+(************************************************************************)
+(*  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: pcoq.ml4,v 1.80.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Rawterm
+open Topconstr
+open Ast
+open Genarg
+open Tacexpr
+open Ppextend
+open Extend
+
+(* The lexer of Coq *)
+
+(* Note: removing a token.
+   We do nothing because [remove_token] is called only when removing a grammar
+   rule with [Grammar.delete_rule]. The latter command is called only when
+   unfreezing the state of the grammar entries (see GRAMMAR summary, file
+   env/metasyntax.ml). Therefore, instead of removing tokens one by one,
+   we unfreeze the state of the lexer. This restores the behaviour of the
+   lexer. B.B. *)
+
+let lexer = {
+  Token.func = Lexer.func;
+  Token.using = Lexer.add_token;
+  Token.removing = (fun _ -> ());
+  Token.tparse = Lexer.tparse;
+  Token.text = Lexer.token_text }
+
+module L =
+  struct
+    let lexer = lexer
+  end
+
+(* The parser of Coq *)
+
+module G = Grammar.Make(L)
+
+let grammar_delete e rls =
+  List.iter
+    (fun (_,_,lev) ->
+       List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
+    (List.rev rls)
+
+(* grammar_object is the superclass of all grammar entry *)
+module type Gramobj =
+sig
+  type grammar_object
+  val weaken_entry : 'a G.Entry.e -> grammar_object G.Entry.e
+end
+
+module Gramobj : Gramobj =
+struct
+  type grammar_object = Obj.t
+  let weaken_entry e = Obj.magic e
+end
+
+type grammar_object = Gramobj.grammar_object
+type typed_entry = entry_type * grammar_object G.Entry.e
+let in_typed_entry t e = (t,Gramobj.weaken_entry e)
+let type_of_typed_entry (t,e) = t
+let object_of_typed_entry (t,e) = e
+let weaken_entry x = Gramobj.weaken_entry x
+
+module type Gramtypes =
+sig
+  open Decl_kinds
+  val inGramObj : 'a raw_abstract_argument_type -> 'a G.Entry.e -> typed_entry
+  val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e
+end
+
+module Gramtypes : Gramtypes =
+struct
+  let inGramObj rawwit = in_typed_entry (unquote rawwit)
+  let outGramObj (a:'a raw_abstract_argument_type) o =
+    if type_of_typed_entry o <> unquote a
+      then anomaly "outGramObj: wrong type";
+    (* downcast from grammar_object *)
+    Obj.magic (object_of_typed_entry o)
+end
+
+open Gramtypes
+
+type ext_kind =
+  | ByGrammar of
+      grammar_object G.Entry.e * Gramext.position option *
+      (string option * Gramext.g_assoc option *
+       (Token.t Gramext.g_symbol list * Gramext.g_action) list) list
+  | ByGEXTEND of (unit -> unit) * (unit -> unit)
+
+let camlp4_state = ref []
+
+(* The apparent parser of Coq; encapsulate G to keep track of the
+   extensions. *)
+module Gram =
+  struct
+    include G
+    let extend e pos rls =
+      camlp4_state :=
+      (ByGEXTEND ((fun () -> grammar_delete e rls),
+                  (fun () -> G.extend e pos rls)))
+      :: !camlp4_state;
+      G.extend e pos rls
+    let delete_rule e pil =
+      errorlabstrm "Pcoq.delete_rule" (str "GDELETE_RULE forbidden.")
+  end
+
+
+let camlp4_verbosity silent f x =
+  let a = !Gramext.warning_verbose in
+  Gramext.warning_verbose := silent;
+  f x;
+  Gramext.warning_verbose := a
+
+(* This extension command is used by the Grammar constr *)
+
+let grammar_extend te pos rls =
+  camlp4_state := ByGrammar (Gramobj.weaken_entry te,pos,rls) :: !camlp4_state;
+  camlp4_verbosity (Options.is_verbose ()) (G.extend te pos) rls
+
+(* n is the number of extended entries (not the number of Grammar commands!)
+   to remove. *)
+let rec remove_grammars n =
+  if n>0 then
+    (match !camlp4_state with
+       | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove"
+       | ByGrammar(g,_,rls)::t ->
+           grammar_delete g rls;
+           camlp4_state := t;
+           remove_grammars (n-1)
+       | ByGEXTEND (undo,redo)::t ->
+           undo();
+           camlp4_state := t;
+           remove_grammars n;
+           redo();
+           camlp4_state := ByGEXTEND (undo,redo) :: !camlp4_state)
+
+(* An entry that checks we reached the end of the input. *)
+let eoi_entry en =
+  let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_eoi") in
+  GEXTEND Gram
+    e: [ [ x = en; EOI -> x ] ]
+    ;
+  END;
+  e
+
+let map_entry f en =
+  let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_map") in
+  GEXTEND Gram
+    e: [ [ x = en -> f x ] ]
+    ;
+  END;
+  e
+
+(* Parse a string, does NOT check if the entire string was read
+   (use eoi_entry) *)
+
+let parse_string f x =
+  let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm)
+
+type gram_universe = (string, typed_entry) Hashtbl.t
+
+let trace = ref false
+
+(* The univ_tab is not part of the state. It contains all the grammar that
+   exist or have existed before in the session. *)
+
+let univ_tab = (Hashtbl.create 7 : (string, string * gram_universe) Hashtbl.t)
+
+let create_univ s =
+  let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
+
+let uprim   = create_univ "prim"
+let uconstr = create_univ "constr"
+let umodule = create_univ "module"
+let utactic = create_univ "tactic"
+let uvernac = create_univ "vernac"
+
+let create_univ_if_new s =
+  (* compatibilite *)
+  let s = if s = "command" then (warning "'command' grammar universe is obsolete; use name 'constr' instead"; "constr") else s in
+  try
+    Hashtbl.find univ_tab s
+  with Not_found -> 
+    if !trace then begin 
+      Printf.eprintf "[Creating univ %s]\n" s; flush stderr; () 
+    end;
+    let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
+
+let get_univ = create_univ_if_new
+
+let get_entry (u, utab) s =
+  try
+    Hashtbl.find utab s 
+  with Not_found -> 
+    errorlabstrm "Pcoq.get_entry"
+      (str "unknown grammar entry " ++ str u ++ str ":" ++ str s)
+
+let new_entry etyp (u, utab) s =
+  let ename = u ^ ":" ^ s in
+  let e = in_typed_entry etyp (Gram.Entry.create ename) in
+  Hashtbl.add utab s e; e
+
+let entry_type (u, utab) s =
+  try
+    let e = Hashtbl.find utab s in
+    Some (type_of_typed_entry e)
+  with Not_found -> None
+
+let get_entry_type (u,n) =  type_of_typed_entry (get_entry (get_univ u) n)
+
+let create_entry_if_new (u, utab) s etyp =
+  try
+    if type_of_typed_entry (Hashtbl.find utab s) <> etyp then
+      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type")
+  with Not_found ->
+    if !trace then begin
+      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
+    end;
+    let _ = new_entry etyp (u, utab) s in ()
+
+let create_entry (u, utab) s etyp =
+  try
+    let e = Hashtbl.find utab s in
+    if type_of_typed_entry e <> etyp then
+      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
+    e
+  with Not_found ->
+    if !trace then begin
+      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
+    end;
+    new_entry etyp (u, utab) s
+
+let create_constr_entry u s =
+  outGramObj rawwit_constr (create_entry u s ConstrArgType)
+
+let create_generic_entry s wit = 
+  let (u,utab) = utactic in
+  let etyp = unquote wit in
+  try
+    let e = Hashtbl.find utab s in
+    if type_of_typed_entry e <> etyp then
+      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
+    outGramObj wit e
+  with Not_found ->
+    if !trace then begin
+      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
+    end;
+  let e = Gram.Entry.create s in
+  Hashtbl.add utab s (inGramObj wit e); e
+
+let get_generic_entry s =
+  let (u,utab) = utactic in
+  try
+    object_of_typed_entry (Hashtbl.find utab s)
+  with Not_found -> 
+    error ("unknown grammar entry "^u^":"^s)
+
+let get_generic_entry_type (u,utab) s =
+  try type_of_typed_entry (Hashtbl.find utab s)
+  with Not_found -> 
+    error ("unknown grammar entry "^u^":"^s)
+
+let force_entry_type (u, utab) s etyp =
+  try
+    let entry = Hashtbl.find utab s in
+    let extyp = type_of_typed_entry entry in
+    if etyp = extyp then 
+      entry
+    else begin
+      prerr_endline
+        ("Grammar entry " ^ u ^ ":" ^ s ^
+         " redefined with another type;\n older entry hidden.");
+      Hashtbl.remove utab s;
+      new_entry etyp (u, utab) s
+    end
+  with Not_found -> 
+    new_entry etyp (u, utab) s
+
+(* [make_gen_entry] builds entries extensible by giving its name (a string) *)
+(* For entries extensible only via the ML name, Gram.Entry.create is enough *)
+
+let make_gen_entry (u,univ) rawwit s =
+  let e = Gram.Entry.create (u ^ ":" ^ s) in
+  Hashtbl.add univ s (inGramObj rawwit e); e
+
+(* Grammar entries *)
+
+module Prim =
+  struct
+    let gec_gen x = make_gen_entry uprim x
+    
+    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Typically for tactic or vernac extensions *)
+    let preident = gec_gen rawwit_pre_ident "preident"
+    let ident = gec_gen rawwit_ident "ident"
+    let natural = gec_gen rawwit_int "natural"
+    let integer = gec_gen rawwit_int "integer"
+    let bigint = Gram.Entry.create "Prim.bigint"
+    let string = gec_gen rawwit_string "string"
+    let reference = make_gen_entry uprim rawwit_ref "reference"
+
+    (* parsed like ident but interpreted as a term *)
+    let hyp = gec_gen rawwit_ident "hyp"
+
+    (* synonym of hyp/ident (before semantics split) for v7 compatibility *)
+    let var = gec_gen rawwit_ident "var"
+
+    let name = Gram.Entry.create "Prim.name"
+    let identref = Gram.Entry.create "Prim.identref"
+
+    (* A synonym of ident - maybe ident will be located one day *)
+    let base_ident = Gram.Entry.create "Prim.base_ident"
+
+    let qualid = Gram.Entry.create "Prim.qualid"
+    let dirpath = Gram.Entry.create "Prim.dirpath"
+
+    let ne_string = Gram.Entry.create "Prim.ne_string"
+
+    (* For old ast printer *)
+    let astpat = Gram.Entry.create "Prim.astpat"
+    let ast = Gram.Entry.create "Prim.ast"
+    let astlist = Gram.Entry.create "Prim.astlist"
+    let ast_eoi = eoi_entry ast
+    let astact = Gram.Entry.create "Prim.astact"
+  end
+
+
+module Constr =
+  struct
+    let gec_constr = make_gen_entry uconstr rawwit_constr
+    let gec_constr_list = make_gen_entry uconstr (wit_list0 rawwit_constr)
+
+    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    let constr = gec_constr "constr"
+    let operconstr = gec_constr "operconstr"
+    let constr_eoi = eoi_entry constr
+    let lconstr = gec_constr "lconstr"
+    let binder_constr = create_constr_entry uconstr "binder_constr"
+    let ident = make_gen_entry uconstr rawwit_ident "ident"
+    let global = make_gen_entry uconstr rawwit_ref "global"
+    let sort = make_gen_entry uconstr rawwit_sort "sort"
+    let pattern = Gram.Entry.create "constr:pattern"
+    let annot = Gram.Entry.create "constr:annot"
+    let constr_pattern = gec_constr "constr_pattern"
+    let lconstr_pattern = gec_constr "lconstr_pattern"
+    let binder = Gram.Entry.create "constr:binder"
+    let binder_let = Gram.Entry.create "constr:binder_let"
+  end
+
+module Module =
+  struct
+    let module_expr = Gram.Entry.create "module_expr"
+    let module_type = Gram.Entry.create "module_type"
+  end
+
+module Tactic =
+  struct
+    (* Main entry for extensions *)
+    let simple_tactic = Gram.Entry.create "tactic:simple_tactic"
+
+    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Typically for tactic user extensions *)
+    let castedopenconstr = 
+      make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr"
+    let constr_with_bindings =
+      make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings"
+    let bindings =
+      make_gen_entry utactic rawwit_bindings "bindings"
+    let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg"
+    let quantified_hypothesis =
+      make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis"
+    let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var"
+    let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr"
+    let simple_intropattern = 
+      make_gen_entry utactic rawwit_intro_pattern "simple_intropattern"
+
+    (* Main entries for ltac *)
+    let tactic_arg = Gram.Entry.create "tactic:tactic_arg"
+    let tactic = make_gen_entry utactic rawwit_tactic "tactic"
+
+    (* Main entry for quotations *)
+    let tactic_eoi = eoi_entry tactic
+  end
+
+
+module Vernac_ =
+  struct
+    let gec_vernac s = Gram.Entry.create ("vernac:" ^ s)
+
+    (* The different kinds of vernacular commands *)
+    let gallina = gec_vernac "gallina"
+    let gallina_ext = gec_vernac "gallina_ext"
+    let command = gec_vernac "command"
+    let syntax = gec_vernac "syntax_command"
+    let vernac = gec_vernac "Vernac_.vernac"
+
+    let vernac_eoi = eoi_entry vernac
+  end
+
+
+(* Prim is not re-initialized *)
+let reset_all_grammars () =
+  let f = Gram.Unsafe.clear_entry in
+  List.iter f
+    [Constr.constr;Constr.operconstr;Constr.lconstr;Constr.annot;
+     Constr.constr_pattern;Constr.lconstr_pattern];
+  f Constr.ident; f Constr.global; f Constr.sort; f Constr.pattern;
+  f Module.module_expr; f Module.module_type;
+  f Tactic.simple_tactic;
+  f Tactic.castedopenconstr;
+  f Tactic.constr_with_bindings;
+  f Tactic.bindings;
+  f Tactic.constrarg;
+  f Tactic.quantified_hypothesis;
+  f Tactic.int_or_var;
+  f Tactic.red_expr;
+  f Tactic.tactic_arg;
+  f Tactic.tactic;
+  f Vernac_.gallina;
+  f Vernac_.gallina_ext;
+  f Vernac_.command;
+  f Vernac_.syntax;
+  f Vernac_.vernac;
+  Lexer.init()
+
+let main_entry = Gram.Entry.create "vernac"
+
+GEXTEND Gram
+  main_entry:
+    [ [ a = Vernac_.vernac -> Some (loc,a) | EOI -> None ] ]
+  ;
+END
+
+(* Quotations *)
+
+open Prim
+open Constr
+open Tactic
+open Vernac_
+
+(* current file and toplevel/vernac.ml *)
+let globalizer = ref (fun x -> failwith "No globalizer")
+let set_globalizer f = globalizer := f
+
+let define_ast_quotation default s (e:Coqast.t G.Entry.e) =
+  (if default then
+    GEXTEND Gram
+      ast: [ [ "<<"; c = e; ">>" -> c ] ];
+     (* Uncomment this to keep compatibility with old grammar syntax
+     constr: [ [ "<<"; c = e; ">>" -> c ] ];
+     vernac: [ [ "<<"; c = e; ">>" -> c ] ];
+     tactic: [ [ "<<"; c = e; ">>" -> c ] ];
+     *)
+   END);
+  (GEXTEND Gram
+     GLOBAL: ast constr command tactic;
+     ast:
+       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
+     (* Uncomment this to keep compatibility with old grammar syntax
+     constr:
+       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
+     command:
+       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
+     tactic:
+       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
+     *)
+   END)
+
+(*
+let _ = define_ast_quotation false "ast" ast in ()
+*)
+
+let dynconstr = Gram.Entry.create "Constr.dynconstr"
+let dyncasespattern = Gram.Entry.create "Constr.dyncasespattern"
+
+GEXTEND Gram
+  dynconstr:
+  [ [ a = Constr.constr -> ConstrNode a 
+    (* For compatibility *)
+    | "<<"; a = Constr.lconstr; ">>" -> ConstrNode a ] ]
+  ;
+  dyncasespattern: [ [ a = Constr.pattern -> CasesPatternNode a ] ];
+END
+
+(**********************************************************************)
+(* The following is to dynamically set the parser in Grammar actions  *)
+(* and Syntax pattern, according to the universe of the rule defined  *)
+
+type parser_type =
+  | ConstrParser
+  | CasesPatternParser
+
+let default_action_parser_ref = ref dynconstr
+
+let get_default_action_parser () = !default_action_parser_ref
+
+let entry_type_of_parser =  function
+  | ConstrParser -> Some ConstrArgType
+  | CasesPatternParser -> failwith "entry_type_of_parser: cases_pattern, TODO"
+
+let parser_type_from_name =  function
+  | "constr" -> ConstrParser
+  | "cases_pattern" -> CasesPatternParser
+  | "tactic" -> assert false
+  | "vernac" -> error "No longer supported"
+  | s -> ConstrParser
+
+let set_default_action_parser = function
+  | ConstrParser  -> default_action_parser_ref := dynconstr
+  | CasesPatternParser  -> default_action_parser_ref := dyncasespattern
+
+let default_action_parser =
+  Gram.Entry.of_parser "default_action_parser" 
+    (fun strm -> Gram.Entry.parse_token (get_default_action_parser ()) strm)
+
+(**********************************************************************)
+(* This determines (depending on the associativity of the current
+   level and on the expected associativity) if a reference to constr_n is
+   a reference to the current level (to be translated into "SELF" on the
+   left border and into "constr LEVEL n" elsewhere), to the level below
+   (to be translated into "NEXT") or to an below wrt associativity (to be
+   translated in camlp4 into "constr" without level) or to another level
+   (to be translated into "constr LEVEL n") *)
+
+let assoc_level = function
+  | Some Gramext.LeftA when !Options.v7 -> "L"
+  | _ -> ""
+
+let constr_level = function
+  | n,assoc -> (string_of_int n)^(assoc_level assoc)
+
+let constr_level2 = function
+  | n,assoc -> (string_of_int n)^(assoc_level (Some assoc))
+
+let default_levels_v7 =
+  [10,Gramext.RightA;
+   9,Gramext.RightA;
+   8,Gramext.RightA;
+   1,Gramext.RightA;
+   0,Gramext.RightA]
+
+let default_levels_v8 =
+  [200,Gramext.RightA;
+   100,Gramext.RightA;
+   99,Gramext.RightA;
+   90,Gramext.RightA;
+   10,Gramext.RightA;
+   9,Gramext.RightA;
+   1,Gramext.LeftA;
+   0,Gramext.RightA]
+
+let default_pattern_levels_v8 =
+  [10,Gramext.LeftA;
+   0,Gramext.RightA]
+
+let level_stack = 
+  ref 
+    [if !Options.v7 then (default_levels_v7, default_levels_v7)
+     else (default_levels_v8, default_pattern_levels_v8)]
+
+(* At a same level, LeftA takes precedence over RightA and NoneA *)
+(* In case, several associativity exists for a level, we make two levels, *)
+(* first LeftA, then RightA and NoneA together *)
+exception Found of Gramext.g_assoc
+
+open Ppextend
+
+let admissible_assoc = function
+  | Gramext.LeftA, Some (Gramext.RightA | Gramext.NonA) -> false
+  | Gramext.RightA, Some Gramext.LeftA -> false
+  | _ -> true
+
+let create_assoc = function
+  | None -> Gramext.RightA
+  | Some a -> a
+
+let error_level_assoc p current expected =
+  let pr_assoc = function
+    | Gramext.LeftA -> str "left"
+    | Gramext.RightA -> str "right" 
+    | Gramext.NonA -> str "non" in
+  errorlabstrm ""
+    (str "Level " ++ int p ++ str " is already declared " ++
+     pr_assoc current ++ str " associative while it is now expected to be " ++
+     pr_assoc expected ++ str " associative")
+
+let find_position forpat other assoc lev =
+  let default = if !Options.v7 then Some (10,Gramext.RightA) else None in
+  let ccurrent,pcurrent as current = List.hd !level_stack in 
+  match lev with
+  | None ->
+      level_stack := current :: !level_stack;
+      None, (if other then assoc else None), None
+  | Some n ->
+      if !Options.v7 & n = 8 & assoc = Some Gramext.LeftA then 
+	error "Left associativity not allowed at level 8";
+      let after = ref default in
+      let rec add_level q = function
+        | (p,_ as pa)::l when p > n -> pa :: add_level (Some pa) l
+        | (p,a as pa)::l as l' when p = n ->
+	    if admissible_assoc (a,assoc) then raise (Found a);
+	    (* No duplication of levels in v8 *)
+	    if not !Options.v7 then error_level_assoc p a (out_some assoc);
+	    (* Maybe this was (p,Left) and p occurs a second time *)
+	    if a = Gramext.LeftA then
+	      match l with
+		| (p,a)::_ as l' when p = n -> raise (Found a)
+		| _ -> after := Some pa; pa::(n,create_assoc assoc)::l
+	    else
+	      (* This was not (p,LeftA) hence assoc is RightA *)
+	      (after := q; (n,create_assoc assoc)::l')
+	| l ->
+	    after := q; (n,create_assoc assoc)::l
+      in
+      try
+	(* Create the entry *)
+	let updated =
+	  if forpat then (ccurrent, add_level default pcurrent)
+	  else (add_level default ccurrent, pcurrent) in
+        level_stack := updated:: !level_stack;
+	let assoc = create_assoc assoc in
+	(if !after = None then Some Gramext.First
+	else Some (Gramext.After (constr_level2 (out_some !after)))),
+	Some assoc, Some (constr_level2 (n,assoc))
+      with
+          Found a ->
+            level_stack := current :: !level_stack;
+	    (* Just inherit the existing associativity and name (None) *)
+	    Some (Gramext.Level (constr_level2 (n,a))), None, None
+
+let remove_levels n =
+  level_stack := list_skipn n !level_stack
+
+(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *)
+let camlp4_assoc = function
+  | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA 
+  | None | Some Gramext.LeftA -> Gramext.LeftA
+
+(* [adjust_level assoc from prod] where [assoc] and [from] are the name
+   and associativity of the level where to add the rule; the meaning of
+   the result is
+
+     None = SELF
+     Some None = NEXT
+     Some (Some (n,cur)) = constr LEVEL n
+         s.t. if [cur] is set then [n] is the same as the [from] level *)
+let adjust_level assoc from = function
+(* Associativity is None means force the level *)
+  | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true))
+(* Compute production name on the right side *)
+  (* If NonA or LeftA on the right-hand side, set to NEXT *)
+  | (NumLevel n,BorderProd (false,Some (Gramext.NonA|Gramext.LeftA))) ->
+      Some None
+  (* If RightA on the right-hand side, set to the explicit (current) level *)
+  | (NumLevel n,BorderProd (false,Some Gramext.RightA)) ->
+      Some (Some (n,true))
+(* Compute production name on the left side *)
+  (* If NonA on the left-hand side, adopt the current assoc ?? *)
+  | (NumLevel n,BorderProd (true,Some Gramext.NonA)) -> None
+  (* If the expected assoc is the current one, set to SELF *)
+  | (NumLevel n,BorderProd (true,Some a)) when a = camlp4_assoc assoc ->
+      None
+  (* Otherwise, force the level, n or n-1, according to expected assoc *)
+  | (NumLevel n,BorderProd (true,Some a)) ->
+      if a = Gramext.LeftA then Some (Some (n,true)) else Some None
+  (* None means NEXT *)
+  | (NextLevel,_) -> Some None
+(* Compute production name elsewhere *)
+  | (NumLevel n,InternalProd) ->
+      match from with
+	| ETConstr (p,()) when p = n+1 -> Some None
+	| ETConstr (p,()) -> Some (Some (n,n=p))
+	| _ -> Some (Some (n,false))
+
+(*
+  (* If NonA on the right-hand side, set to NEXT *)
+  | (n,BorderProd (false,Some Gramext.NonA)) -> Some None
+  (* If NonA on the left-hand side, adopt the current assoc ?? *)
+  | (n,BorderProd (true,Some Gramext.NonA)) -> None
+  (* Associativity is None means force the level *)
+  | (n,BorderProd (_,None)) -> Some (Some (n,true))
+  (* If left assoc at a left level, set NEXT on the right *)
+  | (n,BorderProd (false,Some (Gramext.LeftA as a)))
+      when Gramext.LeftA = camlp4_assoc assoc -> Some None
+  (* If right or none assoc expected is the current assoc, set explicit 
+     level on the right side *)
+  | (n,BorderProd (false,Some a)) when a = camlp4_assoc assoc ->
+      Some (Some (n,true))
+  (* If the expected assoc is the current one, SELF on the left sides *)
+  | (n,BorderProd (true,Some a)) when a = camlp4_assoc assoc -> None
+  (* Otherwise, force the level, n or n-1, according to expected assoc *)
+  | (n,BorderProd (left,Some a)) ->
+      if (left & a = Gramext.LeftA) or ((not left) & a = Gramext.RightA)
+      then Some (Some (n,true)) else Some (Some (n-1,false))
+(*  | (8,InternalProd) -> None (* Or (Some 8) for factorization ? *)*)
+  | (n,InternalProd) ->
+      match from with
+	| ETConstr (p,()) when p = n+1 -> Some None
+	| ETConstr (p,()) -> Some (Some (n,n=p))
+	| _ -> Some (Some (n,false))
+*)
+
+let compute_entry allow_create adjust forpat = function
+  | ETConstr (n,q) ->
+      (if forpat then weaken_entry Constr.pattern
+       else weaken_entry Constr.operconstr),
+      (if forpat & !Options.v7 then None else adjust (n,q)), false
+  | ETIdent -> weaken_entry Constr.ident, None, false
+  | ETBigint -> weaken_entry Prim.bigint, None, false
+  | ETReference -> weaken_entry Constr.global, None, false
+  | ETPattern -> weaken_entry Constr.pattern, None, false
+  | ETOther ("constr","annot") -> 
+      weaken_entry Constr.annot, None, false
+  | ETConstrList _ -> error "List of entries cannot be registered"
+  | ETOther (u,n) ->
+      let u = get_univ u in
+      let e =
+        try get_entry u n
+        with e when allow_create -> create_entry u n ConstrArgType in
+      object_of_typed_entry e, None, true
+
+(* This computes the name of the level where to add a new rule *)
+let get_constr_entry forpat en =
+  match en with
+      ETConstr(200,()) when not !Options.v7 & not forpat ->
+	snd (get_entry (get_univ "constr") "binder_constr"),
+        None,
+        false
+    | _ -> compute_entry true (fun (n,()) -> Some n) forpat en
+
+(* This computes the name to give to a production knowing the name and
+   associativity of the level where it must be added *)
+let get_constr_production_entry ass from forpat en =
+  (* first 2 cases to help factorisation *)
+  match en with
+    | ETConstr (NumLevel 10,q) when !Options.v7 & not forpat ->
+        weaken_entry Constr.lconstr, None, false
+(*
+    | ETConstr (8,q) when !Options.v7 ->
+        weaken_entry Constr.constr, None, false
+*)
+    | _ -> compute_entry false (adjust_level ass from) forpat en
+
+let constr_prod_level assoc cur lev =
+  if !Options.v7 then
+    if cur then constr_level (lev,assoc) else
+      match lev with
+	| 4 when !Options.v7 -> "4L"
+	| n -> string_of_int n
+  else
+    (* No duplication L/R of levels in v8 *)
+    constr_level (lev,assoc)
+
+let is_self from e =
+  match from, e with
+      ETConstr(n,()), ETConstr(NumLevel n',
+        BorderProd(false, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false
+    | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(true,_)) -> n=n'
+    | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint
+      | ETPattern, ETPattern) -> true
+    | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2'
+    | _ -> false
+
+let is_binder_level from e =
+  match from, e with
+      ETConstr(200,()), ETConstr(NumLevel 200,_) -> not !Options.v7
+    | _ -> false
+
+let rec symbol_of_production assoc from forpat typ =
+  if is_binder_level from typ then
+    let eobj = snd (get_entry (get_univ "constr") "operconstr") in
+    Gramext.Snterml (Gram.Entry.obj eobj,"200")
+  else if is_self from typ then Gramext.Sself
+  else
+    match typ with
+    | ETConstrList (typ',[]) ->
+        Gramext.Slist1 (symbol_of_production assoc from forpat (ETConstr typ'))
+    | ETConstrList (typ',tkl) ->
+        Gramext.Slist1sep
+          (symbol_of_production assoc from forpat (ETConstr typ'),
+           Gramext.srules
+             [List.map (fun x -> Gramext.Stoken x) tkl,
+              List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl
+                (Gramext.action (fun loc -> ()))])
+    | _ ->
+    match get_constr_production_entry assoc from forpat typ with
+      | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj)
+      | (eobj,Some None,_) -> Gramext.Snext
+      | (eobj,Some (Some (lev,cur)),_) -> 
+          Gramext.Snterml (Gram.Entry.obj eobj,constr_prod_level assoc cur lev)
+
+
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
new file mode 100644
index 00000000..5c6c8354
--- /dev/null
+++ b/parsing/pcoq.mli
@@ -0,0 +1,192 @@
+(************************************************************************)
+(*  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: pcoq.mli,v 1.63.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+
+open Util
+open Names
+open Rawterm
+open Ast
+open Genarg
+open Topconstr
+open Tacexpr
+open Vernacexpr
+open Libnames
+open Extend
+
+(* The lexer and parser of Coq. *)
+
+val lexer : Token.lexer
+
+module Gram : Grammar.S with type te = Token.t
+
+type grammar_object
+type typed_entry
+
+val type_of_typed_entry : typed_entry -> Extend.entry_type
+val object_of_typed_entry : typed_entry -> grammar_object Gram.Entry.e
+val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e
+
+val get_constr_entry :
+  bool -> constr_entry -> grammar_object Gram.Entry.e * int option * bool
+
+val symbol_of_production : Gramext.g_assoc option -> constr_entry ->
+  bool -> constr_production_entry -> Token.t Gramext.g_symbol
+
+val grammar_extend :
+  'a Gram.Entry.e -> Gramext.position option ->
+    (string option * Gramext.g_assoc option *
+     (Token.t Gramext.g_symbol list * Gramext.g_action) list) list
+    -> unit
+
+val remove_grammars : int -> unit
+
+val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit
+
+(* Parse a string *)
+
+val parse_string : 'a Gram.Entry.e -> string -> 'a
+val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e
+val map_entry : ('a -> 'b) -> 'a Gram.Entry.e -> 'b Gram.Entry.e
+
+(* Entry types *)
+
+(* Table of Coq's grammar entries *)
+
+type gram_universe
+
+val create_univ_if_new : string -> string * gram_universe
+val get_univ : string -> string * gram_universe
+val get_entry : string * gram_universe -> string -> typed_entry
+
+val entry_type : string * gram_universe -> string -> entry_type option
+
+val get_entry_type : string * string -> entry_type
+val create_entry_if_new :
+  string * gram_universe -> string -> entry_type -> unit
+val create_entry :
+  string * gram_universe -> string -> entry_type -> typed_entry
+val force_entry_type :
+  string * gram_universe -> string -> entry_type -> typed_entry
+
+val create_constr_entry :
+  string * gram_universe -> string -> constr_expr Gram.Entry.e
+val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_argument_type -> 'a Gram.Entry.e
+val get_generic_entry : string -> grammar_object Gram.Entry.e
+val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type
+
+type parser_type =
+  | ConstrParser
+  | CasesPatternParser
+
+val entry_type_of_parser : parser_type -> entry_type option
+val parser_type_from_name : string -> parser_type
+
+(* Quotations in ast parser *)
+val define_ast_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit
+val set_globalizer : (constr_expr -> Coqast.t) -> unit
+
+(* The default parser for actions in grammar rules *)
+
+val default_action_parser : dynamic_grammar Gram.Entry.e
+val set_default_action_parser : parser_type -> unit
+
+(* The main entry: reads an optional vernac command *)
+
+val main_entry : (loc * vernac_expr) option Gram.Entry.e
+
+(* Initial state of the grammar *)
+
+module Prim :
+  sig
+    open Util
+    open Names
+    open Libnames
+    val preident : string Gram.Entry.e
+    val ident : identifier Gram.Entry.e
+    val name : name located Gram.Entry.e
+    val identref : identifier located Gram.Entry.e
+    val base_ident : identifier Gram.Entry.e
+    val natural : int Gram.Entry.e
+    val bigint : Bignat.bigint Gram.Entry.e
+    val integer : int Gram.Entry.e
+    val string : string Gram.Entry.e
+    val qualid : qualid located Gram.Entry.e
+    val reference : reference Gram.Entry.e
+    val dirpath : dir_path Gram.Entry.e
+    val ne_string : string Gram.Entry.e
+    val hyp : identifier Gram.Entry.e
+    (* v7 only entries *)
+    val astpat: typed_ast Gram.Entry.e
+    val ast : Coqast.t Gram.Entry.e
+    val astlist : Coqast.t list Gram.Entry.e
+    val ast_eoi : Coqast.t Gram.Entry.e
+    val var : identifier Gram.Entry.e
+  end
+
+module Constr :
+  sig
+    val constr : constr_expr Gram.Entry.e
+    val constr_eoi : constr_expr Gram.Entry.e
+    val lconstr : constr_expr Gram.Entry.e
+    val binder_constr : constr_expr Gram.Entry.e
+    val operconstr : constr_expr Gram.Entry.e
+    val ident : identifier Gram.Entry.e
+    val global : reference Gram.Entry.e
+    val sort : rawsort Gram.Entry.e
+    val pattern : cases_pattern_expr Gram.Entry.e
+    val annot : constr_expr Gram.Entry.e
+    val constr_pattern : constr_expr Gram.Entry.e
+    val lconstr_pattern : constr_expr Gram.Entry.e
+    val binder : (name located list * constr_expr) Gram.Entry.e
+    val binder_let : local_binder Gram.Entry.e
+  end
+
+module Module : 
+  sig
+    val module_expr : module_ast Gram.Entry.e
+    val module_type : module_type_ast Gram.Entry.e
+  end
+
+module Tactic :
+  sig
+    open Rawterm
+    val castedopenconstr : constr_expr Gram.Entry.e
+    val constr_with_bindings : constr_expr with_bindings Gram.Entry.e
+    val bindings : constr_expr bindings Gram.Entry.e
+    val constrarg : (constr_expr,reference) may_eval Gram.Entry.e
+    val quantified_hypothesis : quantified_hypothesis Gram.Entry.e
+    val int_or_var : int or_var Gram.Entry.e
+    val red_expr : raw_red_expr Gram.Entry.e
+    val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e
+    val simple_intropattern : Genarg.intro_pattern_expr Gram.Entry.e
+    val tactic_arg : raw_tactic_arg Gram.Entry.e
+    val tactic : raw_tactic_expr Gram.Entry.e
+    val tactic_eoi : raw_tactic_expr Gram.Entry.e
+  end
+
+module Vernac_ :
+  sig
+    open Decl_kinds
+    val gallina : vernac_expr Gram.Entry.e
+    val gallina_ext : vernac_expr Gram.Entry.e
+    val command : vernac_expr Gram.Entry.e
+    val syntax : vernac_expr Gram.Entry.e
+    val vernac : vernac_expr Gram.Entry.e
+    val vernac_eoi : vernac_expr Gram.Entry.e
+  end
+
+val reset_all_grammars : unit -> unit
+
+(* Registering/resetting the level of an entry *)
+
+val find_position : 
+  bool -> bool -> Gramext.g_assoc option -> int option ->
+    Gramext.position option * Gramext.g_assoc option * string option
+
+val remove_levels : int -> unit 
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
new file mode 100644
index 00000000..6a5242e8
--- /dev/null
+++ b/parsing/ppconstr.ml
@@ -0,0 +1,388 @@
+(************************************************************************)
+(*  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: ppconstr.ml,v 1.32.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+(*i*)
+open Ast
+open Util
+open Pp
+open Nametab
+open Names
+open Nameops
+open Libnames
+open Coqast
+open Ppextend
+open Topconstr
+open Term
+open Pattern
+(*i*)
+
+let latom = 0
+let lannot = 1
+let lprod = 8 (* not 1 because the scope extends to 8 on the right *)
+let llambda = 8 (* not 1 *)
+let lif = 8 (* not 1 *)
+let lletin = 8 (* not 1 *)
+let lcases = 1
+let larrow = 8
+let lcast = 9
+let lapp = 10
+let ltop = (8,E)
+
+let prec_less child (parent,assoc) = match assoc with
+  | E -> child <= parent
+  | L -> child < parent
+  | Prec n -> child <= n
+  | Any -> true
+
+let env_assoc_value v env =
+  try List.nth env (v-1)
+  with Not_found -> anomaly "Inconsistent environment for pretty-print rule"
+
+let decode_constrlist_value = function
+  | CAppExpl (_,_,l) -> l
+  | CApp (_,_,l) -> List.map fst l
+  | _ -> anomaly "Ill-formed list argument of notation"
+
+let decode_patlist_value = function
+  | CPatCstr (_,_,l) -> l
+  | _ -> anomaly "Ill-formed list argument of notation"
+
+open Symbols
+
+let rec print_hunk n decode pr env = function
+  | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env)
+  | UnpListMetaVar (e,prec,sl) -> 
+      prlist_with_sep (fun () -> prlist (print_hunk n decode pr env) sl)
+      (pr (n,prec)) (decode (env_assoc_value e env))
+  | UnpTerminal s -> str s
+  | UnpBox (b,sub) -> ppcmd_of_box b (prlist (print_hunk n decode pr env) sub)
+  | UnpCut cut -> ppcmd_of_cut cut
+
+let pr_notation_gen decode pr s env =
+  let unpl, level = find_notation_printing_rule s in
+  prlist (print_hunk level decode pr env) unpl, level
+
+let pr_notation = pr_notation_gen decode_constrlist_value
+let pr_patnotation = pr_notation_gen decode_patlist_value
+
+let pr_delimiters key strm =
+  let left = "'"^key^":" and right = "'" in
+  let lspace =
+    if is_letter (left.[String.length left -1]) then str " " else mt () in
+  let rspace =
+    let c = right.[0] in
+    if is_letter c or is_digit c or c = '\'' then str " " else mt () in
+  str left ++ lspace ++ strm ++ rspace ++ str right
+
+open Rawterm
+
+let pr_opt pr = function
+  | None -> mt ()
+  | Some x -> spc () ++ pr x
+
+let pr_universe u = str "<univ>"
+
+let pr_sort = function
+  | RProp Term.Null -> str "Prop"
+  | RProp Term.Pos -> str "Set"
+  | RType u -> str "Type" ++ pr_opt pr_universe u
+
+let pr_explicitation = function
+  | None -> mt ()
+  | Some (_,ExplByPos n) -> int n ++ str "!"
+  | Some (_,ExplByName n) -> anomaly "Argument made explicit by name"
+
+let pr_expl_args pr (a,expl) =
+  pr_explicitation expl ++ pr (lapp,L) a
+
+let pr_opt_type pr = function
+  | CHole _ -> mt ()
+  | t -> str ":" ++ pr ltop t
+
+let pr_tight_coma () = str "," ++ cut ()
+
+let pr_name = function
+  | Anonymous -> str "_"
+  | Name id -> pr_id id
+
+let pr_located pr (loc,x) = pr x
+
+let pr_let_binder pr x a =
+  hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++ brk(0,1) ++ pr ltop a)
+
+let pr_binder pr (nal,t) =
+  hov 0 (
+    prlist_with_sep pr_tight_coma (pr_located pr_name) nal ++
+    pr_opt_type pr t)
+
+let pr_binders pr bl =
+  hv 0 (prlist_with_sep pr_semicolon (pr_binder pr) bl)
+
+let pr_local_binder pr = function
+    LocalRawAssum(nal,t) -> pr_binder pr (nal,t)
+  | LocalRawDef((_,na),t) -> pr_let_binder pr na t
+
+let pr_local_binders pr bl =
+  hv 0 (prlist_with_sep pr_semicolon (pr_local_binder pr) bl)
+
+let pr_global vars ref = pr_global_env vars ref
+
+let rec pr_lambda_tail pr bll = function
+  | CLambdaN (_,bl,a) ->
+      pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_binders pr bl) a
+  | CLetIn (_,x,a,b) ->
+      pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_let_binder pr (snd x) a) b
+  | a ->
+      bll, pr ltop a
+
+let rec pr_prod_tail pr bll = function
+  | CProdN (_,bl,a) ->
+      pr_prod_tail pr (bll ++ pr_semicolon () ++ pr_binders pr bl) a
+  | a -> bll, pr ltop a
+
+let pr_recursive_decl pr id binders t c =
+  pr_id id ++ binders ++
+  brk (1,2) ++ str ": " ++ pr ltop t ++ str " :=" ++
+  brk (1,2) ++ pr ltop c
+
+let split_lambda = function
+  | CLambdaN (loc,[[na],t],c) -> (na,t,c)
+  | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
+  | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c))
+  | _ -> anomaly "ill-formed fixpoint body"
+
+let split_product = function
+  | CArrow (loc,t,c) -> ((loc,Anonymous),t,c)
+  | CProdN (loc,[[na],t],c) -> (na,t,c)
+  | CProdN (loc,([na],t)::bl,c) -> (na,t,CProdN(loc,bl,c))
+  | CProdN (loc,(na::nal,t)::bl,c) -> (na,t,CProdN(loc,(nal,t)::bl,c))
+  | _ -> anomaly "ill-formed fixpoint body"
+
+let concat_binder na t = function
+  | [] -> [[na],t]
+  | (nal,u)::bl' as bl -> if t=u then (na::nal,t)::bl' else ([na],t)::bl
+
+let rec split_fix n typ def =
+  if n = 0 then ([],typ,def)
+  else
+    let (na,_,def) = split_lambda def in
+    let (_,t,typ) = split_product typ in
+    let (bl,typ,def) = split_fix (n-1) typ def in
+    (concat_binder na t bl,typ,def)
+
+let pr_fixdecl pr (id,n,bl,t,c) =
+  pr_recursive_decl pr id 
+    (brk (1,2) ++ str "[" ++ pr_local_binders pr bl ++ str "]") t c
+
+let pr_cofixdecl pr (id,bl,t,c) =
+  let  b =
+    if bl=[] then mt() else
+      brk(1,2) ++ str"[" ++ pr_local_binders pr bl ++ str "]" in
+  pr_recursive_decl pr id b t c
+
+let pr_recursive fix pr_decl id = function
+  | [] -> anomaly "(co)fixpoint with no definition"
+  | d1::dl ->
+      hov 0 (
+	str fix ++ spc () ++ pr_id id ++ brk (1,2) ++ str "{" ++
+	(v 0 (
+	  (hov 0 (pr_decl d1)) ++
+	  (prlist (fun fix -> fnl () ++ hov 0 (str "with" ++ pr_decl fix))
+	    dl))) ++
+	str "}")
+
+let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr)
+let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr)
+
+let rec pr_arrow pr = function
+  | CArrow (_,a,b) -> pr (larrow,L) a ++ cut () ++ str "->" ++ pr_arrow pr b
+  | a -> pr (larrow,E) a
+
+let pr_annotation pr = function
+  | None -> mt ()
+  | Some t -> str "<" ++ pr ltop t ++ str ">" ++ brk (0,2)
+
+let rec pr_cases_pattern _inh = function
+  | CPatAlias (_,p,x) ->
+      pr_cases_pattern _inh p ++ spc () ++ str "as" ++ spc () ++ pr_id x
+  | CPatCstr (_,c,[]) -> pr_reference c
+  | CPatCstr (_,c,pl) ->
+      hov 0 (
+	str "(" ++ pr_reference c ++ spc () ++ 
+	prlist_with_sep spc (pr_cases_pattern _inh) pl ++ str ")")
+  | CPatAtom (_,Some c) -> pr_reference c
+  | CPatAtom (_,None) -> str "_"
+  | CPatNotation (_,"( _ )",[p]) ->
+      str"("++ pr_cases_pattern _inh p ++ str")"
+  | CPatNotation (_,s,env) -> fst (pr_patnotation pr_cases_pattern s env)
+  | CPatNumeral (_,n) -> Bignat.pr_bigint n
+  | CPatDelimiters (_,key,p) -> pr_delimiters key (pr_cases_pattern _inh p)
+
+let pr_cases_pattern = pr_cases_pattern (0,E) (* level unused *)
+
+let pr_eqn pr (_,patl,rhs) =
+  hov 0 (
+    prlist_with_sep spc pr_cases_pattern patl ++ spc () ++
+    str "=>" ++
+    brk (1,1) ++ pr ltop rhs) ++ spc ()
+
+let pr_cases pr (po,_) tml eqns =
+  hov 0 (
+    pr_annotation pr po ++
+    hv 0 (
+      hv 0 (
+	str "Cases" ++ brk (1,2) ++
+	prlist_with_sep spc (fun (tm,_) -> pr ltop tm) tml ++ spc() ++ str "of") ++ brk(1,2) ++
+      prlist_with_sep (fun () -> str "| ") (pr_eqn pr) eqns ++
+      str "end"))
+
+let pr_proj pr pr_app a f l =
+  hov 0 (pr (latom,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
+
+let pr_explapp pr f l =
+  hov 0 (
+    str "!" ++ pr_reference f ++ 
+    prlist (fun a -> brk (1,1) ++ pr (lapp,L) a) l)
+
+let pr_app pr a l =
+  hov 0 (
+    pr (lapp,L) a ++ 
+    prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l)
+
+let rec pr inherited a =
+  let (strm,prec) = match a with
+  | CRef r -> pr_reference r, latom
+  | CFix (_,id,fix) -> pr_fix pr (snd id) fix, latom
+  | CCoFix (_,id,cofix) -> pr_cofix pr (snd id) cofix, latom
+  | CArrow _ -> hv 0 (pr_arrow pr a), larrow
+  | CProdN (_,bl,a) ->
+      let bll, a = pr_prod_tail pr (mt()) a in
+      hv 1 (
+	hv 1 (str "(" ++ pr_binders pr bl ++ bll ++ str ")") ++
+	brk (0,1) ++ a), lprod
+  | CLambdaN (_,bl,a) ->
+      let bll, a = pr_lambda_tail pr (mt()) a in
+      hv 1 (
+	hv 1 (str "[" ++ pr_binders pr bl ++ bll ++ str "]") ++
+      brk (0,1) ++ a), llambda
+  | CLetIn (_,x,a,b) ->
+      let bll, b = pr_lambda_tail pr (mt()) b in
+      hv 1 (
+	hv 1 (str "[" ++ pr_let_binder pr (snd x) a ++ bll ++ str "]") ++
+	brk (0,1) ++ b), lletin
+  | CAppExpl (_,((* V7 don't know about projections *)_,f),l) ->
+      pr_explapp pr f l, lapp
+  | CApp (_,(_,a),l) ->
+      pr_app pr a l, lapp
+  | CCases (_,po,tml,eqns) ->
+      pr_cases pr po tml eqns, lcases
+  | COrderedCase (_,IfStyle,po,c,[b1;b2]) ->
+      (* On force les parenthèses autour d'un "if" sous-terme (même si le
+	 parsing est lui plus tolérant) *)
+      hov 0 (
+	pr_annotation pr po ++
+	hv 0 (
+	  str "if " ++ pr ltop c ++ spc () ++
+	  hov 0 (str "then" ++ brk (1,1) ++ pr ltop b1) ++ spc () ++
+	  hov 0 (str "else" ++ brk (1,1) ++ pr ltop b2))), lif
+  | CLetTuple _ | CIf _ ->
+      error "Let tuple not supported in v7"
+
+  | COrderedCase (_,(MatchStyle|RegularStyle as style),po,c,bl) ->
+      hov 0 (
+	hov 0 (
+	pr_annotation pr po ++
+	  hov 0 (
+	    str (if style=RegularStyle then "Case" else "Match") ++ 
+	    brk (1,1) ++ pr ltop c ++ spc () ++
+	    str (if style=RegularStyle then "of" else "with") ++
+	    brk (1,3) ++
+	    fnl () ++ hov 0 (prlist (fun b -> pr ltop b ++ fnl ()) bl) ++
+	    str "end"))), lcases
+  | COrderedCase (_,_,_,_,_) -> 
+      anomaly "malformed if or destructuring let"
+  | CHole _ -> str "?", latom
+(*
+  | CEvar (_,n) -> str "?" ++ int n, latom
+*)
+  | CEvar (_,n) -> str (Evd.string_of_existential n), latom
+  | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
+  | CSort (_,s) -> pr_sort s, latom
+  | CCast (_,a,b) ->
+      hv 0 (pr (lcast,L) a ++ cut () ++ str "::" ++ pr (lcast,E) b), lcast
+  | CNotation (_,"( _ )",[t]) ->
+      str"("++ pr (max_int,E) t ++ str")", latom
+  | CNotation (_,s,env) -> pr_notation pr s env
+  | CNumeral (_,p) -> Bignat.pr_bigint p, latom
+  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr ltop a), latom
+  | CDynamic _ -> str "<dynamic>", latom
+  in
+  if prec_less prec inherited then strm
+  else str"(" ++ strm ++ str")"
+  
+let pr_constr = pr ltop
+
+let pr_pattern = pr_constr
+
+let pr_qualid qid = str (string_of_qualid qid)
+
+open Rawterm
+
+let pr_arg pr x = spc () ++ pr x
+
+let pr_red_flag pr r =
+  (if r.rBeta then pr_arg str "Beta" else mt ()) ++
+  (if r.rIota then pr_arg str "Iota" else mt ()) ++
+  (if r.rZeta then pr_arg str "Zeta" else mt ()) ++
+  (if r.rConst = [] then
+     if r.rDelta then pr_arg str "Delta"
+     else mt ()
+   else
+     pr_arg str "Delta" ++ (if r.rDelta then str "-" else mt ()) ++
+     hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
+
+open Genarg
+
+let pr_occurrences prc (nl,c) = prlist (fun n -> int n ++ spc ()) nl ++ prc c
+
+let pr_red_expr (pr_constr,pr_ref) = function
+  | Red false -> str "Red"
+  | Hnf -> str "Hnf"
+  | Simpl o -> str "Simpl" ++ pr_opt (pr_occurrences pr_constr) o
+  | Cbv f ->
+      if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
+	str "Compute"
+      else
+	hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f)
+  | Lazy f -> 
+      hov 1 (str "Lazy" ++ spc () ++ pr_red_flag pr_ref f)
+  | Unfold l ->
+      hov 1 (str "Unfold" ++
+        prlist (fun (nl,qid) ->
+	  prlist (pr_arg int) nl ++ spc () ++ pr_ref qid) l)
+  | Fold l -> hov 1 (str "Fold" ++ prlist (pr_arg pr_constr) l)
+  | Pattern l -> hov 1 (str "Pattern " ++ prlist (pr_occurrences pr_constr) l)
+  | Red true -> error "Shouldn't be accessible from user"
+  | ExtraRedExpr (s,c) ->
+      hov 1 (str s ++ pr_arg pr_constr c)
+
+let rec pr_may_eval pr pr2 = function
+  | ConstrEval (r,c) ->
+      hov 0
+        (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr2) r ++
+	 spc () ++ str "in" ++ brk (1,1) ++ pr c)
+  | ConstrContext ((_,id),c) ->
+      hov 0
+	(str "Inst " ++ brk (1,1) ++ pr_id id ++ spc () ++
+	 str "[" ++ pr c ++ str "]")
+  | ConstrTypeOf c -> hov 0 (str "Check " ++ brk (1,1) ++ pr c)
+  | ConstrTerm c -> pr c
+
+let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c)
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
new file mode 100644
index 00000000..d238b371
--- /dev/null
+++ b/parsing/ppconstr.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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: ppconstr.mli,v 1.7.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Environ
+open Term
+open Libnames
+open Pcoq
+open Rawterm
+open Extend
+open Coqast
+open Topconstr
+open Names
+open Util
+
+val split_fix : int -> constr_expr -> constr_expr -> 
+  (name located list * constr_expr) list * constr_expr * constr_expr
+
+val pr_global : Idset.t -> global_reference -> std_ppcmds
+
+val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+val pr_name : name -> std_ppcmds
+val pr_qualid : qualid -> std_ppcmds
+val pr_red_expr :
+  ('a -> std_ppcmds) * ('b -> std_ppcmds) ->
+    ('a,'b) red_expr_gen -> std_ppcmds
+val pr_occurrences : ('a -> std_ppcmds) -> 'a occurrences -> std_ppcmds
+
+val pr_sort : rawsort -> std_ppcmds
+val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds
+val pr_constr : constr_expr -> std_ppcmds
+val pr_cases_pattern : cases_pattern_expr -> std_ppcmds
+val pr_may_eval : ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval -> std_ppcmds
+val pr_rawconstr : rawconstr -> std_ppcmds
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
new file mode 100644
index 00000000..95e134ae
--- /dev/null
+++ b/parsing/pptactic.ml
@@ -0,0 +1,758 @@
+(************************************************************************)
+(*  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: pptactic.ml,v 1.54.2.2 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Names
+open Nameops
+open Util
+open Extend
+open Tacexpr
+open Rawterm
+open Topconstr
+open Genarg
+open Libnames
+open Pattern
+
+let pr_red_expr = Ppconstr.pr_red_expr
+let pr_may_eval = Ppconstr.pr_may_eval
+let pr_sort = Ppconstr.pr_sort
+let pr_global x =
+  if Options.do_translate () then (* for pr_gen *)
+    Ppconstrnew.pr_global Idset.empty x
+  else
+    Ppconstr.pr_global Idset.empty x
+let pr_name = Ppconstr.pr_name
+let pr_opt = Ppconstr.pr_opt
+let pr_occurrences = Ppconstr.pr_occurrences
+
+type grammar_terminals = string option list
+
+  (* Extensions *)
+let prtac_tab_v7 = Hashtbl.create 17
+let prtac_tab = Hashtbl.create 17
+
+let declare_extra_tactic_pprule for_v8 s (tags,prods) =
+  Hashtbl.add prtac_tab_v7 (s,tags) prods;
+  if for_v8 then Hashtbl.add prtac_tab (s,tags) prods
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) ->
+      'a -> std_ppcmds
+type 'a glob_extra_genarg_printer =
+    (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
+      'a -> std_ppcmds
+type 'a extra_genarg_printer =
+    (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
+      'a -> std_ppcmds
+
+let genarg_pprule_v7 = ref Stringmap.empty
+let genarg_pprule = ref Stringmap.empty
+
+let declare_extra_genarg_pprule for_v8 (rawwit, f) (globwit, g) (wit, h) =
+  let s = match unquote wit with
+    | ExtraArgType s -> s 
+    | _ -> error
+	"Can declare a pretty-printing rule only for extra argument types"
+  in
+  let f prc prtac x = f prc prtac (out_gen rawwit x) in
+  let g prc prtac x = g prc prtac (out_gen globwit x) in
+  let h prc prtac x = h prc prtac (out_gen wit x) in
+  genarg_pprule_v7 := Stringmap.add s (f,g,h) !genarg_pprule_v7;
+  if for_v8 then
+    genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule 
+
+let pr_arg pr x = spc () ++ pr x
+
+let pr_or_var pr = function
+  | ArgArg x -> pr x
+  | ArgVar (_,s) -> pr_id s
+
+let pr_or_metaid pr = function
+  | AI x -> pr x
+  | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable"
+
+let pr_and_short_name pr (c,_) = pr c
+
+let pr_located pr (loc,x) = pr x
+
+let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp)
+
+let pr_evaluable_reference = function 
+  | EvalVarRef id -> pr_id id
+  | EvalConstRef sp -> pr_global (Libnames.ConstRef sp)
+
+let pr_inductive ind = pr_global (Libnames.IndRef ind)
+
+let pr_quantified_hypothesis = function
+  | AnonHyp n -> int n
+  | NamedHyp id -> pr_id id 
+
+let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
+
+let pr_binding prc = function
+  | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
+  | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+
+let pr_bindings prc prlc = function
+  | ImplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
+      prlist_with_sep spc prc l
+  | ExplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++ 
+        prlist_with_sep spc
+          (fun b -> if Options.do_translate () or not !Options.v7 then
+	    str"(" ++ pr_binding prlc b ++ str")" 
+	   else
+	    pr_binding prc b)
+        l
+  | NoBindings -> mt ()
+
+let pr_bindings_no_with prc prlc = function
+  | ImplicitBindings l ->
+      brk (1,1) ++
+      prlist_with_sep spc prc l
+  | ExplicitBindings l ->
+      brk (1,1) ++ 
+        prlist_with_sep spc
+          (fun b -> if Options.do_translate () or not !Options.v7 then
+	    str"(" ++ pr_binding prlc b ++ str")" 
+	   else
+	    pr_binding prc b)
+        l
+  | NoBindings -> mt ()
+
+let pr_with_bindings prc prlc (c,bl) =
+  if Options.do_translate () then
+    (* translator calls pr_with_bindings on rawconstr: we cast it! *)
+    let bl' = Ppconstrnew.translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in
+    prc c ++ hv 0 (pr_bindings prc prlc bl')
+  else
+    prc c ++ hv 0 (pr_bindings prc prlc bl)
+
+let pr_with_constr prc = function
+  | None -> mt ()
+  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
+
+let pr_with_names = function
+  | None -> mt ()
+  | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
+
+let pr_hyp_location pr_id = function
+  | id, _, (InHyp,_) -> spc () ++ pr_id id
+  | id, _, (InHypTypeOnly,_) ->
+      spc () ++ str "(Type of " ++ pr_id id ++ str ")"
+  | id, _, _ -> error "Unsupported hyp location in v7"
+
+let pr_clause pr_id = function
+  | [] -> mt ()
+  | l -> spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l)
+
+
+let pr_clauses pr_id cls =
+  match cls with
+      { onhyps = Some l; onconcl = false } ->
+        spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l)
+    | { onhyps = Some []; onconcl = true } -> mt()
+    | _ -> error "this clause has both hypothesis and conclusion"
+
+let pr_simple_clause pr_id = function
+  | [] -> mt ()
+  | l -> spc () ++
+      hov 0 (str "in" ++ spc () ++ prlist_with_sep spc pr_id l)
+
+let pr_clause_pattern pr_id cls =
+  pr_opt
+    (prlist (fun (id,occs,_) ->
+      prlist (pr_arg int) occs ++ spc () ++ pr_id id)) cls.onhyps ++
+  if cls.onconcl then
+    prlist (pr_arg int) cls.concl_occs ++ spc() ++ str"Goal"
+  else mt()
+
+let pr_subterms pr occl =
+  hov 0 (pr_occurrences pr occl ++ spc () ++ str "with")
+
+let pr_induction_arg prc = function
+  | ElimOnConstr c -> prc c
+  | ElimOnIdent (_,id) -> pr_id id
+  | ElimOnAnonHyp n -> int n
+
+let pr_induction_kind = function
+  | SimpleInversion -> str "Simple Inversion"
+  | FullInversion -> str "Inversion"
+  | FullInversionClear -> str "Inversion_clear"
+
+let pr_match_pattern pr_pat = function
+  | Term a -> pr_pat a
+  | Subterm (None,a) -> str "[" ++ pr_pat a ++ str "]"
+  | Subterm (Some id,a) -> pr_id id ++ str "[" ++ pr_pat a ++ str "]"
+
+let pr_match_hyps pr_pat = function
+  | Hyp ((_,na),mp) -> pr_name na ++ str ":" ++ pr_match_pattern pr_pat mp
+
+let pr_match_rule m pr_pat pr = function
+  | Pat ([],mp,t) when m ->
+      str "[" ++ pr_match_pattern pr_pat mp ++ str "]"
+      ++ spc () ++ str "->" ++ brk (1,2) ++ pr t
+  | Pat (rl,mp,t) ->
+      str "[" ++ prlist_with_sep pr_semicolon
+                   (pr_match_hyps pr_pat) rl ++ spc () ++ 
+      str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "]" ++
+      spc () ++ str "->" ++ brk (1,2) ++ pr t
+  | All t -> str "_" ++ spc () ++ str "->" ++ brk (1,2) ++ pr t
+
+let pr_funvar = function
+  | None -> spc () ++ str "()"
+  | Some id -> spc () ++ pr_id id
+
+let pr_let_clause k pr = function
+  | ((_,id),None,t) -> hv 0(str k ++ pr_id id ++ str " =" ++ brk (1,1) ++ pr t)
+  | ((_,id),Some c,t) -> str "TODO(LETCLAUSE)"
+
+let pr_let_clauses pr = function
+  | hd::tl ->
+      hv 0
+        (pr_let_clause "Let " pr hd ++
+         prlist (fun t -> spc () ++ pr_let_clause "And " pr t) tl)
+  | [] -> anomaly "LetIn must declare at least one binding"
+
+let pr_rec_clause pr ((_,id),(l,t)) =
+  pr_id id ++ prlist pr_funvar l ++ str "->" ++ spc () ++ pr t
+
+let pr_rec_clauses pr l = 
+  prlist_with_sep (fun () -> fnl () ++ str "And ") (pr_rec_clause pr) l
+
+let pr_hintbases = function
+  | None -> spc () ++ str "with *"
+  | Some [] -> mt ()
+  | Some l ->
+      spc () ++ str "with" ++ hv 0 (prlist (fun s -> spc () ++ str s) l)
+
+let pr_autoarg_adding = function
+  | [] -> mt ()
+  | l ->
+      spc () ++ str "Adding [" ++
+        hv 0 (prlist_with_sep spc pr_reference l) ++ str "]"
+
+let pr_autoarg_destructing = function
+  | true -> spc () ++ str "Destructing"
+  | false -> mt ()
+
+let pr_autoarg_usingTDB = function
+  | true -> spc () ++ str "Using TDB"
+  | false -> mt ()
+
+let rec pr_raw_generic prc prlc prtac prref x =
+  match Genarg.genarg_tag x with
+  | BoolArgType -> pr_arg str (if out_gen rawwit_bool x then "true" else "false")
+  | IntArgType -> pr_arg int (out_gen rawwit_int x)
+  | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen rawwit_int_or_var x)
+  | StringArgType -> spc () ++ str "\"" ++ str (out_gen rawwit_string x) ++ str "\""
+  | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x)
+  | IntroPatternArgType -> pr_arg pr_intro_pattern 
+      (out_gen rawwit_intro_pattern x)
+  | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen rawwit_ident x))
+  | HypArgType -> pr_arg
+      (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen rawwit_var x)
+  | RefArgType -> pr_arg prref (out_gen rawwit_ref x)
+  | SortArgType -> pr_arg pr_sort (out_gen rawwit_sort x)
+  | ConstrArgType -> pr_arg prc (out_gen rawwit_constr x)
+  | ConstrMayEvalArgType ->
+      pr_arg (pr_may_eval prc prref)
+        (out_gen rawwit_constr_may_eval x)
+  | QuantHypArgType ->
+      pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x)
+  | RedExprArgType ->
+      pr_arg (pr_red_expr 
+        (prc,prref)) (out_gen rawwit_red_expr x)
+  | TacticArgType -> pr_arg prtac (out_gen rawwit_tactic x)
+  | CastedOpenConstrArgType ->
+      pr_arg prc (out_gen rawwit_casted_open_constr x)
+  | ConstrWithBindingsArgType -> 
+      pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x)
+  | BindingsArgType -> 
+      pr_arg (pr_bindings_no_with prc prlc) (out_gen rawwit_bindings x)
+  | List0ArgType _ -> 
+      hov 0 (fold_list0 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt()))
+  | List1ArgType _ ->
+      hov 0 (fold_list1 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt()))
+  | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prref) (mt()) x)
+  | PairArgType _ ->
+      hov 0
+        (fold_pair
+	  (fun a b -> pr_raw_generic prc prlc prtac prref a ++ spc () ++ 
+            pr_raw_generic prc prlc prtac prref b)
+	  x)
+  | ExtraArgType s -> 
+      let tab =
+	if Options.do_translate() or not !Options.v7 then !genarg_pprule
+        else !genarg_pprule_v7 in
+      try pi1 (Stringmap.find s tab) prc prtac x
+      with Not_found -> str " [no printer for " ++ str s ++ str "] "
+
+
+let rec pr_glob_generic prc prlc prtac x =
+  match Genarg.genarg_tag x with
+  | BoolArgType -> pr_arg str (if out_gen globwit_bool x then "true" else "false")
+  | IntArgType -> pr_arg int (out_gen globwit_int x)
+  | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen globwit_int_or_var x)
+  | StringArgType -> spc () ++ str "\"" ++ str (out_gen globwit_string x) ++ str "\""
+  | PreIdentArgType -> pr_arg str (out_gen globwit_pre_ident x)
+  | IntroPatternArgType ->
+      pr_arg pr_intro_pattern (out_gen globwit_intro_pattern x)
+  | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen globwit_ident x))
+  | HypArgType -> pr_arg (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen globwit_var x)
+  | RefArgType -> pr_arg (pr_or_var (pr_located pr_global)) (out_gen globwit_ref x)
+  | SortArgType -> pr_arg pr_sort (out_gen globwit_sort x)
+  | ConstrArgType -> pr_arg prc (out_gen globwit_constr x)
+  | ConstrMayEvalArgType ->
+      pr_arg (pr_may_eval prc
+        (pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_constr_may_eval x)
+  | QuantHypArgType ->
+      pr_arg pr_quantified_hypothesis (out_gen globwit_quant_hyp x)
+  | RedExprArgType ->
+      pr_arg (pr_red_expr 
+        (prc,pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_red_expr x)
+  | TacticArgType -> pr_arg prtac (out_gen globwit_tactic x)
+  | CastedOpenConstrArgType ->
+      pr_arg prc (out_gen globwit_casted_open_constr x)
+  | ConstrWithBindingsArgType -> 
+      pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x)
+  | BindingsArgType -> 
+      pr_arg (pr_bindings_no_with prc prlc) (out_gen globwit_bindings x)
+  | List0ArgType _ -> 
+      hov 0 (fold_list0 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt()))
+  | List1ArgType _ ->
+      hov 0 (fold_list1 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt()))
+  | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac) (mt()) x)
+  | PairArgType _ ->
+      hov 0
+        (fold_pair
+	  (fun a b -> pr_glob_generic prc prlc prtac a ++ spc () ++ 
+            pr_glob_generic prc prlc prtac b)
+	  x)
+  | ExtraArgType s -> 
+      let tab =
+	if Options.do_translate() or not !Options.v7 then !genarg_pprule
+        else !genarg_pprule_v7 in
+      try pi2 (Stringmap.find s tab) prc prtac x
+      with Not_found -> str " [no printer for " ++ str s ++ str "] "
+
+open Closure
+
+let rec pr_generic prc prlc prtac x =
+  match Genarg.genarg_tag x with
+  | BoolArgType -> pr_arg str (if out_gen wit_bool x then "true" else "false")
+  | IntArgType -> pr_arg int (out_gen wit_int x)
+  | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen wit_int_or_var x)
+  | StringArgType -> spc () ++ str "\"" ++ str (out_gen wit_string x) ++ str "\""
+  | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x)
+  | IntroPatternArgType -> 
+      pr_arg pr_intro_pattern (out_gen wit_intro_pattern x)
+  | IdentArgType -> pr_arg pr_id (Constrextern.v7_to_v8_id (out_gen wit_ident x))
+  | HypArgType -> pr_arg prc (out_gen wit_var x)
+  | RefArgType -> pr_arg pr_global (out_gen wit_ref x)
+  | SortArgType -> pr_arg prc (Term.mkSort (out_gen wit_sort x))
+  | ConstrArgType -> pr_arg prc (out_gen wit_constr x)
+  | ConstrMayEvalArgType ->
+      pr_arg prc (out_gen wit_constr_may_eval x)
+  | QuantHypArgType ->
+      pr_arg pr_quantified_hypothesis (out_gen wit_quant_hyp x)
+  | RedExprArgType ->
+      pr_arg (pr_red_expr (prc,pr_evaluable_reference)) (out_gen wit_red_expr x)
+  | TacticArgType -> pr_arg prtac (out_gen wit_tactic x)
+  | CastedOpenConstrArgType ->
+      pr_arg prc (snd (out_gen wit_casted_open_constr x))
+  | ConstrWithBindingsArgType -> 
+      pr_arg (pr_with_bindings prc prlc) (out_gen wit_constr_with_bindings x)
+  | BindingsArgType -> 
+      pr_arg (pr_bindings_no_with prc prlc) (out_gen wit_bindings x)
+  | List0ArgType _ -> 
+      hov 0 (fold_list0 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt()))
+  | List1ArgType _ ->
+      hov 0 (fold_list1 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt()))
+  | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac) (mt()) x)
+  | PairArgType _ ->
+      hov 0
+        (fold_pair
+	  (fun a b -> pr_generic prc prlc prtac a ++ spc () ++ 
+            pr_generic prc prlc prtac b)
+	  x)
+  | ExtraArgType s -> 
+      let tab = 
+	if Options.do_translate() or not !Options.v7 then !genarg_pprule
+        else !genarg_pprule_v7 in
+      try pi3 (Stringmap.find s tab) prc prtac x
+      with Not_found -> str " [no printer for " ++ str s ++ str "]"
+
+let rec pr_tacarg_using_rule pr_gen = function
+  | Some s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
+  | None :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule  pr_gen (l,al)
+  | [], [] -> mt ()
+  | _ -> failwith "Inconsistent arguments of extended tactic"
+
+let pr_extend_gen prgen s l =
+  let tab = 
+    if Options.do_translate() or not !Options.v7 then prtac_tab
+    else prtac_tab_v7
+  in
+  try 
+    let tags = List.map genarg_tag l in
+    (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *)
+    let s =
+      let n = String.length s in
+      if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "v7"
+      then String.sub s 0 (n-2) ^ "v8"
+      else s in
+    let (s,pl) = Hashtbl.find tab (s,tags) in
+    str s ++ pr_tacarg_using_rule prgen (pl,l)
+  with Not_found ->
+    str s ++ prlist prgen l ++ str " (* Generic printer *)"
+
+let make_pr_tac (pr_tac,pr_tac0,pr_constr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend) =
+
+let pr_bindings = pr_bindings pr_constr pr_constr in
+let pr_bindings_no_with = pr_bindings_no_with pr_constr pr_constr in
+let pr_with_bindings = pr_with_bindings pr_constr pr_constr in
+let pr_eliminator cb = str "using" ++ pr_arg (pr_with_bindings) cb in
+let pr_constrarg c = spc () ++ pr_constr c in
+let pr_intarg n = spc () ++ int n in
+
+  (* Printing tactics as arguments *)
+let rec pr_atom0 = function
+  | TacIntroPattern [] -> str "Intros"
+  | TacIntroMove (None,None) -> str "Intro"
+  | TacAssumption -> str "Assumption"
+  | TacAnyConstructor None -> str "Constructor"
+  | TacTrivial (Some []) -> str "Trivial"
+  | TacAuto (None,Some []) -> str "Auto"
+  | TacAutoTDB None -> str "AutoTDB"
+  | TacDestructConcl -> str "DConcl"
+  | TacReflexivity -> str "Reflexivity"
+  | t -> str "(" ++ pr_atom1 t ++ str ")"
+
+  (* Main tactic printer *)
+and pr_atom1 = function
+  | TacExtend (_,s,l) -> pr_extend pr_constr pr_constr pr_tac s l
+  | TacAlias (_,s,l,_) ->
+      pr_extend pr_constr pr_constr pr_tac s (List.map snd l)
+
+  (* Basic tactics *)
+  | TacIntroPattern [] as t -> pr_atom0 t
+  | TacIntroPattern (_::_ as p) -> 
+      hov 1 (str "Intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
+  | TacIntrosUntil h ->
+      hv 1 (str "Intros until" ++ pr_arg pr_quantified_hypothesis h)
+  | TacIntroMove (None,None) as t -> pr_atom0 t
+  | TacIntroMove (Some id1,None) -> str "Intro " ++ pr_id id1
+  | TacIntroMove (ido1,Some (_,id2)) ->
+      hov 1
+      (str "Intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ pr_id id2)
+  | TacAssumption as t -> pr_atom0 t
+  | TacExact c -> hov 1 (str "Exact" ++ pr_arg pr_constr c)
+  | TacApply cb -> hov 1 (str "Apply" ++ spc () ++ pr_with_bindings cb)
+  | TacElim (cb,cbo) ->
+      hov 1 (str "Elim" ++ pr_arg pr_with_bindings cb ++ 
+        pr_opt pr_eliminator cbo)
+  | TacElimType c -> hov 1 (str "ElimType" ++ pr_arg pr_constr c)
+  | TacCase cb -> hov 1 (str "Case" ++ spc () ++ pr_with_bindings cb)
+  | TacCaseType c -> hov 1 (str "CaseType" ++ pr_arg pr_constr c)
+  | TacFix (ido,n) -> hov 1 (str "Fix" ++ pr_opt pr_id ido ++ pr_intarg n)
+  | TacMutualFix (id,n,l) ->
+      hov 1 (str "Fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc () ++
+        hov 0 (str "with" ++ brk (1,1) ++
+          prlist_with_sep spc
+	    (fun (id,n,c) ->
+	      spc () ++ pr_id id ++ pr_intarg n ++ pr_arg pr_constr c)
+	  l))
+  | TacCofix ido -> hov 1 (str "Cofix" ++ pr_opt pr_id ido)
+  | TacMutualCofix (id,l) ->
+      hov 1 (str "Cofix" ++ spc () ++ pr_id id ++ spc () ++
+        hov 0 (str "with" ++ brk (1,1) ++
+          prlist (fun (id,c) -> spc () ++ pr_id id ++ pr_arg pr_constr c)
+	  l))
+  | TacCut c -> hov 1 (str "Cut" ++ pr_arg pr_constr c)
+  | TacTrueCut (Anonymous,c) -> 
+      hov 1 (str "Assert" ++ pr_arg pr_constr c)
+  | TacTrueCut (Name id,c) -> 
+      hov 1 (str "Assert" ++ spc () ++ pr_id id ++ str ":" ++ pr_constr c)
+  | TacForward (false,na,c) ->
+      hov 1 (str "Assert" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c)
+  | TacForward (true,na,c) ->
+      hov 1 (str "Pose" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c)
+  | TacGeneralize l ->
+      hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l)
+  | TacGeneralizeDep c ->
+      hov 1 (str "Generalize" ++ spc () ++ str "Dependent" ++ spc () ++
+      pr_constr c)
+  | TacLetTac (na,c,cl) ->
+      let pcl = match cl with
+          {onhyps=None;onconcl=true;concl_occs=[]} -> mt()
+        | _ -> pr_clauses pr_ident cl in
+      hov 1 (str "LetTac" ++ spc () ++ pr_name na ++ str ":=" ++
+             pr_constr c ++ pcl)
+  | TacInstantiate (n,c,cls) ->
+      hov 1 (str "Instantiate" ++ pr_arg int n ++ pr_arg pr_constr c ++ 
+	     pr_clauses pr_ident cls)
+  (* Derived basic tactics *)
+  | TacSimpleInduction (h,_) ->
+      hov 1 (str "Induction" ++ pr_arg pr_quantified_hypothesis h)
+  | TacNewInduction (h,e,(ids,_)) ->
+      hov 1 (str "NewInduction" ++ spc () ++ pr_induction_arg pr_constr h ++
+        pr_opt pr_eliminator e ++ pr_with_names ids)
+  | TacSimpleDestruct h ->
+      hov 1 (str "Destruct" ++ pr_arg pr_quantified_hypothesis h)
+  | TacNewDestruct (h,e,(ids,_)) ->
+      hov 1 (str "NewDestruct" ++ spc () ++ pr_induction_arg pr_constr h ++
+        pr_opt pr_eliminator e ++ pr_with_names ids)
+  | TacDoubleInduction (h1,h2) ->
+      hov 1
+        (str "Double Induction" ++ 
+         pr_arg pr_quantified_hypothesis h1 ++
+ 	 pr_arg pr_quantified_hypothesis h2)
+  | TacDecomposeAnd c ->
+      hov 1 (str "Decompose Record" ++ pr_arg pr_constr c)
+  | TacDecomposeOr c ->
+      hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c)
+  | TacDecompose (l,c) ->
+      hov 1 (str "Decompose" ++ spc () ++
+        hov 0 (str "[" ++ prlist_with_sep spc pr_ind l
+	  ++ str "]" ++ pr_arg pr_constr c))
+  | TacSpecialize (n,c) ->
+      hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c)
+  | TacLApply c -> 
+      hov 1 (str "LApply" ++ pr_constr c)
+
+  (* Automation tactics *)
+  | TacTrivial (Some []) as x -> pr_atom0 x
+  | TacTrivial db -> hov 0 (str "Trivial" ++ pr_hintbases db)
+  | TacAuto (None,Some []) as x -> pr_atom0 x
+  | TacAuto (n,db) -> hov 0 (str "Auto" ++ pr_opt int n ++ pr_hintbases db)
+  | TacAutoTDB None as x -> pr_atom0 x
+  | TacAutoTDB (Some n) -> hov 0 (str "AutoTDB" ++ spc () ++ int n)
+  | TacDestructHyp (true,(_,id)) -> hov 0 (str "CDHyp" ++ spc () ++ pr_id id)
+  | TacDestructHyp (false,(_,id)) -> hov 0 (str "DHyp" ++ spc () ++ pr_id id)
+  | TacDestructConcl as x -> pr_atom0 x
+  | TacSuperAuto (n,l,b1,b2) ->
+      hov 1 (str "SuperAuto" ++ pr_opt int n ++ pr_autoarg_adding l ++ 
+             pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2)
+  | TacDAuto (n,p) ->
+      hov 1 (str "Auto" ++ pr_opt int n ++ str "Decomp" ++ pr_opt int p)
+
+  (* Context management *)
+  | TacClear l ->
+      hov 1 (str "Clear" ++ spc () ++ prlist_with_sep spc pr_ident l)
+  | TacClearBody l ->
+      hov 1 (str "ClearBody" ++ spc () ++ prlist_with_sep spc pr_ident l)
+  | TacMove (b,id1,id2) ->
+      (* Rem: only b = true is available for users *)
+      assert b;
+      hov 1
+        (str "Move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
+	 str "after" ++ brk (1,1) ++ pr_ident id2)
+  | TacRename (id1,id2) ->
+      hov 1
+        (str "Rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
+	 str "into" ++ brk (1,1) ++ pr_ident id2)
+
+  (* Constructors *)
+  | TacLeft l -> hov 1 (str "Left" ++ pr_bindings l)
+  | TacRight l -> hov 1 (str "Right" ++ pr_bindings l)
+  | TacSplit (_,l) -> hov 1 (str "Split" ++ pr_bindings l)
+  | TacAnyConstructor (Some t) ->
+      hov 1 (str "Constructor" ++ pr_arg pr_tac0 t)
+  | TacAnyConstructor None as t -> pr_atom0 t
+  | TacConstructor (n,l) ->
+      hov 1 (str "Constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l)
+
+  (* Conversion *)  
+  | TacReduce (r,h) ->
+      hov 1 (pr_red_expr (pr_constr,pr_cst) r ++ pr_clauses pr_ident h)
+  | TacChange (occl,c,h) ->
+      hov 1 (str "Change" ++ pr_opt (pr_subterms pr_constr) occl ++ 
+        brk (1,1) ++ pr_constr c ++ pr_clauses pr_ident h)
+
+  (* Equivalence relations *)
+  | TacReflexivity as x -> pr_atom0 x
+  | TacSymmetry cls -> str "Symmetry " ++ pr_clauses pr_ident cls
+  | TacTransitivity c -> str "Transitivity" ++ pr_arg pr_constr c
+
+  (* Equality and inversion *)
+  | TacInversion (DepInversion (k,c,ids),hyp) ->
+      hov 1 (str "Dependent " ++ pr_induction_kind k ++ 
+      pr_quantified_hypothesis hyp ++
+      pr_with_names ids ++ pr_with_constr pr_constr c)
+  | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
+      hov 1 (pr_induction_kind k ++ spc () ++
+      pr_quantified_hypothesis hyp ++
+      pr_with_names ids ++ pr_simple_clause pr_ident cl)
+  | TacInversion (InversionUsing (c,cl),hyp) ->
+      hov 1 (str "Inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ 
+      str "using" ++ spc () ++ pr_constr c ++ 
+      pr_simple_clause pr_ident cl)
+
+and pr_tactic_seq_body tl = 
+  hv 0 (str "[ " ++
+        prlist_with_sep (fun () -> spc () ++ str "| ") prtac tl ++ str " ]")
+
+  (* Strictly closed atomic tactic expressions *)
+and pr0 = function
+  | TacFirst tl -> str "First" ++ spc () ++ pr_tactic_seq_body tl
+  | TacSolve tl -> str "Solve" ++ spc () ++ pr_tactic_seq_body tl
+  | TacId "" -> str "Idtac" 
+  | TacFail (ArgArg 0,"") -> str "Fail"
+  | TacAtom (_,t) -> pr_atom0 t
+  | TacArg c -> pr_tacarg c
+  | t -> str "(" ++ prtac t ++ str ")"
+
+  (* Semi-closed atomic tactic expressions *)
+and pr1 = function
+  | TacAtom (_,t) -> pr_atom1 t
+  | TacId s -> str "Idtac \"" ++ str s ++ str "\""	
+  | TacFail (ArgArg 0,s) -> str "Fail \"" ++ str s ++ str "\""
+  | TacFail (n,"") -> str "Fail " ++ pr_or_var int n
+  | TacFail (n,s) -> str "Fail " ++ pr_or_var int n ++ str " \"" ++ str s ++ str "\""
+  | t -> pr0 t
+
+  (* Orelse tactic expressions (printed as if parsed associating on the right
+     though the semantics is purely associative) *)
+and pr2 = function
+  | TacOrelse (t1,t2) ->
+      hov 1 (pr1 t1 ++ str " Orelse" ++ brk (1,1) ++ pr3 t2)
+  | t -> pr1 t
+
+  (* Non closed prefix tactic expressions *)
+and pr3 = function
+  | TacTry t -> hov 1 (str "Try" ++ spc () ++ pr3 t)
+  | TacDo (n,t) -> hov 1 (str "Do " ++ pr_or_var int n ++ spc () ++ pr3 t)
+  | TacRepeat t -> hov 1 (str "Repeat" ++ spc () ++ pr3 t)
+  | TacProgress t -> hov 1 (str "Progress" ++ spc () ++ pr3 t)
+  | TacInfo t -> hov 1 (str "Info" ++ spc () ++ pr3 t)
+  | t -> pr2 t
+
+and pr4 = function
+  | t -> pr3 t
+
+  (* THEN and THENS tactic expressions (printed as if parsed
+     associating on the left though the semantics is purely associative) *)
+and pr5 = function
+  | TacThens (t,tl) -> 
+      hov 1 (pr5 t ++ str ";" ++ spc () ++ pr_tactic_seq_body tl)
+  | TacThen (t1,t2) ->
+      hov 1 (pr5 t1 ++ str ";" ++ spc () ++ pr4 t2)
+  | t -> pr4 t
+
+  (* Ltac tactic expressions *)
+and pr6 = function
+  |(TacAtom _
+  | TacThen _
+  | TacThens _
+  | TacFirst _
+  | TacSolve _
+  | TacTry _
+  | TacOrelse _
+  | TacDo _
+  | TacRepeat _
+  | TacProgress _
+  | TacId _
+  | TacFail _
+  | TacInfo _) as t -> pr5 t
+
+  | TacAbstract (t,None) -> str "Abstract " ++ pr6 t
+  | TacAbstract (t,Some s) -> 
+      hov 0
+       (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s)
+  | TacLetRecIn (l,t) -> 
+      hv 0
+        (str "Rec " ++ pr_rec_clauses prtac l ++
+        spc () ++ str "In" ++ fnl () ++ prtac t)
+  | TacLetIn (llc,u) ->
+      v 0
+       (hv 0 (pr_let_clauses pr_tacarg0 llc ++ spc () ++ str "In") ++ fnl () ++ prtac u)
+  | TacMatch (t,lrul) ->
+      hov 0 (str "Match" ++ spc () ++ pr6 t ++ spc()
+        ++ str "With"
+        ++ prlist
+	  (fun r -> fnl () ++ str "|" ++ spc () ++
+            pr_match_rule true pr_pat prtac r)
+	lrul)
+  | TacMatchContext (lr,lrul) ->
+      hov 0 (
+	str (if lr then "Match Reverse Context With" else "Match Context With")
+	++ prlist
+	  (fun r -> fnl () ++ str "|" ++ spc () ++
+            pr_match_rule false pr_pat prtac r)
+	lrul)
+  | TacFun (lvar,body) ->
+      hov 0 (str "Fun" ++
+        prlist pr_funvar lvar ++ spc () ++ str "->" ++ spc () ++ prtac body)
+
+  | TacArg c -> pr_tacarg c
+
+and pr_tacarg0 = function
+  | TacDynamic (_,t) -> str ("<dynamic ["^(Dyn.tag t)^"]>")
+  | MetaIdArg (_,s) -> str ("$" ^ s)
+  | IntroPattern ipat -> pr_intro_pattern ipat
+  | TacVoid -> str "()"
+  | Reference r -> pr_ref r
+  | ConstrMayEval (ConstrTerm c) -> str "'" ++ pr_constr c
+  | ConstrMayEval c -> pr_may_eval pr_constr pr_cst c
+  | Integer n -> int n
+  | TacFreshId sopt -> str "FreshId" ++ pr_opt qstring sopt
+  | (TacCall _ | Tacexp _) as t -> str "(" ++ pr_tacarg1 t ++ str ")"
+
+and pr_tacarg1 = function
+  | TacCall (_,f,l) ->
+      hov 0 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg0 l)
+  | Tacexp t -> pr_tac t
+  | t -> pr_tacarg0 t
+
+and pr_tacarg x = pr_tacarg1 x
+
+and prtac x = pr6 x
+
+in (prtac,pr0,pr_match_rule false pr_pat pr_tac)
+
+let pr_raw_extend prc prlc prtac = 
+  pr_extend_gen (pr_raw_generic prc prlc prtac Ppconstrnew.pr_reference)
+let pr_glob_extend prc prlc prtac =
+  pr_extend_gen (pr_glob_generic prc prlc prtac)
+let pr_extend prc prlc prtac =
+  pr_extend_gen (pr_generic prc prlc prtac)
+
+let pr_and_constr_expr pr (c,_) = pr c
+
+let rec glob_printers =
+    (pr_glob_tactic, 
+     pr_glob_tactic0,
+     pr_and_constr_expr Printer.pr_rawterm,
+     Printer.pr_pattern,
+     pr_or_var (pr_and_short_name pr_evaluable_reference),
+     pr_or_var pr_inductive,
+     pr_or_var (pr_located pr_ltac_constant),
+     pr_located pr_id,
+     pr_glob_extend)
+
+and pr_glob_tactic (t:glob_tactic_expr) = pi1 (make_pr_tac glob_printers) t
+
+and pr_glob_tactic0 t = pi2 (make_pr_tac glob_printers) t
+
+and pr_glob_match_context t = pi3 (make_pr_tac glob_printers) t
+
+let (pr_tactic,_,_) =
+  make_pr_tac
+    (pr_glob_tactic,
+     pr_glob_tactic0,
+     Printer.prterm,
+     Printer.pr_pattern,
+     pr_evaluable_reference,
+     pr_inductive,
+     pr_ltac_constant,
+     pr_id,
+     pr_extend)
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
new file mode 100644
index 00000000..a80ec6fb
--- /dev/null
+++ b/parsing/pptactic.mli
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  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: pptactic.mli,v 1.9.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Genarg
+open Tacexpr
+open Pretyping
+open Proof_type
+open Topconstr
+open Rawterm
+
+val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
+val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> std_ppcmds
+val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
+val pr_located : ('a -> std_ppcmds) -> 'a Util.located -> std_ppcmds
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) ->
+      'a -> std_ppcmds
+
+type 'a glob_extra_genarg_printer =
+    (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
+      'a -> std_ppcmds
+
+type 'a extra_genarg_printer =
+    (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
+      'a -> std_ppcmds
+
+  (* if the boolean is false then the extension applies only to old syntax *)
+val declare_extra_genarg_pprule : 
+  bool ->
+  ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) ->
+  ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) ->
+  ('b closed_abstract_argument_type * 'b extra_genarg_printer) -> unit
+
+type grammar_terminals = string option list
+
+  (* if the boolean is false then the extension applies only to old syntax *)
+val declare_extra_tactic_pprule : bool -> string -> 
+  argument_type list * (string * grammar_terminals) -> unit
+
+val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
+
+val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+  ('a,'b) match_rule -> std_ppcmds
+
+val pr_glob_tactic : glob_tactic_expr -> std_ppcmds
+
+val pr_tactic : Proof_type.tactic_expr -> std_ppcmds
+
+val pr_glob_generic:
+  (rawconstr_and_expr -> std_ppcmds) -> 
+  (rawconstr_and_expr -> std_ppcmds) -> 
+  (glob_tactic_expr -> std_ppcmds) ->
+    glob_generic_argument -> std_ppcmds
+
+val pr_raw_generic : 
+  (constr_expr -> std_ppcmds) ->
+  (constr_expr -> std_ppcmds) ->
+  (raw_tactic_expr -> std_ppcmds) ->
+  (Libnames.reference -> std_ppcmds) ->
+    (constr_expr, raw_tactic_expr) generic_argument ->
+      std_ppcmds
+
+val pr_raw_extend:
+  (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
+  (raw_tactic_expr -> std_ppcmds) -> string ->
+    raw_generic_argument list -> std_ppcmds
+
+val pr_glob_extend:
+  (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) ->
+  (glob_tactic_expr -> std_ppcmds) -> string ->
+    glob_generic_argument list -> std_ppcmds
+
+val pr_extend :
+  (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
+  (glob_tactic_expr -> std_ppcmds) -> string -> closed_generic_argument list -> std_ppcmds
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
new file mode 100644
index 00000000..169eff94
--- /dev/null
+++ b/parsing/prettyp.ml
@@ -0,0 +1,605 @@
+(************************************************************************)
+(*  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: prettyp.ml,v 1.50.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Inductive
+open Inductiveops
+open Sign
+open Reduction
+open Environ
+open Instantiate
+open Declare
+open Impargs
+open Libobject
+open Printer
+open Printmod
+open Libnames
+open Nametab
+
+(*********************)
+(** Basic printing   *)
+
+let print_basename sp = pr_global (ConstRef sp)
+
+let print_closed_sections = ref false
+
+(********************************)
+(** Printing implicit arguments *)
+			  		  
+let print_impl_args_by_pos = function
+  | []  -> mt ()
+  | [i] -> str"Position [" ++ int i ++ str"] is implicit" ++ fnl()
+  | l   -> 
+      str"Positions [" ++ 
+      prlist_with_sep (fun () -> str "; ") int l ++
+      str"] are implicit" ++ fnl()
+
+let print_impl_args_by_name = function
+  | []  -> mt ()
+  | [i] -> str"Argument " ++ pr_id (name_of_implicit i) ++ str" is implicit" ++
+      fnl()
+  | l   -> 
+      str"Arguments " ++ 
+      prlist_with_sep (fun () -> str ", ")
+        (fun imp -> pr_id (name_of_implicit imp)) l ++
+      str" are implicit" ++ fnl()
+
+let print_impl_args l = 
+  if !Options.v7 then print_impl_args_by_pos (positions_of_implicits l)
+  else print_impl_args_by_name (List.filter is_status_implicit l)
+
+(*********************)
+(** Printing Scopes  *)
+
+let print_ref reduce ref =
+  let typ = Global.type_of_global ref in
+  let typ = 
+    if reduce then
+      let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ
+      in it_mkProd_or_LetIn ccl ctx 
+    else typ in
+  hov 0 (pr_global ref ++ str " :" ++ spc () ++ prtype typ) ++ fnl ()
+
+let print_argument_scopes = function
+  | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl()
+  | l when not (List.for_all ((=) None) l) ->
+      hov 2 (str"Argument scopes are" ++ spc() ++ 
+      str "[" ++ 
+      prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++
+      str "]") ++ fnl()
+  | _  -> mt()
+
+let need_expansion impl ref = 
+  let typ = Global.type_of_global ref in
+  let ctx = fst (decompose_prod_assum typ) in
+  let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in
+  impl <> [] & let _,lastimpl = list_chop nprods impl in
+  List.filter is_status_implicit lastimpl <> []
+
+let print_name_infos ref =
+  let impl = implicits_of_global ref in
+  let scopes = Symbols.find_arguments_scope ref in
+  let type_for_implicit = 
+    if need_expansion impl ref then
+      (* Need to reduce since implicits are computed with products flattened *)
+      str "Expanded type for implicit arguments" ++ fnl () ++ 
+      print_ref true ref ++ fnl()
+    else mt() in
+  (if (List.filter is_status_implicit impl<>[])
+      or not (List.for_all ((=) None) scopes) 
+  then fnl()
+  else mt())
+  ++ type_for_implicit 
+  ++ print_impl_args impl ++ print_argument_scopes scopes
+
+let print_id_args_data test pr id l =
+  if List.exists test l then
+    str"For " ++ pr_id id ++ str": " ++ pr l
+  else 
+    mt()
+
+let print_args_data_of_inductive_ids get test pr sp mipv =
+  prvecti
+    (fun i mip -> 
+      print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) ++
+      prvecti 
+	(fun j idc ->
+	  print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1))))
+        mip.mind_consnames)
+    mipv
+
+let print_inductive_implicit_args =
+  print_args_data_of_inductive_ids
+    implicits_of_global is_status_implicit print_impl_args
+
+let print_inductive_argument_scopes =
+  print_args_data_of_inductive_ids 
+    Symbols.find_arguments_scope ((<>) None) print_argument_scopes
+
+(*********************)
+(* "Locate" commands *)
+
+type logical_name =
+  | Term of global_reference
+  | Dir of global_dir_reference
+  | Syntactic of kernel_name
+  | ModuleType of qualid * kernel_name
+  | Undefined of qualid
+
+let locate_any_name ref =
+  let module N = Nametab in
+  let (loc,qid) = qualid_of_reference ref in
+  try Term (N.locate qid)
+  with Not_found -> 
+  try Syntactic (N.locate_syntactic_definition qid)
+  with Not_found ->
+  try Dir (N.locate_dir qid)
+  with Not_found ->
+  try ModuleType (qid, N.locate_modtype qid)
+  with Not_found -> Undefined qid
+
+let pr_located_qualid = function
+  | Term ref ->
+      let ref_str = match ref with
+	  ConstRef _ -> "Constant"
+	| IndRef _ -> "Inductive"
+	| ConstructRef _ -> "Constructor"
+	| VarRef _ -> "Variable" in
+      str ref_str ++ spc () ++ pr_sp (Nametab.sp_of_global ref)
+  | Syntactic kn ->
+      str (if !Options.v7 then "Syntactic Definition" else "Notation") ++ 
+      spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn)
+  | Dir dir ->
+      let s,dir = match dir with
+	| DirOpenModule (dir,_) -> "Open Module", dir
+	| DirOpenModtype (dir,_) -> "Open Module Type", dir
+	| DirOpenSection (dir,_) -> "Open Section", dir
+	| DirModule (dir,_) -> "Module", dir
+	| DirClosedSection dir -> "Closed Section", dir
+      in
+      str s ++ spc () ++ pr_dirpath dir
+  | ModuleType (qid,_) ->
+      str "Module Type" ++ spc () ++ pr_sp (Nametab.full_name_modtype qid)
+  | Undefined qid ->    
+      pr_qualid qid ++ str " is not a defined object"
+
+let print_located_qualid ref =
+  let (loc,qid) = qualid_of_reference ref in
+  let module N = Nametab in
+  let expand = function
+    | TrueGlobal ref -> Term ref, N.shortest_qualid_of_global Idset.empty ref
+    | SyntacticDef kn -> Syntactic kn, N.shortest_qualid_of_syndef kn in
+  match List.map expand (N.extended_locate_all qid) with
+    | [] -> 
+	let (dir,id) = repr_qualid qid in
+	if dir = empty_dirpath then
+	  str "No object of basename " ++ pr_id id
+	else
+	  str "No object of suffix " ++ pr_qualid qid
+    | l ->
+	prlist_with_sep fnl
+	(fun (o,oqid) ->
+	  hov 2 (pr_located_qualid o ++
+	  (if oqid <> qid then
+	    spc() ++ str "(visible as " ++ pr_qualid oqid ++ str")"
+	  else
+	    mt ()))) l
+
+(******************************************)
+(**** Printing declarations and judgments *)
+
+let print_typed_value_in_env env (trm,typ) =
+  (prterm_env env trm ++ fnl () ++
+     str "     : " ++ prtype_env env typ ++ fnl ())
+
+let print_typed_value x = print_typed_value_in_env (Global.env ()) x
+
+let print_judgment env {uj_val=trm;uj_type=typ} =
+  print_typed_value_in_env env (trm, typ)
+    
+let print_safe_judgment env j =
+  let trm = Safe_typing.j_val j in
+  let typ = Safe_typing.j_type j in
+  print_typed_value_in_env env (trm, typ)
+    
+(* To be improved; the type should be used to provide the types in the
+   abstractions. This should be done recursively inside prterm, so that
+   the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u)
+   synthesizes the type nat of the abstraction on u *)
+
+let print_named_def name body typ =
+  let pbody = prterm body in
+  let ptyp = prtype typ in
+  (str "*** [" ++ str name ++ str " " ++
+     hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++
+	      str ":" ++ brk (1,2) ++ ptyp) ++
+	   str "]" ++ fnl ())
+
+let print_named_assum name typ =
+  (str "*** [" ++ str name ++ str " : " ++ prtype typ ++ str "]" ++ fnl ())
+
+let print_named_decl (id,c,typ) =
+  let s = string_of_id id in
+  match c with
+    | Some body -> print_named_def s body typ
+    | None -> print_named_assum s typ
+
+let assumptions_for_print lna =
+  List.fold_right (fun na env -> add_name na env) lna empty_names_context
+
+(*********************)
+(* *)
+
+let print_params env params =
+  if List.length params = 0 then 
+    (mt ()) 
+  else
+    if !Options.v7 then
+      (str "[" ++ pr_rel_context env params ++ str "]" ++ brk(1,2))
+    else 
+      (pr_rel_context env params ++ brk(1,2))
+
+let print_constructors envpar names types =
+  let pc =
+    prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
+      (fun (id,c) -> pr_id id ++ str " : " ++ prterm_env envpar c)
+      (Array.to_list (array_map2 (fun n t -> (n,t)) names types))
+  in 
+  hv 0 (str "  " ++ pc)
+
+let build_inductive sp tyi =
+  let (mib,mip) = Global.lookup_inductive (sp,tyi) in
+  let params = mip.mind_params_ctxt in
+  let args = extended_rel_list 0 params in
+  let env = Global.env() in
+  let arity = hnf_prod_applist env mip.mind_user_arity args in
+  let cstrtypes = arities_of_constructors env (sp,tyi) in
+  let cstrtypes =
+    Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
+  let cstrnames = mip.mind_consnames in
+  (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes)
+
+let print_one_inductive (sp,tyi) =
+  let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in
+  let env = Global.env () in
+  let envpar = push_rel_context params env in
+  hov 0 (
+    pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++
+    str ": " ++ prterm_env envpar arity ++ str " :=") ++
+  brk(0,2) ++ print_constructors envpar cstrnames cstrtypes
+
+let pr_mutual_inductive finite indl =
+  hov 0 (
+    str (if finite then "Inductive " else "CoInductive ") ++
+    prlist_with_sep (fun () -> fnl () ++ str"  with ")
+      print_one_inductive indl) ++
+  fnl ()
+
+let print_mutual sp =
+  let (mib,mip) = Global.lookup_inductive (sp,0) in
+  let mipv = mib.mind_packets in
+  let names = list_tabulate (fun x -> (sp,x)) (Array.length mipv) in
+  pr_mutual_inductive mib.mind_finite names ++
+  print_inductive_implicit_args sp mipv ++
+  print_inductive_argument_scopes sp mipv
+
+let print_section_variable sp =
+  let d = get_variable sp in
+  print_named_decl d ++ 
+  print_name_infos (VarRef sp)
+
+let print_body = function
+  | Some lc  -> prterm (Declarations.force lc)
+  | None -> (str"<no body>")
+
+let print_typed_body (val_0,typ) =
+  (print_body val_0 ++ fnl () ++ str "     : " ++ prtype typ ++ fnl ())
+
+let print_constant with_values sep sp =
+  let cb = Global.lookup_constant sp in
+  let val_0 = cb.const_body in
+  let typ = cb.const_type in
+  hov 0 (
+    match val_0 with 
+    | None -> 
+	str"*** [ " ++ 
+	print_basename sp ++ str " : " ++ cut () ++ prtype typ ++ 
+	str" ]" ++ fnl ()
+    | _ -> 
+	print_basename sp ++ str sep ++ cut () ++
+	(if with_values then print_typed_body (val_0,typ) else prtype typ) ++
+	fnl ())
+
+let print_constant_with_infos sp =
+  print_constant true " = " sp ++ print_name_infos (ConstRef sp)
+
+let print_inductive sp = (print_mutual sp)
+
+let print_syntactic_def sep kn =
+  let qid = Nametab.shortest_qualid_of_syndef kn in
+  let c = Syntax_def.search_syntactic_definition dummy_loc kn in 
+  (str (if !Options.v7 then "Syntactic Definition " else "Notation ")
+   ++ pr_qualid qid ++ str sep ++ 
+  Constrextern.without_symbols pr_rawterm c ++ fnl ())
+
+let print_leaf_entry with_values sep ((sp,kn as oname),lobj) =
+  let tag = object_tag lobj in
+  match (oname,tag) with
+    | (_,"VARIABLE") ->
+	Some (print_section_variable (basename sp))
+    | (_,"CONSTANT") ->
+	Some (print_constant with_values sep kn)
+    | (_,"INDUCTIVE") ->
+	Some (print_inductive kn)
+    | (_,"MODULE") ->
+	let (mp,_,l) = repr_kn kn in 
+	Some (print_module with_values (MPdot (mp,l)))
+    | (_,"MODULE TYPE") ->
+	Some (print_modtype kn)
+    | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"|
+	"COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None
+    (* To deal with forgotten cases... *)
+    | (_,s) -> None
+(*
+    | (_,s) -> 
+	(str(string_of_path sp) ++ str" : " ++
+           str"Unrecognized object " ++ str s ++ fnl ())
+*)
+
+let rec print_library_entry with_values ent = 
+  let sep = if with_values then " = " else " : " in 
+  let pr_name (sp,_) = pr_id (basename sp) in
+  match ent with
+    | (oname,Lib.Leaf lobj) -> 
+	print_leaf_entry with_values sep (oname,lobj)
+    | (oname,Lib.OpenedSection (dir,_)) -> 
+        Some (str " >>>>>>> Section " ++ pr_name oname)
+    | (oname,Lib.ClosedSection _) -> 
+        Some (str " >>>>>>> Closed Section " ++ pr_name oname)
+    | (_,Lib.CompilingLibrary (dir,_)) ->
+	Some (str " >>>>>>> Library " ++ pr_dirpath dir)
+    | (oname,Lib.OpenedModule _) ->
+	Some (str " >>>>>>> Module " ++ pr_name oname)
+    | (oname,Lib.OpenedModtype _) ->
+	Some (str " >>>>>>> Module Type " ++ pr_name oname)
+    | (_,Lib.FrozenState _) ->
+	None
+	
+let print_context with_values = 
+  let rec prec n = function
+    | h::rest when n = None or out_some n > 0 -> 
+	(match print_library_entry with_values h with
+	  | None -> prec n rest
+	  | Some pp -> prec (option_app ((+) (-1)) n) rest ++ pp ++ fnl ())
+    | _ -> mt ()
+  in 
+  prec
+
+let print_full_context () = 
+  print_context true None (Lib.contents_after None)
+
+let print_full_context_typ () =
+  print_context false None (Lib.contents_after None)
+
+(* For printing an inductive definition with
+   its constructors and elimination,
+   assume that the declaration of constructors and eliminations
+   follows the definition of the inductive type *)
+
+let list_filter_vec f vec = 
+  let rec frec n lf = 
+    if n < 0 then lf 
+    else if f vec.(n) then 
+      frec (n-1) (vec.(n)::lf)
+    else 
+      frec (n-1) lf
+  in 
+  frec (Array.length vec -1) []
+
+(* This is designed to print the contents of an opened section *)
+let read_sec_context r =
+  let loc,qid = qualid_of_reference r in
+  let dir =
+    try Nametab.locate_section qid
+    with Not_found ->
+      user_err_loc (loc,"read_sec_context", str "Unknown section") in
+  let rec get_cxt in_cxt = function
+    | ((_,Lib.OpenedSection ((dir',_),_)) as hd)::rest ->
+        if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
+    | ((_,Lib.ClosedSection (_,_,ctxt)) as hd)::rest ->
+        error "Cannot print the contents of a closed section"
+    | [] -> []
+    | hd::rest -> get_cxt (hd::in_cxt) rest 
+  in
+  let cxt = (Lib.contents_after None) in
+  List.rev (get_cxt [] cxt)
+
+let print_sec_context sec = 
+  print_context true None (read_sec_context sec)
+
+let print_sec_context_typ sec =
+  print_context false None (read_sec_context sec)
+
+let print_eval red_fun env {uj_val=trm;uj_type=typ} =
+  let ntrm = red_fun env Evd.empty trm in
+  (str "     = " ++ print_judgment env {uj_val = ntrm; uj_type = typ})
+
+let print_name ref = 
+  match locate_any_name ref with
+  | Term (ConstRef sp) -> print_constant_with_infos sp
+  | Term (IndRef (sp,_)) -> print_inductive sp
+  | Term (ConstructRef ((sp,_),_)) -> print_inductive sp
+  | Term (VarRef sp) -> print_section_variable sp
+  | Syntactic kn -> print_syntactic_def " := " kn
+  | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp
+  | Dir _ -> mt ()
+  | ModuleType (_,kn) -> print_modtype kn
+  | Undefined qid ->
+  try  (* Var locale de but, pas var de section... donc pas d'implicits *)
+    let dir,str = repr_qualid qid in 
+    if (repr_dirpath dir) <> [] then raise Not_found;
+    let (_,c,typ) = Global.lookup_named str in 
+    (print_named_decl (str,c,typ))
+  with Not_found ->
+  try 
+    let sp = Nametab.locate_obj qid in
+    let (oname,lobj) = 
+      let (oname,entry) =
+	List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None)
+      in
+      match entry with
+	| Lib.Leaf obj -> (oname,obj)
+	| _ -> raise Not_found
+    in
+    match print_leaf_entry true " = " (oname,lobj) with
+      | None -> mt ()
+      | Some pp -> pp ++ fnl()
+  with Not_found ->
+    errorlabstrm
+      "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object")
+
+let print_opaque_name qid = 
+  let sigma = Evd.empty in
+  let env = Global.env () in
+  let sign = Global.named_context () in
+  match global qid with
+    | ConstRef cst ->
+	let cb = Global.lookup_constant cst in
+        if cb.const_body <> None then
+	  print_constant_with_infos cst
+        else 
+	  error "not a defined constant"
+    | IndRef (sp,_) ->
+        print_mutual sp
+    | ConstructRef cstr -> 
+	let ty = Inductive.type_of_constructor env cstr in
+	print_typed_value (mkConstruct cstr, ty)
+    | VarRef id ->
+        let (_,c,ty) = lookup_named id env in 
+	print_named_decl (id,c,ty)
+
+let print_about ref = 
+  let sigma = Evd.empty in
+  let k = locate_any_name ref in
+  begin match k with
+  | Term ref -> print_ref false ref ++ print_name_infos ref
+  | Syntactic kn -> print_syntactic_def " := " kn
+  | Dir _ | ModuleType _ | Undefined _ -> mt () end
+  ++
+  hov 0 (str "Expands to: " ++ pr_located_qualid k)
+
+let print_impargs ref =
+  let ref = Nametab.global ref in
+  let impl = implicits_of_global ref in
+  let has_impl = List.filter is_status_implicit impl <> [] in
+  (* Need to reduce since implicits are computed with products flattened *)
+  print_ref (need_expansion impl ref) ref ++ fnl() ++
+  (if has_impl then print_impl_args impl 
+   else (str "No implicit arguments" ++ fnl ()))
+
+let print_local_context () =
+  let env = Lib.contents_after None in
+  let rec print_var_rec = function 
+    | [] -> (mt ())
+    | (oname,Lib.Leaf lobj)::rest ->
+	if "VARIABLE" = object_tag lobj then
+          let d = get_variable (basename (fst oname)) in 
+	  (print_var_rec rest ++
+             print_named_decl d)
+	else 
+	  print_var_rec rest
+    | _::rest -> print_var_rec rest
+
+  and print_last_const = function
+    | (oname,Lib.Leaf lobj)::rest -> 
+        (match object_tag lobj with
+           | "CONSTANT" -> 
+	       let kn = snd oname in
+               let {const_body=val_0;const_type=typ} = 
+		 Global.lookup_constant kn in
+		 (print_last_const rest ++
+                  print_basename kn ++str" = " ++
+                  print_typed_body (val_0,typ))
+           | "INDUCTIVE" -> 
+	       let kn = snd oname in
+               (print_last_const rest ++print_mutual kn ++ fnl ())
+           | "VARIABLE" ->  (mt ())
+           | _          ->  print_last_const rest)
+    | _ -> (mt ())
+  in 
+  (print_var_rec env ++  print_last_const env)
+
+let unfold_head_fconst = 
+  let rec unfrec k = match kind_of_term k with
+    | Const cst -> constant_value (Global.env ()) cst 
+    | Lambda (na,t,b) -> mkLambda (na,t,unfrec b)
+    | App (f,v) -> appvect (unfrec f,v)
+    | _ -> k
+  in 
+  unfrec
+
+(* for debug *)
+let inspect depth = 
+  print_context false (Some depth) (Lib.contents_after None)
+
+
+(*************************************************************************)
+(* Pretty-printing functions coming from classops.ml                     *)
+
+open Classops
+
+let print_coercion_value v = prterm (get_coercion_value v)
+
+let print_class i =
+  let cl,_ = class_info_from_index i in
+  pr_class cl
+  
+let print_path ((i,j),p) = 
+  (str"[" ++ 
+     prlist_with_sep pr_semicolon print_coercion_value p ++
+     str"] : " ++ print_class i ++ str" >-> " ++
+     print_class j)
+
+let _ = Classops.install_path_printer print_path
+
+let print_graph () = 
+  prlist_with_sep pr_fnl print_path (inheritance_graph())
+
+let print_classes () = 
+  prlist_with_sep pr_spc pr_class (classes())
+
+let print_coercions () = 
+  prlist_with_sep pr_spc print_coercion_value (coercions())
+  
+let index_of_class cl =
+  try 
+    fst (class_info cl)
+  with _ -> 
+    errorlabstrm "index_of_class" (pr_class cl ++ str" is not a defined class")
+
+let print_path_between cls clt = 
+  let i = index_of_class cls in
+  let j = index_of_class clt in
+  let p = 
+    try 
+      lookup_path_between (i,j) 
+    with _ -> 
+      errorlabstrm "index_cl_of_id"
+        (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt)
+  in
+  print_path ((i,j),p)
+
+(*************************************************************************)
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
new file mode 100644
index 00000000..c8471330
--- /dev/null
+++ b/parsing/prettyp.mli
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  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: prettyp.mli,v 1.12.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Sign
+open Term
+open Environ
+open Reductionops
+open Libnames
+open Nametab
+(*i*)
+
+(* A Pretty-Printer for the Calculus of Inductive Constructions. *)
+
+val assumptions_for_print : name list -> Termops.names_context
+
+val print_closed_sections : bool ref
+val print_impl_args : Impargs.implicits_list -> std_ppcmds
+val print_context : bool -> int option -> Lib.library_segment -> std_ppcmds
+val print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option
+val print_full_context : unit -> std_ppcmds
+val print_full_context_typ : unit -> std_ppcmds
+val print_sec_context : reference -> std_ppcmds
+val print_sec_context_typ : reference -> std_ppcmds
+val print_judgment : env -> unsafe_judgment -> std_ppcmds
+val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds
+val print_eval :
+  reduction_function -> env -> unsafe_judgment -> std_ppcmds
+(* This function is exported for the graphical user-interface pcoq *)
+val build_inductive : mutual_inductive -> int ->
+  global_reference * rel_context * types * identifier array * types array
+val print_mutual : mutual_inductive -> std_ppcmds
+val print_name : reference -> std_ppcmds
+val print_opaque_name : reference -> std_ppcmds
+val print_local_context : unit -> std_ppcmds
+val print_about : reference -> std_ppcmds
+val print_impargs : reference -> std_ppcmds
+
+(*i
+val print_extracted_name : identifier -> std_ppcmds
+val print_extraction : unit -> std_ppcmds
+val print_extracted_vars : unit -> std_ppcmds
+i*)
+
+(* Pretty-printing functions for classes and coercions *)
+val print_graph : unit -> std_ppcmds
+val print_classes : unit -> std_ppcmds
+val print_coercions : unit -> std_ppcmds
+val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds
+
+val inspect : int -> std_ppcmds
+
+(* Locate *)
+val print_located_qualid : reference -> std_ppcmds
diff --git a/parsing/printer.ml b/parsing/printer.ml
new file mode 100644
index 00000000..dfacc764
--- /dev/null
+++ b/parsing/printer.ml
@@ -0,0 +1,249 @@
+(************************************************************************)
+(*  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: printer.ml,v 1.58.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Global
+open Declare
+open Coqast
+open Ast
+open Termast
+open Libnames
+open Extend
+open Nametab
+open Ppconstr
+
+let emacs_str s = if !Options.print_emacs then s else "" 
+
+(**********************************************************************)
+(* Old Ast printing *)
+
+let constr_syntax_universe = "constr"
+(* This is starting precedence for printing constructions or tactics *)
+(* Level 9 means no parentheses except for applicative terms (at level 10) *)
+let constr_initial_prec_v7 = Some (9,Ppextend.L)
+let constr_initial_prec = Some (200,Ppextend.E)
+
+let dfltpr ast = (str"#GENTERM " ++ print_ast ast);;
+
+let global_const_name kn =
+  try pr_global Idset.empty (ConstRef kn)
+  with Not_found -> (* May happen in debug *)
+    (str ("CONST("^(string_of_kn kn)^")"))
+
+let global_var_name id =
+  try pr_global Idset.empty (VarRef id)
+  with Not_found -> (* May happen in debug *)
+    (str ("SECVAR("^(string_of_id id)^")"))
+
+let global_ind_name (kn,tyi) =
+  try pr_global Idset.empty (IndRef (kn,tyi))
+  with Not_found -> (* May happen in debug *)
+    (str ("IND("^(string_of_kn kn)^","^(string_of_int tyi)^")"))
+
+let global_constr_name ((kn,tyi),i) =
+  try pr_global Idset.empty (ConstructRef ((kn,tyi),i))
+  with Not_found -> (* May happen in debug *)
+    (str ("CONSTRUCT("^(string_of_kn kn)^","^(string_of_int tyi)
+		  ^","^(string_of_int i)^")"))
+
+let globpr gt = match gt with
+  | Nvar(_,s) -> (pr_id s)
+  | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev)))
+  | Node(_,"CONST",[Path(_,sl)]) ->
+      global_const_name (section_path sl)
+  | Node(_,"SECVAR",[Nvar(_,s)]) ->
+      global_var_name s
+  | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) ->
+      global_ind_name (section_path sl, tyi)
+  | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) ->
+      global_constr_name ((section_path sl, tyi), i)
+  | Dynamic(_,d) ->
+    if (Dyn.tag d) = "constr" then (str"<dynamic [constr]>")
+    else dfltpr gt
+  | gt -> dfltpr gt
+
+
+let wrap_exception = function
+    Anomaly (s1,s2) ->
+      warning ("Anomaly ("^s1^")"); pp s2;
+      str"<PP error: non-printable term>"
+  | Failure _ | UserError _ | Not_found ->
+      str"<PP error: non-printable term>"
+  | s -> raise s
+
+let gentermpr_fail gt =
+  let prec =
+    if !Options.v7 then constr_initial_prec_v7 else constr_initial_prec in
+  Esyntax.genprint globpr constr_syntax_universe prec gt
+
+let gentermpr gt =
+  try gentermpr_fail gt
+  with s -> wrap_exception s
+
+(**********************************************************************)
+(* Generic printing: choose old or new printers *)
+
+(* [at_top] means ids of env must be avoided in bound variables *)
+let gentermpr_core at_top env t =
+  if !Options.v7 then gentermpr (Termast.ast_of_constr at_top env t)
+  else Ppconstrnew.pr_lconstr (Constrextern.extern_constr at_top env t)
+let pr_cases_pattern t =
+  if !Options.v7 then gentermpr (Termast.ast_of_cases_pattern t)
+  else Ppconstrnew.pr_cases_pattern
+    (Constrextern.extern_cases_pattern Idset.empty t)
+let pr_pattern_env tenv env t =
+  if !Options.v7 then gentermpr (Termast.ast_of_pattern tenv env t)
+  else Ppconstrnew.pr_constr
+    (Constrextern.extern_pattern tenv env t)
+
+(**********************************************************************)
+(* Derived printers *)
+  
+let prterm_env_at_top env = gentermpr_core true env
+let prterm_env env = gentermpr_core false env
+let prtype_env env typ = prterm_env env typ
+let prjudge_env env j =
+  (prterm_env env j.uj_val, prterm_env env j.uj_type)
+
+(* NB do not remove the eta-redexes! Global.env() has side-effects... *)
+let prterm t = prterm_env (Global.env()) t
+let prtype t = prtype_env (Global.env()) t
+let prjudge j = prjudge_env (Global.env()) j
+
+let pr_constant env cst = prterm_env env (mkConst cst)
+let pr_existential env ev = prterm_env env (mkEvar ev)
+let pr_inductive env ind = prterm_env env (mkInd ind)
+let pr_constructor env cstr = prterm_env env (mkConstruct cstr)
+let pr_global = pr_global Idset.empty
+
+let pr_rawterm t =
+  if !Options.v7 then gentermpr (Termast.ast_of_rawconstr t)
+  else Ppconstrnew.pr_lconstr (Constrextern.extern_rawconstr Idset.empty t)
+
+open Pattern
+let pr_ref_label = function (* On triche sur le contexte *)
+  | ConstNode sp -> pr_constant (Global.env()) sp
+  | IndNode sp -> pr_inductive (Global.env()) sp
+  | CstrNode sp -> pr_constructor (Global.env()) sp
+  | VarNode id -> pr_id id
+
+let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t
+
+let pr_var_decl env (id,c,typ) =
+  let pbody = match c with
+    | None ->  (mt ())
+    | Some c ->
+	(* Force evaluation *) 
+	let pb = prterm_env env c in
+	(str" := " ++ pb ++ cut () ) in
+  let pt = prtype_env env typ in
+  let ptyp = (str" : " ++ pt) in
+  (pr_id id ++ hov 0 (pbody ++ ptyp))
+
+let pr_rel_decl env (na,c,typ) =
+  let pbody = match c with
+    | None -> mt ()
+    | Some c ->
+	(* Force evaluation *) 
+	let pb = prterm_env env c in
+	(str":=" ++ spc () ++ pb ++ spc ()) in
+  let ptyp = prtype_env env typ in
+  match na with
+  | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
+  | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
+
+
+(* Prints out an "env" in a nice format.  We print out the
+ * signature,then a horizontal bar, then the debruijn environment.
+ * It's printed out from outermost to innermost, so it's readable. *)
+
+(* Prints a signature, all declarations on the same line if possible *)
+let pr_named_context_of env =
+  hv 0 (fold_named_context
+	  (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d)
+          env ~init:(mt ()))
+
+let pr_rel_context env rel_context =
+  let rec prec env = function
+    | [] -> (mt ()) 
+    | [b] -> 
+	if !Options.v7 then pr_rel_decl env b
+	else str "(" ++ pr_rel_decl env b ++ str")"
+    | b::rest ->
+        let pb = pr_rel_decl env b in
+        let penvtl = prec (push_rel b env) rest in
+	if !Options.v7 then
+          (pb ++ str";" ++ spc () ++ penvtl)
+	else 
+          (str "(" ++ pb ++ str")" ++ spc () ++ penvtl)
+  in 
+  hov 0 (prec env (List.rev rel_context))
+
+(* Prints an env (variables and de Bruijn). Separator: newline *)
+let pr_context_unlimited env =
+  let sign_env =
+    fold_named_context
+      (fun env d pps ->
+         let pidt =  pr_var_decl env d in (pps ++ fnl () ++ pidt))
+      env ~init:(mt ()) 
+  in
+  let db_env =
+    fold_rel_context
+      (fun env d pps ->
+         let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
+      env ~init:(mt ())
+  in 
+  (sign_env ++ db_env)
+
+let pr_ne_context_of header env =
+  if Environ.rel_context env = empty_rel_context &
+    Environ.named_context env = empty_named_context  then (mt ())
+  else let penv = pr_context_unlimited env in (header ++ penv ++ fnl ())
+
+let pr_context_limit n env =
+  let named_context = Environ.named_context env in
+  let lgsign = List.length named_context in
+  if n >= lgsign then 
+    pr_context_unlimited env
+  else
+    let k = lgsign-n in
+    let _,sign_env =
+      fold_named_context
+        (fun env d (i,pps) ->
+           if i < k then 
+	     (i+1, (pps ++str "."))
+	   else
+             let pidt = pr_var_decl env d in
+	     (i+1, (pps ++ fnl () ++
+		      str (emacs_str (String.make 1 (Char.chr 253))) ++
+		      pidt)))
+        env ~init:(0,(mt ())) 
+    in
+    let db_env =
+      fold_rel_context
+        (fun env d pps ->
+           let pnat = pr_rel_decl env d in
+	   (pps ++ fnl () ++
+	      str (emacs_str (String.make 1 (Char.chr 253))) ++
+	      pnat))
+        env ~init:(mt ())
+    in 
+    (sign_env ++ db_env)
+
+let pr_context_of env = match Options.print_hyps_limit () with 
+  | None -> hv 0 (pr_context_unlimited env)
+  | Some n -> hv 0 (pr_context_limit n env)
diff --git a/parsing/printer.mli b/parsing/printer.mli
new file mode 100644
index 00000000..b4cd87b0
--- /dev/null
+++ b/parsing/printer.mli
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  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: printer.mli,v 1.26.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Libnames
+open Term
+open Sign
+open Environ
+open Rawterm
+open Pattern
+open Nametab
+open Termops
+(*i*)
+
+(* These are the entry points for printing terms, context, tac, ... *)
+(*
+val gentacpr  : Tacexpr.raw_tactic_expr -> std_ppcmds
+*)
+
+val prterm_env      : env -> constr -> std_ppcmds
+val prterm_env_at_top : env -> constr -> std_ppcmds
+val prterm          : constr -> std_ppcmds
+val prtype_env      : env -> types -> std_ppcmds
+val prtype          : types -> std_ppcmds
+val prjudge_env     :
+  env -> Environ.unsafe_judgment -> std_ppcmds * std_ppcmds
+val prjudge         : Environ.unsafe_judgment -> std_ppcmds * std_ppcmds
+
+val pr_rawterm       : Rawterm.rawconstr -> std_ppcmds
+val pr_cases_pattern : Rawterm.cases_pattern -> std_ppcmds
+
+val pr_constant     : env -> constant -> std_ppcmds
+val pr_existential  : env -> existential -> std_ppcmds
+val pr_constructor  : env -> constructor -> std_ppcmds
+val pr_inductive    : env -> inductive -> std_ppcmds
+val pr_global       : global_reference -> std_ppcmds
+val pr_ref_label    : constr_label -> std_ppcmds
+val pr_pattern      : constr_pattern -> std_ppcmds
+val pr_pattern_env  : env -> names_context -> constr_pattern -> std_ppcmds
+
+val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds
+
+val pr_var_decl     : env -> named_declaration -> std_ppcmds
+val pr_rel_decl     : env -> rel_declaration -> std_ppcmds
+
+val pr_named_context_of : env -> std_ppcmds
+val pr_rel_context  : env -> rel_context -> std_ppcmds
+val pr_context_of   : env -> std_ppcmds
+
+val emacs_str       : string -> string
+
diff --git a/parsing/printmod.ml b/parsing/printmod.ml
new file mode 100644
index 00000000..aaf4a662
--- /dev/null
+++ b/parsing/printmod.ml
@@ -0,0 +1,133 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+open Pp
+open Util
+open Names
+open Declarations
+open Nameops
+open Libnames
+
+let get_new_id locals id = 
+  let rec get_id l id = 
+    let dir = make_dirpath [id] in
+      if not (Nametab.exists_module dir) then
+	id
+      else
+	get_id (id::l) (Nameops.next_ident_away id l)
+  in
+    get_id (List.map snd locals) id
+
+let rec print_local_modpath locals = function
+  | MPbound mbid -> pr_id (List.assoc mbid locals)
+  | MPdot(mp,l) ->
+      print_local_modpath locals mp ++ str "." ++ pr_lab l
+  | MPself _ | MPfile _ -> raise Not_found
+
+let print_modpath locals mp = 
+  try (* must be with let because streams are lazy! *)
+    let qid = Nametab.shortest_qualid_of_module mp in 
+      pr_qualid qid
+  with
+    | Not_found -> print_local_modpath locals mp
+
+let print_kn locals kn = 
+  try
+    let qid = Nametab.shortest_qualid_of_modtype kn in 
+      pr_qualid qid
+  with
+      Not_found -> 
+	let (mp,_,l) = repr_kn kn in
+	  print_local_modpath locals mp ++ str"." ++ pr_lab l
+
+let rec flatten_app mexpr l = match mexpr with
+  | MEBapply (mexpr,marg,_) -> flatten_app mexpr (marg::l)
+  | mexpr -> mexpr::l
+
+let rec print_module name locals with_body mb =
+  let body = match mb.mod_equiv, with_body, mb.mod_expr with 
+    | None, false, _ 
+    | None, true, None -> mt()
+    | None, true, Some mexpr -> 
+	spc () ++ str ":= " ++ print_modexpr locals mexpr
+    | Some mp, _, _ -> str " == " ++ print_modpath locals mp
+  in
+  hv 2 (str "Module " ++ name ++ spc () ++ str": " ++ 
+	print_modtype locals mb.mod_type ++ body)
+
+and print_modtype locals mty = match mty with
+  | MTBident kn -> print_kn locals kn
+  | MTBfunsig (mbid,mtb1,mtb2) ->
+(*    let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env 
+      in *) 
+      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
+      hov 2 (str "Funsig" ++ spc () ++ str "(" ++ 
+        pr_id (id_of_mbid mbid) ++ str " : " ++ print_modtype locals mtb1 ++ 
+      str ")" ++ spc() ++ print_modtype locals' mtb2)
+  | MTBsig (msid,sign) -> 
+      hv 2 (str "Sig" ++ spc () ++ print_sig locals msid sign ++ brk (1,-2) ++ str "End")
+
+and print_sig locals msid sign = 
+  let print_spec (l,spec) = (match spec with
+    | SPBconst {const_body=Some _; const_opaque=false} -> str "Definition "
+    | SPBconst {const_body=None}
+    | SPBconst {const_opaque=true} -> str "Parameter "
+    | SPBmind _ -> str "Inductive "
+    | SPBmodule _ -> str "Module "
+    | SPBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
+  in
+    prlist_with_sep spc print_spec sign
+
+and print_struct locals msid struc = 
+  let print_body (l,body) = (match body with
+    | SEBconst {const_body=Some _; const_opaque=false} -> str "Definition "
+    | SEBconst {const_body=Some _; const_opaque=true} -> str "Theorem "
+    | SEBconst {const_body=None} -> str "Parameter "
+    | SEBmind _ -> str "Inductive "
+    | SEBmodule _ -> str "Module "
+    | SEBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
+  in
+    prlist_with_sep spc print_body struc
+
+and print_modexpr locals mexpr = match mexpr with 
+  | MEBident mp -> print_modpath locals mp
+  | MEBfunctor (mbid,mty,mexpr) ->
+(*    let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env 
+      in *)
+      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
+      hov 2 (str "Functor" ++ spc() ++ str"[" ++ pr_id(id_of_mbid mbid) ++ 
+	     str ":" ++ print_modtype locals mty ++ 
+      str "]" ++ spc () ++ print_modexpr locals' mexpr)
+  | MEBstruct (msid, struc) -> 
+      hv 2 (str "Struct" ++ spc () ++ print_struct locals msid struc ++ brk (1,-2) ++ str "End")
+  | MEBapply (mexpr,marg,_) -> 
+      let lapp = flatten_app mexpr [marg] in
+	hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")")
+
+
+
+let rec printable_body dir =     
+  let dir = dirpath_prefix dir in
+    dir = empty_dirpath || 
+    try 
+      match Nametab.locate_dir (qualid_of_dirpath dir) with
+	  DirOpenModtype _ -> false
+	| DirModule _ | DirOpenModule _ -> printable_body dir
+	| _ -> true
+    with 
+	Not_found -> true
+
+
+let print_module with_body mp = 
+  let name = print_modpath [] mp in
+    print_module name [] with_body (Global.lookup_module mp) ++ fnl ()
+
+let print_modtype kn = 
+  let name = print_kn [] kn in
+    str "Module Type " ++ name ++ str " = " ++ 
+      print_modtype [] (Global.lookup_modtype kn) ++ fnl ()
diff --git a/parsing/printmod.mli b/parsing/printmod.mli
new file mode 100644
index 00000000..2df0581c
--- /dev/null
+++ b/parsing/printmod.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+open Pp
+open Names
+
+(* false iff the module is an element of an open module type *)
+val printable_body : dir_path -> bool
+
+val print_module : bool -> module_path -> std_ppcmds
+
+val print_modtype : kernel_name -> std_ppcmds
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
new file mode 100644
index 00000000..aa0fce9d
--- /dev/null
+++ b/parsing/q_coqast.ml4
@@ -0,0 +1,567 @@
+(************************************************************************)
+(*  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: q_coqast.ml4,v 1.47.2.2 2004/07/16 20:51:12 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+open Q_util
+
+let is_meta s = String.length s > 0 && s.[0] == '$'
+
+let purge_str s =
+  if String.length s == 0 || s.[0] <> '$' then s
+  else String.sub s 1 (String.length s - 1)
+
+let anti loc x =
+  let e =
+    let loc = unloc loc in
+    let loc = make_loc (1, snd loc - fst loc) in <:expr< $lid:purge_str x$ >>
+  in
+  <:expr< $anti:e$ >>
+
+(* [mlexpr_of_ast] contributes to translate g_*.ml4 files into g_*.ppo *)
+(* This is where $id's (and macros) in ast are translated in ML variables *)
+(* which will bind their actual ast value *)
+
+let rec mlexpr_of_ast = function
+  | Coqast.Nmeta (loc, id) -> anti loc id
+  | Coqast.Id (loc, id) when is_meta id -> <:expr< Coqast.Id loc $anti loc id$ >>
+  | Coqast.Node (_, "$VAR", [Coqast.Nmeta (loc, x)]) ->
+      <:expr< let s = $anti loc x$ in
+      if String.length s > 0 && String.sub s 0 1 = "$" then
+	failwith "Wrong ast: $VAR should not be bound to a meta variable"
+      else
+	Coqast.Nvar loc (Names.id_of_string s) >>
+  | Coqast.Node (_, "$PATH", [Coqast.Nmeta (loc, x)]) ->
+      <:expr< Coqast.Path loc $anti loc x$ >>
+  | Coqast.Node (_, "$ID", [Coqast.Nmeta (loc, x)]) ->
+      <:expr< Coqast.Id loc $anti loc x$ >>
+  | Coqast.Node (_, "$STR", [Coqast.Nmeta (loc, x)]) ->
+      <:expr< Coqast.Str loc $anti loc x$ >>
+(* Obsolète
+  | Coqast.Node _ "$SLAM" [Coqast.Nmeta loc idl; y] ->
+      <:expr<
+      List.fold_right (Pcoq.slam_ast loc) $anti loc idl$ $mlexpr_of_ast y$ >>
+*)
+  | Coqast.Node (loc, "$ABSTRACT", [Coqast.Str (_, s); x; y]) ->
+      let x = mlexpr_of_ast x in
+      let y = mlexpr_of_ast y in
+      <:expr< Ast.abstract_binders_ast loc $str:s$ $x$ $y$ >>
+  | Coqast.Node (loc, nn, al) ->
+      let e = expr_list_of_ast_list al in
+      <:expr< Coqast.Node loc $str:nn$ $e$ >>
+  | Coqast.Nvar (loc, id) ->
+      <:expr< Coqast.Nvar loc (Names.id_of_string $str:Names.string_of_id id$) >>
+  | Coqast.Slam (loc, None, a) ->
+      <:expr< Coqast.Slam loc None $mlexpr_of_ast a$ >>
+  | Coqast.Smetalam (loc, s, a) ->
+      <:expr< 
+      match $anti loc s$ with
+	[ Coqast.Nvar _ id -> Coqast.Slam loc (Some id) $mlexpr_of_ast a$
+	| Coqast.Nmeta _ s -> Coqast.Smetalam loc s $mlexpr_of_ast a$
+	| _ -> failwith "Slam expects a var or a metavar" ] >>
+  | Coqast.Slam (loc, Some s, a) ->
+      let se = <:expr< Names.id_of_string $str:Names.string_of_id s$ >> in
+      <:expr< Coqast.Slam loc (Some $se$) $mlexpr_of_ast a$ >>
+  | Coqast.Num (loc, i) -> <:expr< Coqast.Num loc $int:string_of_int i$ >>
+  | Coqast.Id (loc, id) -> <:expr< Coqast.Id loc $str:id$ >>
+  | Coqast.Str (loc, str) -> <:expr< Coqast.Str loc $str:str$ >>
+  | Coqast.Path (loc, kn) ->
+      let l,a = Libnames.decode_kn kn in
+      let mlexpr_of_modid id =
+	<:expr< Names.id_of_string $str:string_of_id id$ >> in
+      let e = List.map mlexpr_of_modid (repr_dirpath l) in
+      let e = expr_list_of_var_list e in
+      <:expr< Coqast.Path loc (Libnames.encode_kn (Names.make_dirpath $e$)
+                (Names.id_of_string $str:Names.string_of_id a$)) >> 
+  | Coqast.Dynamic (_, _) ->
+      failwith "Q_Coqast: dynamic: not implemented"
+
+and expr_list_of_ast_list al =
+  List.fold_right
+    (fun a e2 -> match a with
+       | (Coqast.Node (_, "$LIST", [Coqast.Nmeta (locv, pv)])) ->
+           let e1 = anti locv pv in
+           let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in
+	     if e2 = (let loc = dummy_loc in <:expr< [] >>)
+	     then <:expr< $e1$ >>
+	     else <:expr< ( $lid:"@"$ $e1$ $e2$) >>
+       | _ ->
+           let e1 = mlexpr_of_ast a in
+           let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in
+	   <:expr< [$e1$ :: $e2$] >> )
+    al (let loc = dummy_loc in <:expr< [] >>)
+
+and expr_list_of_var_list sl =
+  let loc = dummy_loc in
+  List.fold_right
+    (fun e1 e2 ->
+       let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in
+       <:expr< [$e1$ :: $e2$] >>)
+    sl <:expr< [] >>
+
+(* We don't give location for tactic quotation! *)
+let loc = dummy_loc
+
+let dloc = <:expr< Util.dummy_loc >>
+
+let mlexpr_of_ident id =
+  <:expr< Names.id_of_string $str:Names.string_of_id id$ >>
+
+let mlexpr_of_name = function
+  | Names.Anonymous -> <:expr< Names.Anonymous >>
+  | Names.Name id -> 
+      <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >>
+
+let mlexpr_of_dirpath dir =
+  let l = Names.repr_dirpath dir in
+  <:expr< Names.make_dirpath $mlexpr_of_list mlexpr_of_ident l$ >>
+
+let mlexpr_of_qualid qid =
+  let (dir, id) = repr_qualid qid in
+  <:expr< make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >>
+
+let mlexpr_of_reference = function
+  | Libnames.Qualid (loc,qid) -> <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >>
+  | Libnames.Ident (loc,id) -> <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >>
+
+let mlexpr_of_intro_pattern = function
+  | Genarg.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO"
+  | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >>
+  | Genarg.IntroIdentifier id ->
+      <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
+
+let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident)
+
+let mlexpr_of_or_metaid f = function
+  | Tacexpr.AI a -> <:expr< Tacexpr.AI $f a$ >>
+  | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >>
+
+let mlexpr_of_quantified_hypothesis = function
+  | Rawterm.AnonHyp n -> <:expr< Rawterm.AnonHyp $mlexpr_of_int n$ >>
+  | Rawterm.NamedHyp id ->  <:expr< Rawterm.NamedHyp $mlexpr_of_ident id$ >>
+
+let mlexpr_of_located f (loc,x) = <:expr< ($dloc$, $f x$) >>
+
+let mlexpr_of_loc loc = <:expr< $dloc$ >>
+
+let mlexpr_of_or_var f = function
+  | Genarg.ArgArg x -> <:expr< Genarg.ArgArg $f x$ >>
+  | Genarg.ArgVar id -> <:expr< Genarg.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
+
+let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident)
+
+let mlexpr_of_occs = mlexpr_of_list mlexpr_of_int
+
+let mlexpr_of_hyp_location = function
+  | id, occs, (Tacexpr.InHyp,_) ->
+      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHyp, ref None)) >>
+  | id, occs, (Tacexpr.InHypTypeOnly,_) ->
+      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypTypeOnly, ref None)) >>
+  | id, occs, (Tacexpr.InHypValueOnly,_) ->
+      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypValueOnly,ref None)) >>
+
+let mlexpr_of_clause cl =
+  <:expr< {Tacexpr.onhyps=
+             $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location)
+               cl.Tacexpr.onhyps$;
+           Tacexpr.onconcl= $mlexpr_of_bool cl.Tacexpr.onconcl$;
+           Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >>
+
+(*
+let mlexpr_of_red_mode = function
+  | Closure.UNIFORM -> <:expr< Closure.UNIFORM >>
+  | Closure.SIMPL -> <:expr< Closure.SIMPL >>
+  | Closure.WITHBACK -> <:expr< Closure.WITHBACK >>
+*)
+
+let mlexpr_of_red_flags {
+  Rawterm.rBeta = bb;
+  Rawterm.rIota = bi;
+  Rawterm.rZeta = bz;
+  Rawterm.rDelta = bd;
+  Rawterm.rConst = l
+} = <:expr< {
+  Rawterm.rBeta = $mlexpr_of_bool bb$;
+  Rawterm.rIota = $mlexpr_of_bool bi$;
+  Rawterm.rZeta = $mlexpr_of_bool bz$;
+  Rawterm.rDelta = $mlexpr_of_bool bd$;
+  Rawterm.rConst = $mlexpr_of_list mlexpr_of_reference l$
+} >>
+
+let mlexpr_of_explicitation = function
+  | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >>
+  | Topconstr.ExplByPos n -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >>
+ 
+let rec mlexpr_of_constr = function
+  | Topconstr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) ->
+      anti loc (string_of_id id)
+  | Topconstr.CRef r -> <:expr< Topconstr.CRef $mlexpr_of_reference r$ >>
+  | Topconstr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.CArrow (loc,a,b) ->
+  <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >>
+  | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
+  | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
+  | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >>
+  | Topconstr.CCases (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.COrderedCase (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.CHole loc -> <:expr< Topconstr.CHole $dloc$ >>
+  | Topconstr.CNotation(_,ntn,l) ->
+      <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$
+                $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Topconstr.CPatVar (loc,n) -> 
+      <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >>
+  | _ -> failwith "mlexpr_of_constr: TODO"
+
+let mlexpr_of_occ_constr =
+  mlexpr_of_pair (mlexpr_of_list mlexpr_of_int) mlexpr_of_constr
+
+let mlexpr_of_red_expr = function
+  | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >>
+  | Rawterm.Hnf -> <:expr< Rawterm.Hnf >>
+  | Rawterm.Simpl o -> <:expr< Rawterm.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >>
+  | Rawterm.Cbv f ->
+      <:expr< Rawterm.Cbv $mlexpr_of_red_flags f$ >>
+  | Rawterm.Lazy f ->
+      <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >>
+  | Rawterm.Unfold l ->
+      let f1 = mlexpr_of_list mlexpr_of_int in
+      let f2 = mlexpr_of_reference in
+      let f = mlexpr_of_list (mlexpr_of_pair f1 f2) in
+      <:expr< Rawterm.Unfold $f l$ >>
+  | Rawterm.Fold l ->
+      <:expr< Rawterm.Fold $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Rawterm.Pattern l ->
+      let f = mlexpr_of_list mlexpr_of_occ_constr in
+      <:expr< Rawterm.Pattern $f l$ >>
+  | Rawterm.ExtraRedExpr (s,c) ->
+      let l = mlexpr_of_constr c in
+      <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ $l$ >>
+
+let rec mlexpr_of_argtype loc = function
+  | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >>
+  | Genarg.IntArgType -> <:expr< Genarg.IntArgType >>
+  | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >>
+  | Genarg.RefArgType -> <:expr< Genarg.RefArgType >>
+  | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >>
+  | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >>
+  | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >>
+  | Genarg.HypArgType -> <:expr< Genarg.HypArgType >>
+  | Genarg.StringArgType -> <:expr< Genarg.StringArgType >>
+  | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >>
+  | Genarg.CastedOpenConstrArgType -> <:expr< Genarg.CastedOpenConstrArgType >>
+  | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >>
+  | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >>
+  | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >>
+  | Genarg.TacticArgType -> <:expr< Genarg.TacticArgType >>
+  | Genarg.SortArgType -> <:expr< Genarg.SortArgType >>
+  | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >>
+  | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >>
+  | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.PairArgType (t1,t2) -> 
+      let t1 = mlexpr_of_argtype loc t1 in
+      let t2 = mlexpr_of_argtype loc t2 in
+      <:expr< Genarg.PairArgType $t1$ $t2$ >>
+  | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >>
+
+let rec mlexpr_of_may_eval f = function
+  | Rawterm.ConstrEval (r,c) ->
+      <:expr< Rawterm.ConstrEval $mlexpr_of_red_expr r$ $f c$ >>
+  | Rawterm.ConstrContext ((loc,id),c) ->
+      let id = mlexpr_of_ident id in
+      <:expr< Rawterm.ConstrContext (loc,$id$) $f c$ >>
+  | Rawterm.ConstrTypeOf c ->
+      <:expr< Rawterm.ConstrTypeOf $mlexpr_of_constr c$ >>
+  | Rawterm.ConstrTerm c ->
+      <:expr< Rawterm.ConstrTerm $mlexpr_of_constr c$ >>
+
+let mlexpr_of_binding_kind = function
+  | Rawterm.ExplicitBindings l ->
+      let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in
+      <:expr< Rawterm.ExplicitBindings $l$ >>
+  | Rawterm.ImplicitBindings l -> 
+      let l = mlexpr_of_list mlexpr_of_constr l in
+      <:expr< Rawterm.ImplicitBindings $l$ >>
+  | Rawterm.NoBindings -> 
+       <:expr< Rawterm.NoBindings >>
+
+let mlexpr_of_induction_arg = function
+  | Tacexpr.ElimOnConstr c ->
+      <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr c$ >>
+  | Tacexpr.ElimOnIdent (_,id) -> 
+      <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >>
+  | Tacexpr.ElimOnAnonHyp n ->
+      <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >>
+
+let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr
+
+let mlexpr_of_constr_with_binding =
+  mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind
+
+let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO"
+
+let mlexpr_of_pattern_ast = mlexpr_of_constr
+
+let mlexpr_of_entry_type = function
+    _ -> failwith "mlexpr_of_entry_type: TODO"
+
+let mlexpr_of_match_pattern = function
+  | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >>
+  | Tacexpr.Subterm (ido,t) ->
+      <:expr< Tacexpr.Subterm $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >>
+
+let mlexpr_of_match_context_hyps = function
+  | Tacexpr.Hyp (id,l) ->
+      let f = mlexpr_of_located mlexpr_of_name in
+      <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >>
+
+let mlexpr_of_match_rule f = function
+  | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >>
+  | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >>
+
+let rec mlexpr_of_atomic_tactic = function
+  (* Basic tactics *)
+  | Tacexpr.TacIntroPattern pl ->
+      let pl = mlexpr_of_list mlexpr_of_intro_pattern pl in
+      <:expr< Tacexpr.TacIntroPattern $pl$ >>
+  | Tacexpr.TacIntrosUntil h ->
+      <:expr< Tacexpr.TacIntrosUntil $mlexpr_of_quantified_hypothesis h$ >>
+  | Tacexpr.TacIntroMove (idopt,idopt') ->
+      let idopt = mlexpr_of_ident_option idopt in
+      let idopt'=mlexpr_of_option (mlexpr_of_located mlexpr_of_ident) idopt' in
+      <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >>
+  | Tacexpr.TacAssumption ->
+      <:expr< Tacexpr.TacAssumption >>
+  | Tacexpr.TacExact c ->
+      <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >>
+  | Tacexpr.TacApply cb ->
+      <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >>
+  | Tacexpr.TacElim (cb,cbo) ->
+      let cb = mlexpr_of_constr_with_binding cb in
+      let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
+      <:expr< Tacexpr.TacElim $cb$ $cbo$ >>
+  | Tacexpr.TacElimType c ->
+      <:expr< Tacexpr.TacElimType $mlexpr_of_constr c$ >>
+  | Tacexpr.TacCase cb ->
+      let cb = mlexpr_of_constr_with_binding cb in
+      <:expr< Tacexpr.TacCase $cb$ >>
+  | Tacexpr.TacCaseType c ->
+      <:expr< Tacexpr.TacCaseType $mlexpr_of_constr c$ >>
+  | Tacexpr.TacFix (ido,n) ->
+      let ido = mlexpr_of_ident_option ido in
+      let n = mlexpr_of_int n in
+      <:expr< Tacexpr.TacFix $ido$ $n$ >>
+  | Tacexpr.TacMutualFix (id,n,l) ->
+      let id = mlexpr_of_ident id in
+      let n = mlexpr_of_int n in
+      let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in
+      let l = mlexpr_of_list f l in
+      <:expr< Tacexpr.TacMutualFix $id$ $n$ $l$ >>
+  | Tacexpr.TacCofix ido ->
+      let ido = mlexpr_of_ident_option ido in
+      <:expr< Tacexpr.TacCofix $ido$ >>
+  | Tacexpr.TacMutualCofix (id,l) ->
+      let id = mlexpr_of_ident id in
+      let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in
+      let l = mlexpr_of_list f l in
+      <:expr< Tacexpr.TacMutualCofix $id$ $l$ >>
+
+  | Tacexpr.TacCut c ->
+      <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >>
+  | Tacexpr.TacTrueCut (na,c) ->
+      let na = mlexpr_of_name na in
+      <:expr< Tacexpr.TacTrueCut $na$ $mlexpr_of_constr c$ >>
+  | Tacexpr.TacForward (b,na,c) ->
+      <:expr< Tacexpr.TacForward $mlexpr_of_bool b$ $mlexpr_of_name na$ $mlexpr_of_constr c$ >>
+  | Tacexpr.TacGeneralize cl ->
+      <:expr< Tacexpr.TacGeneralize $mlexpr_of_list mlexpr_of_constr cl$ >>
+  | Tacexpr.TacGeneralizeDep c ->
+      <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >>
+  | Tacexpr.TacLetTac (na,c,cl) ->
+      let na = mlexpr_of_name na in
+      let cl = mlexpr_of_clause_pattern cl in
+      <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ >>
+
+  (* Derived basic tactics *)
+  | Tacexpr.TacSimpleInduction (h,_) ->
+      <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$,ref []) >>
+  | Tacexpr.TacNewInduction (c,cbo,ids) ->
+      let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
+      let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in
+      <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref [])>>
+  | Tacexpr.TacSimpleDestruct h ->
+      <:expr< Tacexpr.TacSimpleDestruct $mlexpr_of_quantified_hypothesis h$ >>
+  | Tacexpr.TacNewDestruct (c,cbo,ids) ->
+      let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
+      let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in
+      <:expr< Tacexpr.TacNewDestruct $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref []) >>
+
+  (* Context management *)
+  | Tacexpr.TacClear l ->
+      let l = mlexpr_of_list (mlexpr_of_hyp) l in
+      <:expr< Tacexpr.TacClear $l$ >>
+  | Tacexpr.TacClearBody l ->
+      let l = mlexpr_of_list (mlexpr_of_hyp) l in
+      <:expr< Tacexpr.TacClearBody $l$ >>
+  | Tacexpr.TacMove (dep,id1,id2) ->
+      <:expr< Tacexpr.TacMove $mlexpr_of_bool dep$
+              $mlexpr_of_hyp id1$
+              $mlexpr_of_hyp id2$ >>
+
+  (* Constructors *)
+  | Tacexpr.TacLeft l ->
+      <:expr< Tacexpr.TacLeft $mlexpr_of_binding_kind l$>>
+  | Tacexpr.TacRight l ->
+      <:expr< Tacexpr.TacRight $mlexpr_of_binding_kind l$>>
+  | Tacexpr.TacSplit (b,l) ->
+      <:expr< Tacexpr.TacSplit
+        ($mlexpr_of_bool b$,$mlexpr_of_binding_kind l$)>>
+  | Tacexpr.TacAnyConstructor t ->
+      <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_option mlexpr_of_tactic t$>>
+  | Tacexpr.TacConstructor (n,l) ->
+      let n = mlexpr_of_or_metaid mlexpr_of_int n in
+      <:expr< Tacexpr.TacConstructor $n$ $mlexpr_of_binding_kind l$>>
+
+  (* Conversion *)
+  | Tacexpr.TacReduce (r,cl) ->
+      let l = mlexpr_of_clause cl in
+      <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >>
+  | Tacexpr.TacChange (occl,c,cl) ->
+      let l = mlexpr_of_clause cl in
+      let g = mlexpr_of_option mlexpr_of_occ_constr in
+      <:expr< Tacexpr.TacChange $g occl$ $mlexpr_of_constr c$ $l$ >>
+
+  (* Equivalence relations *)
+  | Tacexpr.TacReflexivity -> <:expr< Tacexpr.TacReflexivity >>
+  | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >>
+  | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_constr c$ >>
+
+  (* Automation tactics *)
+  | Tacexpr.TacAuto (n,l) ->
+      let n = mlexpr_of_option mlexpr_of_int n in
+      let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
+      <:expr< Tacexpr.TacAuto $n$ $l$ >>
+(*
+  | Tacexpr.TacTrivial l ->
+      let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
+      <:expr< Tacexpr.TacTrivial $l$ >>
+*)
+
+(*
+  | Tacexpr.TacExtend (s,l) ->
+      let l = mlexpr_of_list mlexpr_of_tactic_arg l in
+      let $dloc$ = MLast.loc_of_expr l in
+      <:expr< Tacexpr.TacExtend $mlexpr_of_string s$ $l$ >>
+*)
+  | _ -> failwith "Quotation of atomic tactic expressions: TODO"
+
+and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
+  | Tacexpr.TacAtom (loc,t) ->
+      <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >>
+  | Tacexpr.TacThen (t1,t2) -> 
+      <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
+  | Tacexpr.TacThens (t,tl) ->
+      <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>>
+  | Tacexpr.TacFirst tl ->
+      <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >>
+  | Tacexpr.TacSolve tl ->
+      <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >>
+  | Tacexpr.TacTry t ->
+      <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacOrelse (t1,t2) ->
+      <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
+  | Tacexpr.TacDo (n,t) ->
+      <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacRepeat t ->
+      <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacProgress t ->
+      <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacId s -> <:expr< Tacexpr.TacId $str:s$ >>
+  | Tacexpr.TacFail (n,s) -> <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $str:s$ >>
+(*
+  | Tacexpr.TacInfo t -> TacInfo (loc,f t)
+
+  | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t)))
+  | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t)
+*)
+  | Tacexpr.TacLetIn (l,t) ->
+      let f =
+	mlexpr_of_triple
+	  (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident)
+	  (mlexpr_of_option mlexpr_of_tactic)
+	  mlexpr_of_tactic_arg in
+      <:expr< Tacexpr.TacLetIn $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacMatch (t,l) ->
+      <:expr< Tacexpr.TacMatch
+        $mlexpr_of_tactic t$
+        $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
+  | Tacexpr.TacMatchContext (lr,l) ->
+      <:expr< Tacexpr.TacMatchContext 
+        $mlexpr_of_bool lr$
+        $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
+(*
+  | Tacexpr.TacFun of $dloc$ * tactic_fun_ast
+  | Tacexpr.TacFunRec of $dloc$ * identifier * tactic_fun_ast
+*)
+(*
+  | Tacexpr.TacArg (Tacexpr.AstTacArg (Coqast.Nmeta $dloc$ id)) -> anti loc id
+*)
+  | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,id)) -> anti loc id
+  | Tacexpr.TacArg t ->
+      <:expr< Tacexpr.TacArg $mlexpr_of_tactic_arg t$ >>
+  | _ -> failwith "Quotation of tactic expressions: TODO"
+
+and mlexpr_of_tactic_arg = function
+  | Tacexpr.MetaIdArg (loc,id) -> anti loc id
+  | Tacexpr.TacCall (loc,t,tl) ->
+      <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>>
+  | Tacexpr.Tacexp t ->
+      <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >>
+  | Tacexpr.ConstrMayEval c ->
+      <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >>
+  | Tacexpr.Reference r ->
+      <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >>
+  | _ -> failwith "mlexpr_of_tactic_arg: TODO"
+
+let f e =
+  let ee s =
+    mlexpr_of_ast (Pcoq.Gram.Entry.parse e
+                     (Pcoq.Gram.parsable (Stream.of_string s)))
+  in
+  let ep s = patt_of_expr (ee s) in
+  Quotation.ExAst (ee, ep)
+
+let fconstr e =
+  let ee s =
+    mlexpr_of_constr (Pcoq.Gram.Entry.parse e
+                     (Pcoq.Gram.parsable (Stream.of_string s)))
+  in
+  let ep s = patt_of_expr (ee s) in
+  Quotation.ExAst (ee, ep)
+
+let ftac e =
+  let ee s =
+    mlexpr_of_tactic (Pcoq.Gram.Entry.parse e
+                     (Pcoq.Gram.parsable (Stream.of_string s)))
+  in
+  let ep s = patt_of_expr (ee s) in
+  Quotation.ExAst (ee, ep)
+
+let _ = 
+  Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi);
+  Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi);
+(*  Quotation.add "vernac" (f Pcoq.Vernac_.vernac_eoi);*)
+(*  Quotation.add "ast" (f Pcoq.Prim.ast_eoi);*)
+  Quotation.default := "constr"
diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4
new file mode 100644
index 00000000..b3f5393c
--- /dev/null
+++ b/parsing/q_util.ml4
@@ -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        *)
+(************************************************************************)
+
+(* $Id: q_util.ml4,v 1.2.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+
+(* This file defines standard combinators to build ml expressions *)
+
+open Util
+
+let not_impl name x =
+  let desc =
+    if Obj.is_block (Obj.repr x) then
+      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
+    else 
+      "int_val = " ^ string_of_int (Obj.magic x)
+  in
+  failwith ("<Q_util." ^ name ^ ", not impl: " ^ desc)
+
+let rec patt_of_expr e =
+  let loc = MLast.loc_of_expr e in
+  match e with
+    | <:expr< $e1$.$e2$ >> -> <:patt< $patt_of_expr e1$.$patt_of_expr e2$ >>
+    | <:expr< $e1$ $e2$ >> -> <:patt< $patt_of_expr e1$ $patt_of_expr e2$ >>
+    | <:expr< loc >> -> <:patt< _ >>
+    | <:expr< $lid:s$ >> -> <:patt< $lid:s$ >>
+    | <:expr< $uid:s$ >> -> <:patt< $uid:s$ >>
+    | <:expr< $str:s$ >> -> <:patt< $str:s$ >>
+    | <:expr< $anti:e$ >> -> <:patt< $anti:patt_of_expr e$ >>
+    | _ -> not_impl "patt_of_expr" e
+
+let mlexpr_of_list f l =
+  List.fold_right
+    (fun e1 e2 ->
+      let e1 = f e1 in
+       let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in
+       <:expr< [$e1$ :: $e2$] >>)
+    l (let loc = dummy_loc in <:expr< [] >>)
+
+let mlexpr_of_pair m1 m2 (a1,a2) =
+  let e1 = m1 a1 and e2 = m2 a2 in
+  let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in
+  <:expr< ($e1$, $e2$) >>
+
+let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)=
+  let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 in
+  let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e3)) in
+  <:expr< ($e1$, $e2$, $e3$) >>
+
+(* We don't give location for tactic quotation! *)
+let loc = dummy_loc
+
+
+let mlexpr_of_bool = function
+  | true -> <:expr< True >>
+  | false -> <:expr< False >>
+
+let mlexpr_of_int n = <:expr< $int:string_of_int n$ >>
+
+let mlexpr_of_string s = <:expr< $str:s$ >>
+
+let mlexpr_of_option f = function
+  | None -> <:expr< None >>
+  | Some e -> <:expr< Some $f e$ >>
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
new file mode 100644
index 00000000..a2c22bc3
--- /dev/null
+++ b/parsing/q_util.mli
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  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: q_util.mli,v 1.2.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+
+val patt_of_expr : MLast.expr -> MLast.patt
+
+val mlexpr_of_list :  ('a -> MLast.expr) -> 'a list -> MLast.expr
+
+val mlexpr_of_pair :
+  ('a -> MLast.expr) -> ('b -> MLast.expr)
+    -> 'a * 'b -> MLast.expr
+
+val mlexpr_of_triple :
+  ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr)
+    -> 'a * 'b * 'c -> MLast.expr
+
+val mlexpr_of_bool : bool -> MLast.expr
+
+val mlexpr_of_int : int -> MLast.expr
+
+val mlexpr_of_string : string -> MLast.expr
+
+val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
+
diff --git a/parsing/search.ml b/parsing/search.ml
new file mode 100644
index 00000000..a3d6e000
--- /dev/null
+++ b/parsing/search.ml
@@ -0,0 +1,224 @@
+(************************************************************************)
+(*  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: search.ml,v 1.30.2.1 2004/07/16 19:30:41 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Rawterm
+open Declarations
+open Libobject
+open Declare
+open Coqast
+open Environ
+open Pattern
+open Matching
+open Printer
+open Libnames
+open Nametab
+
+(* The functions print_constructors and crible implement the behavior needed
+   for the Coq searching commands.
+   These functions take as first argument the procedure
+   that will be called to treat each entry.  This procedure receives the name
+   of the object, the assumptions that will make it possible to print its type,
+   and the constr term that represent its type. *)
+
+let print_constructors indsp fn env nconstr =
+  for i = 1 to nconstr do
+    fn (ConstructRef (indsp,i)) env (Inductive.type_of_constructor env (indsp,i))
+  done
+
+let rec head_const c = match kind_of_term c with
+  | Prod (_,_,d) -> head_const d
+  | LetIn (_,_,_,d) -> head_const d
+  | App (f,_)   -> head_const f
+  | Cast (d,_)   -> head_const d
+  | _            -> c
+
+(* General search, restricted to head constant if [only_head] *)
+
+let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
+  let env = Global.env () in
+  let imported = Library.opened_libraries() in
+  let crible_rec (sp,_) lobj = match object_tag lobj with
+    | "VARIABLE" ->
+	(try 
+	   let (idc,_,typ) = get_variable (basename sp) in 
+           if refopt = None
+	     || head_const typ = constr_of_reference (out_some refopt)
+	   then
+	     fn (VarRef idc) env typ
+	 with Not_found -> (* we are in a section *) ())
+    | "CONSTANT" ->
+	let kn = locate_constant (qualid_of_sp sp) in
+	let {const_type=typ} = Global.lookup_constant kn in
+        if refopt = None
+	  || head_const typ = constr_of_reference (out_some refopt)
+	then
+	  fn (ConstRef kn) env typ
+    | "INDUCTIVE" -> 
+	let kn = locate_mind (qualid_of_sp sp) in
+        let mib = Global.lookup_mind kn in 
+        (match refopt with 
+	  | Some (IndRef ((kn',tyi) as ind)) when kn=kn' ->
+	      print_constructors ind fn env
+	        (Array.length (mib.mind_packets.(tyi).mind_user_lc))
+          | Some _ -> ()
+	  | _ ->
+              Array.iteri 
+	        (fun i mip -> print_constructors (kn,i) fn env
+	          (Array.length mip.mind_user_lc)) mib.mind_packets)
+    | _ -> ()
+  in 
+  try 
+    Declaremods.iter_all_segments false crible_rec
+  with Not_found -> 
+    ()
+
+let crible ref = gen_crible (Some ref)
+
+(* Fine Search. By Yves Bertot. *)
+
+exception No_section_path
+
+let rec head c = 
+  let c = strip_outer_cast c in
+  match kind_of_term c with
+  | Prod (_,_,c) -> head c
+  | LetIn (_,_,_,c) -> head c
+  | _              -> c
+      
+let constr_to_section_path c = match kind_of_term c with
+  | Const sp -> sp
+  | _ -> raise No_section_path
+      
+let xor a b = (a or b) & (not (a & b))
+
+let plain_display ref a c =
+  let pc = prterm_env a c in
+  let pr = pr_global ref in
+  msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ())
+
+let filter_by_module (module_list:dir_path list) (accept:bool) 
+  (ref:global_reference) _ _ =
+  try
+    let sp = sp_of_global ref in
+    let sl = dirpath sp in
+    let rec filter_aux = function
+      | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl)
+      | [] -> true 
+    in
+    xor accept (filter_aux module_list)
+  with No_section_path -> 
+    false
+
+let gref_eq =
+  IndRef (Libnames.encode_kn Coqlib.logic_module (id_of_string "eq"), 0)
+let gref_eqT =
+  IndRef (Libnames.encode_kn Coqlib.logic_type_module (id_of_string "eqT"), 0)
+
+let mk_rewrite_pattern1 eq pattern =
+  PApp (PRef eq, [| PMeta None; pattern; PMeta None |])
+
+let mk_rewrite_pattern2 eq pattern =
+  PApp (PRef eq, [| PMeta None; PMeta None; pattern |])
+
+let pattern_filter pat _ a c =
+  try 
+    try
+      is_matching pat (head c) 
+    with _ -> 
+      is_matching
+	pat (head (Typing.type_of (Global.env()) Evd.empty c))
+    with UserError _ -> 
+      false
+
+let filtered_search filter_function display_function ref =
+  crible ref
+    (fun s a c -> if filter_function s a c then display_function s a c) 
+
+let rec id_from_pattern = function
+  | PRef gr -> gr
+(* should be appear as a PRef (VarRef sp) !!
+  | PVar id -> Nametab.locate (make_qualid [] (string_of_id id))
+ *)
+  | PApp (p,_) -> id_from_pattern p
+  | _ -> error "the pattern is not simple enough"
+	
+let raw_pattern_search extra_filter display_function pat =
+  let name = id_from_pattern pat in
+  filtered_search 
+    (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) 
+    display_function name
+
+let raw_search_rewrite extra_filter display_function pattern =
+  filtered_search
+    (fun s a c ->
+       ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) ||
+        (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) 
+       && extra_filter s a c)
+    display_function gref_eq
+(*
+  ;
+  filtered_search
+    (fun s a c ->
+       ((pattern_filter (mk_rewrite_pattern1 gref_eqT pattern) s a c) ||
+        (pattern_filter (mk_rewrite_pattern2 gref_eqT pattern) s a c)) 
+       && extra_filter s a c)
+    display_function gref_eqT
+*)
+
+let text_pattern_search extra_filter =
+  raw_pattern_search extra_filter plain_display
+    
+let text_search_rewrite extra_filter =
+  raw_search_rewrite extra_filter plain_display
+
+let filter_by_module_from_list = function
+  | [], _ -> (fun _ _ _ -> true)
+  | l, outside -> filter_by_module l (not outside)
+
+let search_by_head ref inout = 
+  filtered_search (filter_by_module_from_list inout) plain_display ref
+
+let search_rewrite pat inout =
+  text_search_rewrite (filter_by_module_from_list inout) pat
+
+let search_pattern pat inout =
+  text_pattern_search (filter_by_module_from_list inout) pat
+
+
+let gen_filtered_search filter_function display_function =
+  gen_crible None
+    (fun s a c -> if filter_function s a c then display_function s a c) 
+
+(** SearchAbout *)
+
+let name_of_reference ref = string_of_id (id_of_global ref)
+
+type glob_search_about_item =
+  | GlobSearchRef of global_reference
+  | GlobSearchString of string
+
+let search_about_item (itemref,typ) = function
+  | GlobSearchRef ref -> Termops.occur_term (constr_of_reference ref) typ
+  | GlobSearchString s -> string_string_contains (name_of_reference itemref) s
+
+let raw_search_about filter_modules display_function l =
+  let filter ref' env typ =
+    filter_modules ref' env typ &&
+    List.for_all (search_about_item (ref',typ)) l
+  in
+  gen_filtered_search filter display_function
+
+let search_about ref inout = 
+  raw_search_about (filter_by_module_from_list inout) plain_display ref
diff --git a/parsing/search.mli b/parsing/search.mli
new file mode 100644
index 00000000..62ba865d
--- /dev/null
+++ b/parsing/search.mli
@@ -0,0 +1,49 @@
+(************************************************************************)
+(*  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: search.mli,v 1.16.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+
+open Pp
+open Names
+open Term
+open Environ
+open Pattern
+open Libnames
+open Nametab
+
+(*s Search facilities. *)
+
+type glob_search_about_item =
+  | GlobSearchRef of global_reference
+  | GlobSearchString of string
+
+val search_by_head : global_reference -> dir_path list * bool -> unit
+val search_rewrite : constr_pattern -> dir_path list * bool -> unit
+val search_pattern : constr_pattern -> dir_path list * bool -> unit
+val search_about  : glob_search_about_item list -> dir_path list * bool -> unit
+
+(* The filtering function that is by standard search facilities.
+   It can be passed as argument to the raw search functions.
+   It is used in pcoq. *)
+
+val filter_by_module_from_list :
+  dir_path list * bool -> global_reference -> env -> 'a -> bool
+
+(* raw search functions can be used for various extensions.
+   They are also used for pcoq. *)
+val gen_filtered_search : (global_reference -> env -> constr -> bool) ->
+      (global_reference -> env -> constr -> unit) -> unit
+val filtered_search : (global_reference -> env -> constr -> bool) -> 
+  (global_reference -> env -> constr -> unit) -> global_reference -> unit
+val raw_pattern_search : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
+val raw_search_rewrite : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
+val raw_search_about : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> 
+      glob_search_about_item list -> unit
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
new file mode 100644
index 00000000..bbacd013
--- /dev/null
+++ b/parsing/tacextend.ml4
@@ -0,0 +1,283 @@
+(************************************************************************)
+(*  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: tacextend.ml4,v 1.10.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+
+open Genarg
+open Q_util
+open Q_coqast
+open Argextend
+
+let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
+let loc = Util.dummy_loc
+let default_loc = <:expr< Util.dummy_loc >>
+
+type grammar_tactic_production_expr =
+  | TacTerm of string
+  | TacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option
+
+let rec make_patt = function
+  | [] -> <:patt< [] >>
+  | TacNonTerm(loc',_,_,Some p)::l ->
+      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
+  | _::l -> make_patt l
+
+let rec make_when loc = function
+  | [] -> <:expr< True >>
+  | TacNonTerm(loc',t,_,Some p)::l ->
+      let l = make_when loc l in
+      let loc = join_loc loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
+  | _::l -> make_when loc l
+
+let rec make_let e = function
+  | [] -> e
+  | TacNonTerm(loc,t,_,Some p)::l ->
+      let loc = join_loc loc (MLast.loc_of_expr e) in
+      let e = make_let e l in
+      let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in
+      let v = 
+        (* Special case for tactics which must be stored in algebraic
+           form to avoid marshalling closures and to be reprinted *)
+        if t = TacticArgType then
+          <:expr< ($v$, Tacinterp.eval_tactic $v$) >>
+        else v in
+      <:expr< let $lid:p$ = $v$ in $e$ >>
+  | _::l -> make_let e l
+
+let add_clause s (_,pt,e) l =
+  let p = make_patt pt in
+  let w = Some (make_when (MLast.loc_of_expr e) pt) in
+  (p, w, make_let e pt)::l
+
+let rec extract_signature = function
+  | [] -> []
+  | TacNonTerm (_,t,_,_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+let check_unicity s l =
+  let l' = List.map (fun (_,l,_) -> extract_signature l) l in
+  if not (Util.list_distinct l') then
+    Pp.warning_with Pp_control.err_ft
+      ("Two distinct rules of tactic entry "^s^" have the same\n"^
+      "non-terminals in the same order: put them in distinct tactic entries")
+
+let make_clauses s l =
+  check_unicity s l;
+  let default =
+    (<:patt< _ >>,None,<:expr< failwith "Tactic extension: cannot occur" >>) in
+  List.fold_right (add_clause s) l [default]
+
+let rec make_args = function
+  | [] -> <:expr< [] >>
+  | TacNonTerm(loc,t,_,Some p)::l ->
+      <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >>
+  | _::l -> make_args l
+
+let rec make_eval_tactic e = function
+  | [] -> e
+  | TacNonTerm(loc,TacticArgType,_,Some p)::l ->
+      let loc = join_loc loc (MLast.loc_of_expr e) in
+      let e = make_eval_tactic e l in
+        (* Special case for tactics which must be stored in algebraic
+           form to avoid marshalling closures and to be reprinted *)
+      <:expr< let $lid:p$ = ($lid:p$,Tacinterp.eval_tactic $lid:p$) in $e$ >>
+  | _::l -> make_eval_tactic e l
+
+let rec make_fun e = function
+  | [] -> e
+  | TacNonTerm(loc,_,_,Some p)::l -> 
+      <:expr< fun $lid:p$ -> $make_fun e l$ >>
+  | _::l -> make_fun e l
+
+let mlexpr_of_grammar_production = function
+  | TacTerm s ->
+      <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >>
+  | TacNonTerm (loc,nt,g,sopt) ->
+      <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >>
+
+let mlexpr_terminals_of_grammar_production = function
+  | TacTerm s -> <:expr< Some $mlexpr_of_string s$ >>
+  | TacNonTerm (loc,nt,g,sopt) -> <:expr< None >>
+
+let mlexpr_of_semi_clause =
+  mlexpr_of_pair mlexpr_of_string (mlexpr_of_list mlexpr_of_grammar_production)
+
+let mlexpr_of_clause =
+  mlexpr_of_list (fun (a,b,c) -> mlexpr_of_semi_clause (a,b))
+
+let rec make_tags loc = function
+  | [] -> <:expr< [] >>
+  | TacNonTerm(loc',t,_,Some p)::l ->
+      let l = make_tags loc l in
+      let loc = join_loc loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< [ $t$ :: $l$ ] >>
+  | _::l -> make_tags loc l
+
+let make_one_printing_rule (s,pt,e) =
+  let loc = MLast.loc_of_expr e in
+  let prods = mlexpr_of_list mlexpr_terminals_of_grammar_production pt in
+  <:expr< ($make_tags loc pt$, ($str:s$, $prods$)) >>
+
+let make_printing_rule = mlexpr_of_list make_one_printing_rule
+
+let new_tac_ext (s,cl) =
+  (String.lowercase s, List.map 
+    (fun (s,l,e) ->
+      (String.lowercase s, List.map
+        (function TacTerm s -> TacTerm (String.lowercase s)
+          | t -> t) l,
+        e))
+    cl)
+
+let declare_tactic_v7 loc s cl =
+  let pp = make_printing_rule cl in
+  let gl = mlexpr_of_clause cl in
+  let hide_tac (_,p,e) =
+    (* reste a definir les fonctions cachees avec des noms frais *)
+    let stac = let s = "h_"^s in s.[2] <- Char.lowercase s.[2]; s in
+    let e = 
+      make_fun
+        <:expr<
+          Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$
+        >>
+      p in
+    <:str_item< value $lid:stac$ = $e$ >>
+  in
+  let se = mlexpr_of_string s in
+  <:str_item<
+    declare
+      open Pcoq;
+      Egrammar.extend_tactic_grammar $se$ $gl$;
+      List.iter (Pptactic.declare_extra_tactic_pprule False $se$) $pp$;
+    end
+  >>
+
+let rec contains_epsilon = function
+  | List0ArgType _ -> true
+  | List1ArgType t -> contains_epsilon t
+  | OptArgType _ -> true
+  | PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2
+  | ExtraArgType("hintbases") -> true
+  | _ -> false
+let is_atomic =
+  List.for_all
+    (function
+        TacTerm _ -> false
+      | TacNonTerm(_,t,_,_) -> contains_epsilon t)
+
+let declare_tactic loc s cl =
+  let (s',cl') = new_tac_ext (s,cl) in
+  let pp' = make_printing_rule cl' in
+  let gl' = mlexpr_of_clause cl' in
+  let se' = mlexpr_of_string s' in
+  let pp = make_printing_rule cl in
+  let gl = mlexpr_of_clause cl in
+  let hide_tac (_,p,e) =
+    (* reste a definir les fonctions cachees avec des noms frais *)
+    let stac = "h_"^s' in
+    let e = 
+      make_fun
+        <:expr<
+          Refiner.abstract_extended_tactic $mlexpr_of_string s'$ $make_args p$ $make_eval_tactic e p$
+        >>
+      p in
+    <:str_item< value $lid:stac$ = $e$ >>
+  in
+  let hidden = if List.length cl = 1 then List.map hide_tac cl' else [] in
+  let se = mlexpr_of_string s in
+  let atomic_tactics =
+    mlexpr_of_list (fun (s,_,_) -> mlexpr_of_string s)
+      (List.filter (fun (_,al,_) -> is_atomic al) cl') in
+  <:str_item<
+    declare
+      open Pcoq;
+      declare $list:hidden$ end;
+      try
+        let _=Refiner.add_tactic $se'$ (fun [ $list:make_clauses s' cl'$ ]) in
+        List.iter
+          (fun s -> Tacinterp.add_primitive_tactic s
+              (Tacexpr.TacAtom($default_loc$,
+                 Tacexpr.TacExtend($default_loc$,s,[]))))
+          $atomic_tactics$
+      with e -> Pp.pp (Cerrors.explain_exn e);
+      if Options.v7.val then Egrammar.extend_tactic_grammar $se'$ $gl$
+      else Egrammar.extend_tactic_grammar $se'$ $gl'$;
+      List.iter (Pptactic.declare_extra_tactic_pprule True $se'$) $pp'$;
+      List.iter (Pptactic.declare_extra_tactic_pprule False $se'$) $pp$;
+    end
+  >>
+
+open Vernacexpr
+open Pcoq
+
+let rec interp_entry_name loc s =
+  let l = String.length s in
+  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
+    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
+  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
+    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
+  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
+    OptArgType t, <:expr< Gramext.Sopt $g$ >>
+  else
+    
+    let t, se =
+      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
+	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
+	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
+	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
+	| None -> None, <:expr< $lid:s$ >> in
+    let t =
+      match t with
+	| Some t -> t
+	| None ->
+(*	    Pp.warning_with Pp_control.err_ft
+            ("Unknown primitive grammar entry: "^s);*)
+	    ExtraArgType s
+    in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
+
+open Pcaml
+
+EXTEND
+  GLOBAL: str_item;
+  str_item:
+    [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ];
+        OPT "|"; l = LIST1 tacrule SEP "|";
+        "END" ->
+         declare_tactic loc s l
+      | "V7"; "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ];
+        OPT "|"; l = LIST1 tacrule SEP "|";
+        "END" ->
+         declare_tactic_v7 loc s l ] ]
+  ;
+  tacrule:
+    [ [ "["; s = STRING; l = LIST0 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]"
+        ->
+       if s = "" then Util.user_err_loc (loc,"",Pp.str "Tactic name is empty");
+       (s,l,e)
+    ] ]
+  ;
+  tacargs:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name loc e in
+        TacNonTerm (loc, t, g, Some s)
+      | s = STRING ->
+        TacTerm s
+    ] ]
+  ;
+  END
+
diff --git a/parsing/termast.ml b/parsing/termast.ml
new file mode 100644
index 00000000..47e45d42
--- /dev/null
+++ b/parsing/termast.ml
@@ -0,0 +1,503 @@
+(************************************************************************)
+(*  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: termast.ml,v 1.78.2.1 2004/07/16 19:30:42 herbelin Exp $ *)
+
+open Pp
+open Util
+open Univ
+open Names
+open Nameops
+open Term
+open Termops
+open Inductive
+open Sign
+open Environ
+open Libnames
+open Declare
+open Impargs
+open Coqast
+open Ast
+open Rawterm
+open Pattern
+open Nametab
+
+(* In this file, we translate rawconstr to ast, in order to print constr *)
+
+(**********************************************************************)
+(* Parametrization                                                    *)
+open Constrextern
+(*
+(* This governs printing of local context of references *)
+let print_arguments = ref false
+
+(* If true, prints local context of evars, whatever print_arguments *)
+let print_evar_arguments = ref false
+*)
+
+(* This forces printing of cast nodes *)
+let print_casts = ref true
+
+(*
+(* This governs printing of implicit arguments.  When
+   [print_implicits] is on then [print_implicits_explicit_args] tells
+   how implicit args are printed. If on, implicit args are printed
+   prefixed by "!" otherwise the function and not the arguments is
+   prefixed by "!" *)
+let print_implicits = ref false
+*)
+let print_implicits_explicit_args = ref false
+
+(*
+(* This forces printing of coercions *)
+let print_coercions = ref false
+
+(* This forces printing universe names of Type{.} *)
+let print_universes = ref false
+
+
+let with_option o f x =
+  let old = !o in o:=true;
+  try let r = f x in o := old; r
+  with e -> o := old; raise e
+
+let with_arguments f = with_option print_arguments f
+let with_casts f = with_option print_casts f
+let with_implicits f = with_option print_implicits f
+let with_coercions f = with_option print_coercions f
+let with_universes f = with_option print_universes f
+*)
+(**********************************************************************)
+(* conversion of references                                           *)
+
+let ids_of_ctxt ctxt =
+  Array.to_list
+    (Array.map
+       (function c -> match kind_of_term c with
+	  | Var id -> id
+	  | _ ->
+       error
+       "Termast: arbitrary substitution of references not yet implemented")
+     ctxt)
+
+let ast_of_ident id = nvar id
+
+let ast_of_name = function 
+  | Name id -> nvar id
+  | Anonymous -> nvar wildcard
+
+let idopt_of_name = function 
+  | Name id -> Some id
+  | Anonymous -> None
+
+let ast_of_binders bl =
+  List.map (fun (nal,isdef,ty) ->
+    if isdef then ope("LETBINDER",ty::List.map ast_of_name nal)
+    else ope("BINDER",ty::List.map ast_of_name nal)) bl
+
+let ast_type_of_binder bl t =
+  List.fold_right (fun (nal,isdef,ty) ast ->
+    if isdef then
+      ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)])
+    else
+      ope("PROD",[ty;List.fold_right
+        (fun na ast -> slam(idopt_of_name na,ast)) nal ast]))
+    bl t
+
+let ast_body_of_binder bl t =
+  List.fold_right (fun (nal,isdef,ty) ast ->
+    if isdef then
+      ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)])
+    else
+      ope("LAMBDA",[ty;List.fold_right
+        (fun na ast -> slam(idopt_of_name na,ast)) nal ast]))
+    bl t
+
+let ast_of_constant_ref sp =
+  ope("CONST", [path_section dummy_loc sp])
+
+let ast_of_existential_ref ev =
+(*
+  let ev = 
+    try int_of_string (string_of_id ev)
+    with _ -> warning "cannot find existential variable number"; 0 in
+*)
+  ope("EVAR", [num ev])
+
+let ast_of_constructor_ref ((sp,tyi),n) =
+  ope("MUTCONSTRUCT",[path_section dummy_loc sp; num tyi; num n])
+
+let ast_of_inductive_ref (sp,tyi) =
+  ope("MUTIND", [path_section dummy_loc sp; num tyi])
+
+let ast_of_section_variable_ref s =
+  ope("SECVAR", [nvar s])
+
+let ast_of_qualid p =
+  let dir, s = repr_qualid p in
+  let args = List.map nvar ((List.rev(repr_dirpath dir))@[s]) in
+  ope ("QUALID", args)
+
+let ast_of_ref = function
+  | ConstRef sp -> ast_of_constant_ref sp
+  | IndRef sp -> ast_of_inductive_ref sp
+  | ConstructRef sp -> ast_of_constructor_ref sp
+  | VarRef id -> ast_of_section_variable_ref id
+
+(**********************************************************************)
+(* conversion of patterns                                             *)
+
+let rec ast_of_cases_pattern = function   (* loc is thrown away for printing *)
+  | PatVar (loc,Name id) -> nvar id
+  | PatVar (loc,Anonymous) -> nvar wildcard
+  | PatCstr(loc,cstrsp,args,Name id) ->
+      let args = List.map ast_of_cases_pattern args in
+      ope("PATTAS",
+	  [nvar id;
+	   ope("PATTCONSTRUCT", (ast_of_constructor_ref cstrsp)::args)])
+  | PatCstr(loc,cstrsp,args,Anonymous) ->
+      ope("PATTCONSTRUCT",
+	  (ast_of_constructor_ref cstrsp)
+	  :: List.map ast_of_cases_pattern args)
+	
+let ast_dependent na aty =
+  match na with
+    | Name id -> occur_var_ast id aty
+    | Anonymous -> false
+
+let decompose_binder = function
+  | RProd(_,na,ty,c) -> Some (BProd,na,ty,c)
+  | RLambda(_,na,ty,c) -> Some (BLambda,na,ty,c)
+  | RLetIn(_,na,b,c) -> Some (BLetIn,na,b,c)
+  | _ -> None
+
+(* Implicit args indexes are in ascending order *)
+let explicitize impl args =
+  let n = List.length args in
+  let rec exprec q = function
+    | a::args, imp::impl when is_status_implicit imp ->
+        let tail = exprec (q+1) (args,impl) in
+        let visible =
+          (!print_implicits & !print_implicits_explicit_args)
+          or not (is_inferable_implicit false n imp) in
+        if visible then ope("EXPL", [num q; a]) :: tail else tail
+    | a::args, _::impl -> a :: exprec (q+1) (args,impl)
+    | args, [] -> args  (* In case of polymorphism *)
+    | [], _ -> []
+  in exprec 1 (args,impl)
+
+let rec skip_coercion dest_ref (f,args as app) =
+  if !print_coercions then app
+  else
+    try
+      match dest_ref f with
+	| Some r ->
+	    (match Classops.hide_coercion r with
+	       | Some n ->
+		   if n >= List.length args then app
+		   else (* We skip a coercion *)
+		     let fargs = list_skipn n args in
+	       	     skip_coercion dest_ref (List.hd fargs,List.tl fargs)
+	       | None -> app)
+	| None -> app
+    with Not_found -> app
+
+let ast_of_app impl f args =
+  if !print_implicits & not !print_implicits_explicit_args then 
+    ope("APPLISTEXPL", f::args)
+  else
+    let args = explicitize impl args in
+    if args = [] then f else ope("APPLIST", f::args)
+
+let rec ast_of_raw = function
+  | RRef (_,ref) -> ast_of_ref ref
+  | RVar (_,id) -> ast_of_ident id
+  | REvar (_,n,_) -> (* we drop args *) ast_of_existential_ref n
+  | RPatVar (_,(_,n)) -> ope("META",[ast_of_ident n])
+  | RApp (_,f,args) ->
+      let (f,args) =
+	skip_coercion (function RRef(_,r) -> Some r | _ -> None) (f,args) in
+      let astf = ast_of_raw f in
+      let astargs = List.map ast_of_raw args in
+      (match f with 
+	 | RRef (_,ref) -> ast_of_app (implicits_of_global ref) astf astargs
+	 | _       -> ast_of_app [] astf astargs)
+
+  | RProd (_,Anonymous,t,c) ->
+      (* Anonymous product are never factorized *)
+      ope("ARROW",[ast_of_raw t; slam(None,ast_of_raw c)])
+
+  | RLetIn (_,na,t,c) ->
+      ope("LETIN",[ast_of_raw t; slam(idopt_of_name na,ast_of_raw c)])
+
+  | RProd (_,na,t,c) ->
+      let (n,a) = factorize_binder 1 BProd na (ast_of_raw t) c in
+      (* PROD et PRODLIST doivent être distingués à cause du cas *)
+      (* non dépendant, pour isoler l'implication; peut-être un *)
+      (* constructeur ARROW serait-il plus justifié ? *) 
+      let tag = if n=1 then "PROD" else "PRODLIST" in
+      ope(tag,[ast_of_raw t;a])
+
+  | RLambda (_,na,t,c) ->
+      let (n,a) = factorize_binder 1 BLambda na (ast_of_raw t) c in
+      (* LAMBDA et LAMBDALIST se comportent pareil ... Non ! *)
+      (* Pour compatibilité des theories, il faut LAMBDALIST partout *)
+      ope("LAMBDALIST",[ast_of_raw t;a])
+
+  | RCases (_,(typopt,_),tml,eqns) ->
+      let pred = ast_of_rawopt typopt in
+      let tag = "CASES" in
+      let asttomatch =
+	ope("TOMATCH", List.map (fun (tm,_) -> ast_of_raw tm) tml) in
+      let asteqns = List.map ast_of_eqn eqns in 
+      ope(tag,pred::asttomatch::asteqns)
+	
+  | ROrderedCase (_,LetStyle,typopt,tm,[|bv|],_) ->
+      let nvar' = function Anonymous -> nvar wildcard | Name id -> nvar id in
+      let rec f l = function
+        | RLambda (_,na,RHole _,c) -> f (nvar' na :: l) c
+        | RLetIn (_,na,RHole _,c) -> f (nvar' na :: l) c
+        | c -> List.rev l, ast_of_raw c in
+      let l,c = f [] bv in
+      let eqn = ope ("EQN", [c;ope ("PATTCONSTRUCT",(nvar wildcard)::l)]) in
+      ope ("FORCELET",[(ast_of_rawopt typopt);(ast_of_raw tm);eqn])
+
+  | ROrderedCase (_,st,typopt,tm,bv,_) ->
+      let tag = match st with
+	| IfStyle -> "FORCEIF"
+	| RegularStyle -> "CASE"
+	| MatchStyle | LetStyle -> "MATCH"
+      in
+
+      (* warning "Old Case syntax"; *)
+      ope(tag,(ast_of_rawopt typopt)
+	    ::(ast_of_raw tm)
+	    ::(Array.to_list (Array.map ast_of_raw bv)))
+
+  | RLetTuple _ | RIf _ ->
+      error "Let tuple not supported in v7"
+
+  | RRec (_,fk,idv,blv,tyv,bv) ->
+      let alfi = Array.map ast_of_ident idv in
+      (match fk with
+	 | RFix (nv,n) ->
+             let rec split_lambda binds = function
+	       | (0, t) -> (List.rev binds,ast_of_raw t)
+	       | (n, RLetIn (_,na,b,c)) ->
+		   let bind = ope("LETBINDER",[ast_of_raw b;ast_of_name na]) in
+		   split_lambda (bind::binds) (n,c)
+	       | (n, RLambda (_,na,t,b)) ->
+		   let bind = ope("BINDER",[ast_of_raw t;ast_of_name na]) in
+		   split_lambda (bind::binds) (n-1,b)
+	       | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint body" in
+	     let rec split_product = function
+	       | (0, t) -> ast_of_raw t
+	       | (n, RLetIn (_,na,_,c)) -> split_product (n,c)
+	       | (n, RProd (_,na,t,b)) -> split_product (n-1,b)
+	       | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint type" in
+	     let listdecl = 
+	       Array.mapi
+		 (fun i fi ->
+                   if List.length blv.(i) >= nv.(i)+1 then
+                     let (oldfixp,factb) = list_chop (nv.(i)+1) blv.(i) in
+                     let bl = factorize_local_binder oldfixp in
+                     let factb = factorize_local_binder factb in
+                     let asttyp = ast_type_of_binder factb
+                       (ast_of_raw tyv.(i)) in
+                     let astdef = ast_body_of_binder factb
+                       (ast_of_raw bv.(i)) in
+                     ope("FDECL",[fi;ope("BINDERS",ast_of_binders bl);
+                                  asttyp; astdef])
+                   else
+                     let n = nv.(i)+1 - List.length blv.(i) in
+		     let (lparams,astdef) =
+                       split_lambda [] (n,bv.(i)) in
+                     let bl = factorize_local_binder blv.(i) in
+                     let lparams = ast_of_binders bl @ lparams in
+		     let asttyp = split_product (n,tyv.(i)) in
+		     ope("FDECL",
+		         [fi; ope ("BINDERS",lparams); 
+		          asttyp; astdef]))
+		 alfi
+	     in 
+	     ope("FIX", alfi.(n)::(Array.to_list listdecl))
+	 | RCoFix n -> 
+	     let listdecl =
+               Array.mapi 
+		 (fun i fi ->
+                   let bl = factorize_local_binder blv.(i) in
+                   let asttyp = ast_type_of_binder bl (ast_of_raw tyv.(i)) in
+                   let astdef = ast_body_of_binder bl (ast_of_raw bv.(i)) in
+		   ope("CFDECL",[fi; asttyp; astdef]))
+		 alfi
+	     in 
+	     ope("COFIX", alfi.(n)::(Array.to_list listdecl)))
+
+  | RSort (_,s) ->
+      (match s with
+	 | RProp Null -> ope("PROP",[])
+	 | RProp Pos -> ope("SET",[])
+	 | RType (Some u) when !print_universes -> ope("TYPE",[ide(Univ.string_of_univ u)])
+	 | RType _ -> ope("TYPE",[]))
+  | RHole _ -> ope("ISEVAR",[])
+  | RCast (_,c,t) -> ope("CAST",[ast_of_raw c;ast_of_raw t])
+  | RDynamic (loc,d) -> Dynamic (loc,d)
+	
+and ast_of_eqn (_,ids,pl,c) =
+  ope("EQN", (ast_of_raw c)::(List.map ast_of_cases_pattern pl))
+
+and ast_of_rawopt = function
+  | None -> (string "SYNTH")
+  | Some p -> ast_of_raw p
+
+and factorize_binder n oper na aty c =
+  let (p,body) = match decompose_binder c with
+    | Some (oper',na',ty',c')
+	when (oper = oper') & (aty = ast_of_raw ty')
+	  & not (ast_dependent na aty) (* To avoid na in ty' escapes scope *)
+	  & not (na' = Anonymous & oper = BProd)
+	  -> factorize_binder (n+1) oper na' aty c'
+    | _ -> (n,ast_of_raw c)
+  in
+  (p,slam(idopt_of_name na, body))
+
+and factorize_local_binder = function
+    [] -> []
+  | (na,Some bd,ty)::l ->
+      ([na],true,ast_of_raw bd) :: factorize_local_binder l
+  | (na,None,ty)::l ->
+      let ty = ast_of_raw ty in
+      (match factorize_local_binder l with
+          (lna,false,ty') :: l when ty=ty' ->
+            (na::lna,false,ty') :: l
+        | l -> ([na],false,ty) :: l)
+
+
+let ast_of_rawconstr = ast_of_raw
+
+(******************************************************************)
+(* Main translation function from constr -> ast *)
+       
+let ast_of_constr at_top env t =
+  let t' =
+    if !print_casts then t
+    else Reductionops.local_strong strip_outer_cast t in
+  let avoid = if at_top then ids_of_context env else [] in
+  ast_of_raw 
+    (Detyping.detype (at_top,env) avoid (names_of_rel_context env) t')
+
+let ast_of_constant env sp =
+  let a = ast_of_constant_ref sp in
+  a
+
+let ast_of_existential env (ev,ids) =
+  let a = ast_of_existential_ref ev in
+  if !print_arguments or !print_evar_arguments then
+    ope("INSTANCE",a::(array_map_to_list (ast_of_constr false env) ids))
+  else a
+
+let ast_of_constructor env cstr_sp =
+  let a = ast_of_constructor_ref cstr_sp in
+  a
+
+let ast_of_inductive env ind_sp =
+  let a = ast_of_inductive_ref ind_sp in
+  a
+
+let decompose_binder_pattern = function
+  | PProd(na,ty,c) -> Some (BProd,na,ty,c)
+  | PLambda(na,ty,c) -> Some (BLambda,na,ty,c)
+  | PLetIn(na,b,c) -> Some (BLetIn,na,b,c)
+  | _ -> None
+
+let rec ast_of_pattern tenv env = function
+  | PRef ref -> ast_of_ref ref
+
+  | PVar id -> ast_of_ident id
+
+  | PEvar (n,_) -> ast_of_existential_ref n
+
+  | PRel n ->
+      (try match lookup_name_of_rel n env with
+	 | Name id   -> ast_of_ident id
+	 | Anonymous ->
+	     anomaly "ast_of_pattern: index to an anonymous variable"
+       with Not_found ->
+	 nvar (id_of_string ("[REL "^(string_of_int n)^"]")))
+
+  | PApp (f,args) ->
+      let (f,args) = 
+	skip_coercion (function PRef r -> Some r | _ -> None)
+	  (f,Array.to_list args) in
+      let astf = ast_of_pattern tenv env f in
+      let astargs = List.map (ast_of_pattern tenv env) args in
+      (match f with 
+	 | PRef ref -> ast_of_app (implicits_of_global ref) astf astargs
+	 | _        -> ast_of_app [] astf astargs)
+
+  | PSoApp (n,args) ->
+      ope("SOAPP",(ope ("META",[ast_of_ident n])):: 
+		  (List.map (ast_of_pattern tenv env) args))
+
+  | PLetIn (na,b,c) ->
+      let c' = ast_of_pattern tenv (add_name na env) c in
+      ope("LETIN",[ast_of_pattern tenv env b;slam(idopt_of_name na,c')])
+		
+  | PProd (Anonymous,t,c) ->
+      ope("PROD",[ast_of_pattern tenv env t;
+                  slam(None,ast_of_pattern tenv env c)])
+  | PProd (na,t,c) ->
+      let env' = add_name na env in
+      let (n,a) =
+	factorize_binder_pattern tenv env' 1 BProd na
+          (ast_of_pattern tenv env t) c in
+      (* PROD et PRODLIST doivent être distingués à cause du cas *)
+      (* non dépendant, pour isoler l'implication; peut-être un *)
+      (* constructeur ARROW serait-il plus justifié ? *) 
+      let tag = if n=1 then "PROD" else "PRODLIST" in
+      ope(tag,[ast_of_pattern tenv env t;a])
+  | PLambda (na,t,c) ->
+      let env' = add_name na env in
+      let (n,a) =
+	factorize_binder_pattern tenv env' 1 BLambda na
+          (ast_of_pattern tenv env t) c in
+      (* LAMBDA et LAMBDALIST se comportent pareil *)
+      let tag = if n=1 then "LAMBDA" else "LAMBDALIST" in
+      ope(tag,[ast_of_pattern tenv env t;a])
+
+  | PCase (st,typopt,tm,bv) ->
+      warning "Old Case syntax";
+      ope("MUTCASE",(ast_of_patopt tenv env typopt)
+	    ::(ast_of_pattern tenv env tm)
+	    ::(Array.to_list (Array.map (ast_of_pattern tenv env) bv)))
+
+  | PSort s ->
+      (match s with
+	 | RProp Null -> ope("PROP",[])
+	 | RProp Pos -> ope("SET",[])
+	 | RType _ -> ope("TYPE",[]))
+
+  | PMeta (Some n) -> ope("META",[ast_of_ident n])
+  | PMeta None -> ope("ISEVAR",[])
+  | PFix f -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkFix f))
+  | PCoFix c -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkCoFix c))
+	
+and ast_of_patopt tenv env = function
+  | None -> (string "SYNTH")
+  | Some p -> ast_of_pattern tenv env p
+
+and factorize_binder_pattern tenv env n oper na aty c =
+  let (p,body) = match decompose_binder_pattern c with
+    | Some (oper',na',ty',c')
+	when (oper = oper') & (aty = ast_of_pattern tenv env ty')
+	  & not (na' = Anonymous & oper = BProd)
+	  ->
+	factorize_binder_pattern tenv (add_name na' env) (n+1) oper na' aty c'
+    | _ -> (n,ast_of_pattern tenv env c)
+  in
+  (p,slam(idopt_of_name na, body))
diff --git a/parsing/termast.mli b/parsing/termast.mli
new file mode 100644
index 00000000..c66e8f0f
--- /dev/null
+++ b/parsing/termast.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  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: termast.mli,v 1.24.2.1 2004/07/16 19:30:42 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Termops
+open Sign
+open Environ
+open Libnames
+open Nametab
+open Rawterm
+open Pattern
+(*i*)
+
+(* Translation of pattern, cases pattern, rawterm and term into syntax
+   trees for printing *)
+
+val ast_of_cases_pattern : cases_pattern -> Coqast.t
+val ast_of_rawconstr : rawconstr -> Coqast.t
+val ast_of_pattern : env -> names_context -> constr_pattern -> Coqast.t
+
+(* If [b=true] in [ast_of_constr b env c] then the variables in the first 
+   level of quantification clashing with the variables in [env] are renamed *)
+
+val ast_of_constr : bool -> env -> constr -> Coqast.t
+
+val ast_of_constant     : env -> constant -> Coqast.t
+val ast_of_existential  : env -> existential -> Coqast.t
+val ast_of_constructor  : env -> constructor -> Coqast.t
+val ast_of_inductive    : env -> inductive -> Coqast.t
+val ast_of_ref          : global_reference -> Coqast.t
+val ast_of_qualid       : qualid -> Coqast.t
+
+(*i Now in constrextern.mli
+val print_implicits : bool ref
+val print_casts : bool ref
+val print_arguments : bool ref
+val print_evar_arguments : bool ref
+val print_coercions : bool ref
+val print_universes : bool ref
+
+val with_casts : ('a -> 'b) -> 'a -> 'b
+val with_implicits : ('a -> 'b) -> 'a -> 'b
+val with_arguments : ('a -> 'b) -> 'a -> 'b
+val with_coercions : ('a -> 'b) -> 'a -> 'b
+val with_universes : ('a -> 'b) -> 'a -> 'b
+i*)
diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4
new file mode 100644
index 00000000..bdc1ea66
--- /dev/null
+++ b/parsing/vernacextend.ml4
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  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: vernacextend.ml4,v 1.5.2.2 2004/07/16 19:30:42 herbelin Exp $ *)
+
+open Genarg
+open Q_util
+open Q_coqast
+open Ast
+open Argextend
+
+let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
+let loc = Util.dummy_loc
+let default_loc = <:expr< Util.dummy_loc >>
+
+type grammar_tactic_production_expr =
+  | VernacTerm of string
+  | VernacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option
+let rec make_patt = function
+  | [] -> <:patt< [] >>
+  | VernacNonTerm(_,_,_,Some p)::l ->
+      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
+  | _::l -> make_patt l
+
+let rec make_when loc = function
+  | [] -> <:expr< True >>
+  | VernacNonTerm(loc',t,_,Some p)::l ->
+      let l = make_when loc l in
+      let loc = join_loc loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
+  | _::l -> make_when loc l
+
+let rec make_let e = function
+  | [] -> e
+  | VernacNonTerm(loc,t,_,Some p)::l ->
+      let loc = join_loc loc (MLast.loc_of_expr e) in
+      let e = make_let e l in
+      <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >>
+  | _::l -> make_let e l
+
+let add_clause s (_,pt,e) l =
+  let p = make_patt pt in
+  let w = Some (make_when (MLast.loc_of_expr e) pt) in
+  (p, w, make_let e pt)::l
+
+let rec extract_signature = function
+  | [] -> []
+  | VernacNonTerm (_,t,_,_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+let check_unicity s l =
+  let l' = List.map (fun (_,l,_) -> extract_signature l) l in
+  if not (Util.list_distinct l') then
+    Pp.warning_with Pp_control.err_ft
+      ("Two distinct rules of entry "^s^" have the same\n"^
+      "non-terminals in the same order: put them in distinct vernac entries")
+
+let make_clauses s l =
+  check_unicity s l;
+  let default =
+    (<:patt< _ >>,None,<:expr< failwith "Vernac extension: cannot occur" >>) in
+  List.fold_right (add_clause s) l [default]
+
+let rec make_fun e = function
+  | [] -> e
+  | VernacNonTerm(loc,_,_,Some p)::l -> 
+      <:expr< fun $lid:p$ -> $make_fun e l$ >>
+  | _::l -> make_fun e l
+
+let mlexpr_of_grammar_production = function
+  | VernacTerm s ->
+      <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >>
+  | VernacNonTerm (loc,nt,g,sopt) ->
+      <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >>
+
+let mlexpr_of_clause =
+  mlexpr_of_list
+    (fun (a,b,c) ->
+      (mlexpr_of_pair
+	mlexpr_of_string
+	(mlexpr_of_list mlexpr_of_grammar_production)
+	(a,b)))
+
+let declare_command loc s cl =
+  let gl = mlexpr_of_clause cl in
+  let icl = make_clauses s cl in
+  <:str_item<
+    declare
+      open Pcoq;
+      try Vernacinterp.vinterp_add $mlexpr_of_string s$ (fun [ $list:icl$ ])
+      with e -> Pp.pp (Cerrors.explain_exn e);
+      Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $gl$;
+    end
+  >>
+
+open Vernacexpr
+open Pcoq
+
+let rec interp_entry_name loc s =
+  let l = String.length s in
+  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
+    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
+  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
+    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
+  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
+    OptArgType t, <:expr< Gramext.Sopt $g$ >>
+  else
+    let t, se = 
+      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
+	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>
+	| None ->
+      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
+	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
+	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
+	| None -> None, <:expr< $lid:s$ >> in
+    let t =
+      match t with
+	| Some t -> t
+	| None ->
+(*	    Pp.warning_with Pp_control.err_ft
+            ("Unknown primitive grammar entry: "^s);*)
+	    ExtraArgType s
+    in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
+
+open Pcaml
+
+EXTEND
+  GLOBAL: str_item;
+  str_item:
+    [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT;
+        OPT "|"; l = LIST1 rule SEP "|";
+        "END" ->
+         declare_command loc s l ] ]
+  ;
+  rule:
+    [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]"
+        -> 
+      if s = "" then Util.user_err_loc (loc,"",Pp.str "Command name is empty");
+      (s,l,<:expr< fun () -> $e$ >>)
+    ] ]
+  ;
+  args:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name loc e in
+        VernacNonTerm (loc, t, g, Some s)
+      | s = STRING ->
+        VernacTerm s
+    ] ]
+  ;
+  END
+;;