Imported Upstream version 8.0pl3+8.1alphaupstream/8.0pl3+8.1alpha

64 files changed, 5321 insertions, 8693 deletions

diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
index e6d9f99d..650afe17 100644
--- a/parsing/argextend.ml4
+++ b/parsing/argextend.ml4
@@ -6,12 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: argextend.ml4,v 1.9.2.4 2005/01/15 14:56:53 herbelin Exp $ *)
+(* $Id: argextend.ml4 7739 2005-12-26 17:08:16Z herbelin $ *)
 
 open Genarg
 open Q_util
 open Q_coqast
-open Ast
 
 let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
 let loc = Util.dummy_loc
@@ -25,16 +24,15 @@ let rec make_rawwit loc = function
   | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >>
   | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >>
   | IdentArgType -> <:expr< Genarg.rawwit_ident >>
-  | HypArgType -> <:expr< Genarg.rawwit_var >>
+  | VarArgType -> <: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 >>
+  | TacticArgType n -> <:expr< Genarg.rawwit_tactic $mlexpr_of_int n$ >>
   | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >>
-  | OpenConstrArgType -> <:expr< Genarg.rawwit_open_constr >>
-  | CastedOpenConstrArgType -> <:expr< Genarg.rawwit_casted_open_constr >>
+  | OpenConstrArgType b -> <:expr< Genarg.rawwit_open_constr_gen $mlexpr_of_bool b$ >>
   | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >>
   | BindingsArgType -> <:expr< Genarg.rawwit_bindings >>
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >>
@@ -52,16 +50,15 @@ let rec make_globwit loc = function
   | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >>
   | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >>
   | IdentArgType -> <:expr< Genarg.globwit_ident >>
-  | HypArgType -> <:expr< Genarg.globwit_var >>
+  | VarArgType -> <: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 >>
+  | TacticArgType n -> <:expr< Genarg.globwit_tactic  $mlexpr_of_int n$ >>
   | RedExprArgType -> <:expr< Genarg.globwit_red_expr >>
-  | OpenConstrArgType -> <:expr< Genarg.globwit_open_constr >>
-  | CastedOpenConstrArgType -> <:expr< Genarg.globwit_casted_open_constr >>
+  | OpenConstrArgType b -> <:expr< Genarg.globwit_open_constr_gen $mlexpr_of_bool b$ >>
   | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >>
   | BindingsArgType -> <:expr< Genarg.globwit_bindings >>
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >>
@@ -79,16 +76,15 @@ let rec make_wit loc = function
   | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >>
   | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >>
   | IdentArgType -> <:expr< Genarg.wit_ident >>
-  | HypArgType -> <:expr< Genarg.wit_var >>
+  | VarArgType -> <: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 >>
+  | TacticArgType n -> <:expr< Genarg.wit_tactic $mlexpr_of_int n$ >>
   | RedExprArgType -> <:expr< Genarg.wit_red_expr >>
-  | OpenConstrArgType -> <:expr< Genarg.wit_open_constr >>
-  | CastedOpenConstrArgType -> <:expr< Genarg.wit_casted_open_constr >>
+  | OpenConstrArgType b -> <:expr< Genarg.wit_open_constr_gen $mlexpr_of_bool b$ >>
   | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >>
   | BindingsArgType -> <:expr< Genarg.wit_bindings >>
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >>
@@ -105,7 +101,8 @@ let make_act loc act pil =
     | Some (p, t) :: tl ->
 	<:expr<
           Gramext.action 
-            (fun $lid:p$ -> let _ = in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
+            (fun $lid:p$ ->
+               let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
         >> in
   make (List.rev pil)
 
@@ -113,22 +110,34 @@ 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 declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
   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 glob = match g with
+    | None ->
+	<:expr< fun e x ->
+          out_gen $make_globwit loc typ$
+            (Tacinterp.intern_genarg e
+               (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >>
+    | Some f -> <:expr< $lid:f$>> in
+  let interp = match f with
+    | None -> 
+	<:expr< fun ist gl x ->
+          out_gen $make_wit loc typ$
+            (Tacinterp.interp_genarg ist gl
+               (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
+    | Some f -> <:expr< $lid:f$>> in
+  let substitute = match h with
+    | None -> 
+	<:expr< fun s x ->
+          out_gen $make_globwit loc globtyp$
+	    (Tacinterp.subst_genarg s
+               (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
+    | Some f -> <:expr< $lid:f$>> in
   let se = mlexpr_of_string s in
   let wit = <:expr< $lid:"wit_"^s$ >> in
   let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
@@ -141,36 +150,22 @@ let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl =
       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)))))),
+          (Genarg.in_gen $globwit$ ($glob$ e (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)))))),
+          (Genarg.in_gen $wit$ ($interp$ ist gl (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)))))));
+          (Genarg.in_gen $globwit$ ($substitute$ subst (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 declare_vernac_argument 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<
@@ -238,40 +233,17 @@ EXTEND
         "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
+         declare_tactic_argument 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 ] ]
+         declare_vernac_argument loc s l ] ]
   ;
   argtype:
-    [ "2" RIGHTA
-      [ e1 = argtype; "*"; e2 = NEXT -> PairArgType (e1, e2) ]
+    [ "2" 
+      [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ]
     | "1"
       [ e = argtype; LIDENT "list" -> List0ArgType e
       | e = argtype; LIDENT "option" -> OptArgType e ]
@@ -288,7 +260,8 @@ EXTEND
       | 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)
+        (<:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>, None)
     ] ]
   ;
   END
+
diff --git a/parsing/ast.ml b/parsing/ast.ml
deleted file mode 100755
index b2a30f9c..00000000
--- a/parsing/ast.ml
+++ /dev/null
@@ -1,600 +0,0 @@
-(************************************************************************)
-(*  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
deleted file mode 100755
index 7bc0b607..00000000
--- a/parsing/ast.mli
+++ /dev/null
@@ -1,123 +0,0 @@
-(************************************************************************)
-(*  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
deleted file mode 100644
index 0f447766..00000000
--- a/parsing/coqast.ml
+++ /dev/null
@@ -1,123 +0,0 @@
-(************************************************************************)
-(*  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
deleted file mode 100644
index 0b1138f2..00000000
--- a/parsing/coqast.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(*  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.2 2005/01/21 16:42:36 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
-
-(*i
-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
-i*)
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
index 09889d40..c723175c 100644
--- a/parsing/egrammar.ml
+++ b/parsing/egrammar.ml
@@ -6,64 +6,31 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: egrammar.ml,v 1.48.2.4 2005/12/23 22:16:46 herbelin Exp $ *)
+(* $Id: egrammar.ml 7762 2005-12-30 10:55:33Z herbelin $ *)
 
 open Pp
 open Util
-open Ppextend
-open Extend
 open Pcoq
+open Extend
 open Topconstr
-open Ast
 open Genarg
 open Libnames
 open Nameops
-
-(* State of the grammar extensions *)
-
-type notation_grammar = 
-    int * Gramext.g_assoc option * notation * prod_item list * int list option
-
-type all_grammar_command =
-  | Notation of (precedence * tolerability list) * notation_grammar
-  | Grammar of grammar_command
-  | TacticGrammar of
-      (string * (string * grammar_production list) * 
-      (Names.dir_path * Tacexpr.raw_tactic_expr))
-      list * (string * Genarg.argument_type list *
-              (string * Pptactic.grammar_terminals)) 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,p) -> TacticGrammar (g,p) (* TODO ... *)
-
-let (grammar_state : all_grammar_command list ref) = ref []
-
+open Tacexpr
+open Names
+open Vernacexpr
 
 (**************************************************************************)
-(* 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
+(*  
+ * --- Note on the mapping of grammar productions to camlp4 actions ---
+ *  
+ * 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:
+ * the make_*_action family build the following closure:
  *
  *      ((fun env ->
  *          (fun vi -> 
@@ -77,11 +44,18 @@ let specify_name name e =
  *         [])
  *)
 
-open Names
+(**********************************************************************)
+(** Declare Notations grammar rules                                   *)
+
+type prod_item =
+  | Term of Token.pattern
+  | NonTerm of constr_production_entry * 
+      (Names.identifier * constr_production_entry) option
 
 type 'a action_env = (identifier * 'a) list
 
-let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
+let make_constr_action
+  (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)
@@ -95,8 +69,8 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
         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)
+        Gramext.action (fun (v:Bigint.bigint) ->
+	  make ((p,CPrim (dummy_loc,Numeral v)) :: env) tl)
     | Some (p, ETConstrList _) :: tl ->
         Gramext.action (fun (v:constr_expr list) ->
           let dummyid = Ident (dummy_loc,id_of_string "") in
@@ -105,7 +79,7 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
 	failwith "Unexpected entry of type cases pattern" in
   make [] (List.rev pil)
 
-let make_act_in_cases_pattern (* For Notations *)
+let make_cases_pattern_action
   (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
   let rec make (env : cases_pattern_expr action_env) = function
     | [] ->
@@ -121,8 +95,8 @@ let make_act_in_cases_pattern (* For Notations *)
         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)
+        Gramext.action (fun (v:Bigint.bigint) ->
+	  make ((p,CPatPrim (dummy_loc,Numeral v)) :: env) tl)
     | Some (p, ETConstrList _) :: tl ->
         Gramext.action (fun (v:cases_pattern_expr list) ->
           let dummyid = Ident (dummy_loc,id_of_string "") in
@@ -131,183 +105,37 @@ let make_act_in_cases_pattern (* For Notations *)
 	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
+let make_constr_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 extend_constr entry (n,assoc,pos,p4assoc,name) mkact (forpat,pt) =
+  let univ = get_univ "constr" in
+  let pil = List.map (make_constr_prod_item univ assoc n forpat) pt 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)
+  grammar_extend entry pos [(name, p4assoc, [symbs, mkact ntl])]
 
-(* 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 extend_constr_notation (n,assoc,ntn,rule) =
+  (* Add the notation in constr *)
+  let mkact loc env = CNotation (loc,ntn,List.map snd env) 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_constr_action mkact) (false,rule);
+  (* Add the notation in cases_pattern *)
+  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_cases_pattern_action mkact) (true,rule)
 
-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)
+(**********************************************************************)
+(** Making generic actions in type generic_argument                   *)
 
-let make_gen_act f pil =
+let make_generic_action
+  (f:loc -> ('b * raw_generic_argument) list -> 'a) pil =
   let rec make env = function
     | [] -> 
 	Gramext.action (fun loc -> f loc env)
@@ -317,73 +145,77 @@ let make_gen_act f pil =
         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
+let make_rule univ f g pt =
+  let (symbs,ntl) = List.split (List.map g pt) in
+  let act = make_generic_action f ntl in
   (symbs, act)
 
+(**********************************************************************)
+(** Grammar extensions declared at ML level                           *) 
+
+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 (Lexer.terminal s), None)
+  | TacNonTerm (_,(nont,t), po) -> (nont, option_app (fun p -> (p,t)) po)
+
+(* Tactic grammar extensions *)
+
 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
+  let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
+  let rules = List.map (make_rule univ mkact make_prod_item) gl in
   Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)]
 
+(* Vernac grammar extensions *)
+
 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
+  let mkact loc l = VernacExtend (s,List.map snd l) in
+  let rules = List.map (make_rule univ mkact make_prod_item) gl in
   Gram.extend Vernac_.command None [(None, None, List.rev rules)]
 
-let rec interp_entry_name u s =
+(**********************************************************************)
+(** Grammar declaration for Tactic Notation (Coq level)               *) 
+
+(* Interpretation of the grammar entry names *)
+
+let find_index s t =
+  let t,n = repr_ident (id_of_string t) in
+  if s <> t or n = None then raise Not_found;
+  out_some n
+
+let rec interp_entry_name up_level 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
+    let t, g = interp_entry_name up_level 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
+    let t, g = interp_entry_name up_level 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
+    let t, g = interp_entry_name up_level u (String.sub s 0 (l-4)) in
     OptArgType t, Gramext.Sopt g
   else
+    try 
+      let i = find_index "tactic" s in
+      TacticArgType i, 
+      if i=up_level then Gramext.Sself else
+      if i=up_level-1 then Gramext.Snext else
+      Gramext.Snterml(Pcoq.Gram.Entry.obj Tactic.tactic_expr,string_of_int i)
+    with Not_found ->
     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 _ -> 
@@ -396,31 +228,61 @@ let rec interp_entry_name u s =
     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)
+let make_vprod_item n univ = function
+  | VTerm s -> (Gramext.Stoken (Lexer.terminal s), None)
   | VNonTerm (loc, nt, po) ->
-      let (u,nt) = qualified_nterm univ nt in
-      let (etyp, e) = interp_entry_name u nt in
+      let (etyp, e) = interp_entry_name n univ nt in
       e, option_app (fun p -> (p,etyp)) po
 
-let add_tactic_entries gl =
+let get_tactic_entry n =
+  if n = 0 then
+    weaken_entry Tactic.simple_tactic, None
+  else if 1<=n && n<=5 then
+    weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n))
+  else 
+    error ("Invalid Tactic Notation level: "^(string_of_int n))
+
+(* Declaration of the tactic grammar rule *)
+
+let head_is_ident = function VTerm _::_ -> true | _ -> false
+
+let add_tactic_entry (key,lev,prods,tac) =
   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 entry, pos = get_tactic_entry lev in
+  let mkprod = make_vprod_item lev "tactic" in
+  let rules = 
+    if lev = 0 then begin
+      if not (head_is_ident prods) then
+	error "Notation for simple tactic must start with an identifier";
+      let mkact s tac loc l =
+	(TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in
+      make_rule univ (mkact key tac) mkprod prods
+    end
+    else
+      let mkact s tac loc l = 
+	(TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in
+      make_rule univ (mkact key tac) mkprod prods in
   let _ = find_position true true None None (* to synchronise with remove *) in
-  grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+  grammar_extend entry pos [(None, None, List.rev [rules])]
+
+(**********************************************************************)
+(** State of the grammar extensions                                   *)
+
+type notation_grammar = 
+    int * Gramext.g_assoc option * notation * prod_item list
+
+type all_grammar_command =
+  | Notation of Notation.level * notation_grammar
+  | TacticGrammar of
+      (string * int * grammar_production list * 
+        (Names.dir_path * Tacexpr.glob_tactic_expr))
+
+let (grammar_state : all_grammar_command list ref) = ref []
 
 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);
+  | TacticGrammar g -> add_tactic_entry g);
   grammar_state := gram :: !grammar_state
 
 let reset_extend_grammars_v8 () =
@@ -428,12 +290,12 @@ let reset_extend_grammars_v8 () =
   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) -> print_string ("Resinstalling "^s); flush stdout; extend_tactic_grammar s gl) te;
   List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv
 
 let recover_notation_grammar ntn prec =
   let l = map_succeed (function
-    | Notation (prec',(_,_,ntn',_,_ as x)) when prec = prec' & ntn = ntn' -> x
+    | Notation (prec',(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> x
     | _ -> failwith "") !grammar_state in
   assert (List.length l = 1);
   List.hd l
@@ -453,11 +315,7 @@ let factorize_grams 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)
+      | Notation _ -> n + 2 (* 1 for operconstr, 1 for pattern *)
       | TacticGrammar _ -> n + 1)
     0 gcl
 
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
index ade91453..31247044 100644
--- a/parsing/egrammar.mli
+++ b/parsing/egrammar.mli
@@ -6,54 +6,62 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: egrammar.mli,v 1.14.2.6 2005/12/23 22:16:46 herbelin Exp $ i*)
+(*i $Id: egrammar.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
 
 (*i*)
 open Util
 open Topconstr
-open Ast
-open Coqast
+open Pcoq
+open Extend
 open Vernacexpr
 open Ppextend
-open Extend
 open Rawterm
+open Mod_subst
 (*i*)
 
+(** Mapping of grammar productions to camlp4 actions
+    Used for Coq-level Notation and Tactic Notation, 
+    and for ML-level tactic and vernac extensions
+ *)
+
+type prod_item =
+  | Term of Token.pattern
+  | NonTerm of constr_production_entry * 
+      (Names.identifier * constr_production_entry) option
+
 type notation_grammar = 
-    int * Gramext.g_assoc option * notation * prod_item list * int list option
+    int * Gramext.g_assoc option * notation * prod_item list
 
 type all_grammar_command =
   | Notation of (precedence * tolerability list) * notation_grammar
-  | Grammar of grammar_command
   | TacticGrammar of
-      (string * (string * grammar_production list) * 
-      (Names.dir_path * Tacexpr.raw_tactic_expr))
-      list * (string * Genarg.argument_type list *
-              (string * Pptactic.grammar_terminals)) list
+      (string * int * grammar_production list * 
+        (Names.dir_path * Tacexpr.glob_tactic_expr))
 
 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
+  | 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
+  string -> grammar_tactic_production list list -> unit
 
 val extend_vernac_command_grammar :
-  string -> (string * grammar_tactic_production list) list -> unit
-
+  string -> grammar_tactic_production list list -> unit
+(*
 val get_extend_tactic_grammars :
- unit -> (string * (string * grammar_tactic_production list) list) list
+ unit -> (string * grammar_tactic_production list list) list
+*)
 val get_extend_vernac_grammars :
- unit -> (string * (string * grammar_tactic_production list) list) list
+ unit -> (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 -> 
+*)
+val interp_entry_name : int -> string -> string -> 
   entry_type * Token.t Gramext.g_symbol
 
 val recover_notation_grammar :
diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml
deleted file mode 100644
index 6a4758ab..00000000
--- a/parsing/esyntax.ml
+++ /dev/null
@@ -1,276 +0,0 @@
-(************************************************************************)
-(*  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
deleted file mode 100644
index 88d1a0e2..00000000
--- a/parsing/esyntax.mli
+++ /dev/null
@@ -1,61 +0,0 @@
-(************************************************************************)
-(*  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.2 2005/01/21 16:42:36 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
-
-(*i
-val declare_infix_symbol : Libnames.section_path -> string -> unit
-i*)
-
-(* Generic printing functions *) 
-(*i
-val token_printer: std_printer -> std_printer
-val print_syntax_entry : 
-  string -> unparsing_subfunction -> Ast.env -> Ast.astpat syntax_entry -> std_ppcmds
-i*)
-val genprint : std_printer -> unparsing_subfunction
diff --git a/parsing/extend.ml b/parsing/extend.ml
index 2778de44..f4c98291 100644
--- a/parsing/extend.ml
+++ b/parsing/extend.ml
@@ -7,21 +7,23 @@
 (************************************************************************)
 
 
-(*i $Id: extend.ml,v 1.20.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+(*i $Id: extend.ml 7761 2005-12-30 10:52:19Z herbelin $ i*)
 
 open Util
 open Pp
 open Gramext
 open Names
-open Ast
 open Ppextend
 open Topconstr
 open Genarg
 
-type entry_type = argument_type
+(**********************************************************************)
+(* constr entry keys                                                  *)
+
+type side = Left | Right
 
 type production_position =
-  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | BorderProd of side * Gramext.g_assoc option  (* true=left; false=right *)
   | InternalProd
 
 type production_level =
@@ -37,54 +39,13 @@ type ('lev,'pos) constr_entry_key =
 
 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
+type constr_entry =
+    (int,unit) constr_entry_key
+type simple_constr_production_entry =
+    (production_level,unit) constr_entry_key
 
 (**********************************************************************)
-(* 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
+(* syntax modifiers                                                   *)
 
 type syntax_modifier =
   | SetItemLevel of string list * production_level
@@ -94,285 +55,3 @@ type syntax_modifier =
   | 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
index c5417649..80de7108 100644
--- a/parsing/extend.mli
+++ b/parsing/extend.mli
@@ -6,23 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extend.mli,v 1.19.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: extend.mli 7761 2005-12-30 10:52:19Z herbelin $ i*)
 
-(*i*)
-open Pp
 open Util
-open Names
-open Ast
-open Coqast
-open Ppextend
-open Topconstr
-open Genarg
-(*i*)
 
-type entry_type = argument_type
+(**********************************************************************)
+(* constr entry keys                                                  *)
+
+type side = Left | Right
 
 type production_position =
-  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | BorderProd of side * Gramext.g_assoc option  (* true=left; false=right *)
   | InternalProd
 
 type production_level =
@@ -38,41 +32,13 @@ type ('lev,'pos) constr_entry_key =
 
 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
+type constr_entry =
+    (int,unit) constr_entry_key
+type simple_constr_production_entry =
+    (production_level,unit) constr_entry_key
 
-(* Globalisation and type-checking of Grammar actions *)
-type entry_context = identifier list
-
-val set_constr_globalizer : 
-  (entry_context -> constr_expr -> constr_expr) -> unit
+(**********************************************************************)
+(* syntax modifiers                                                   *)
 
 type syntax_modifier =
   | SetItemLevel of string list * production_level
@@ -82,73 +48,3 @@ type syntax_modifier =
   | 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
-
-(*i
-val subst_unparsing_hunk : 
-  Names.substitution -> (Names.substitution -> 'pat -> 'pat) -> 
-  'pat unparsing_hunk -> 'pat unparsing_hunk
-i*)
-
-(* 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_ascii_syntax.ml b/parsing/g_ascii_syntax.ml
new file mode 100644
index 00000000..e6324e00
--- /dev/null
+++ b/parsing/g_ascii_syntax.ml
@@ -0,0 +1,81 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Rawterm
+open Topconstr
+open Libnames
+open Coqlib
+open Bigint
+
+exception Non_closed_ascii
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_kn dir id = Libnames.encode_kn (make_dir dir) (id_of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let ascii_module = ["Coq";"Strings";"Ascii"]
+
+let ascii_path = make_path ascii_module "ascii"
+
+let ascii_kn = make_kn ascii_module "ascii"
+let path_of_Ascii = ((ascii_kn,0),1)
+let static_glob_Ascii  = ConstructRef path_of_Ascii
+
+let make_reference id = find_reference "Ascii interpretation" ascii_module id
+let glob_Ascii = lazy (make_reference "Ascii")
+
+open Lazy
+
+let interp_ascii dloc p =
+  let rec aux n p = 
+     if n = 0 then [] else
+     let mp = p mod 2 in
+     RRef (dloc,if mp = 0 then glob_false else glob_true)
+     :: (aux (n-1) (p/2)) in
+  RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p)
+
+let interp_ascii_string dloc s =
+  let p = 
+    if String.length s = 1 then int_of_char s.[0]
+    else
+      if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
+      then int_of_string s
+      else
+	user_err_loc (dloc,"interp_ascii_string",
+	  str "Expects a single character or a three-digits ascii code") in
+  interp_ascii dloc p
+
+let uninterp_ascii r =
+  let rec uninterp_bool_list n = function
+    | [] when n = 0 -> 0
+    | RRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
+    | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
+    | _ -> raise Non_closed_ascii in
+  try 
+    let rec aux = function
+    | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+    | _ -> raise Non_closed_ascii in
+    Some (aux r)
+  with 
+   Non_closed_ascii -> None
+
+let make_ascii_string n =
+  if n>=32 && n<=126 then String.make 1 (char_of_int n)
+  else Printf.sprintf "%03d" n
+
+let uninterp_ascii_string r = option_app make_ascii_string (uninterp_ascii r)
+
+let _ =
+  Notation.declare_string_interpreter "char_scope"
+    (ascii_path,ascii_module)
+    interp_ascii_string
+    ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4
deleted file mode 100644
index c4badbc3..00000000
--- a/parsing/g_basevernac.ml4
+++ /dev/null
@@ -1,524 +0,0 @@
-(************************************************************************)
-(*  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
deleted file mode 100644
index b952305d..00000000
--- a/parsing/g_cases.ml4
+++ /dev/null
@@ -1,73 +0,0 @@
-(************************************************************************)
-(*  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
index 80dc69f1..9f7f7304 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -6,129 +6,129 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_constr.ml4,v 1.52.2.2 2004/11/17 12:48:35 herbelin Exp $ *)
+(* $Id: g_constr.ml4 8624 2006-03-13 17:38:17Z msozeau $ *)
 
 open Pcoq
 open Constr
+open Prim
 open Rawterm
 open Term
 open Names
 open Libnames
-open Prim
 open Topconstr
 
-(* Initialize the lexer *)
+open Util
+
 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 ? *)
+  [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; 
+    "end"; "as"; "let"; "if"; "then"; "else"; "return";
+    "Prop"; "Set"; "Type"; ".("; "_"; ".." ]
 
+let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw
 
-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 mk_cast = function
+    (c,(_,None)) -> c
+  | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, DEFAULTcast,ty)
 
-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 mk_lam = function
+    ([],c) -> c
+  | (bl,c) -> CLambdaN(constr_loc c, bl,c)
 
-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)
+let loc_of_binder_let = function
+  | LocalRawAssum ((loc,_)::_,_)::_ -> loc
+  | LocalRawDef ((loc,_),_)::_ -> loc
+  | _ -> dummy_loc
 
-open Util
+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 abstract_constr loc c = function
+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
-  | 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)
+  | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c
 
-(* 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)
+let rec index_and_rec_order_of_annot loc bl ann =
+  match names_of_local_assums bl,ann with
+    | [_], (None, r) -> 0, r
+    | lids, (Some x, ro) ->
+        let ids = List.map snd lids in
+        (try list_index (snd x) ids - 1, ro
+        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")
 
-(* 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)
+let mk_fixb (id,bl,ann,body,(loc,tyc)) =
+  let n,ro = index_and_rec_order_of_annot (fst id) bl ann in
+  let ty = match tyc with
+      Some ty -> ty
+    | None -> CHole loc in
+  (snd id,(n,ro),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")) (fst 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])
 
-(* Hack to parse "`id:...`" at level 0 without conflicting with
-   "`...`" from ZArith *)
-let test_ident_colon =
-  Gram.Entry.of_parser "test_ident_colon"
+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
-        | [("IDENT", _)] ->
-            begin match Stream.npeek 2 strm with
-              | [_; ("", ":")] -> ()
-              | _ -> raise Stream.Failure
-            end
+        | [("","(")] ->
+            (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 !Options.v7 then
 GEXTEND Gram
-  GLOBAL: operconstr lconstr constr sort global constr_pattern Constr.ident annot
-          (*ne_name_comma_list*);
+  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) ] ]
+  ;
   global:
     [ [ r = Prim.reference -> r
 
@@ -138,231 +138,197 @@ GEXTEND Gram
   constr_pattern:
     [ [ c = constr -> c ] ]
   ;
-  ne_constr_list:
-    [ [ cl = LIST1 constr -> cl ] ]
+  lconstr_pattern:
+    [ [ c = lconstr -> c ] ]
   ;
   sort:
     [ [ "Set"  -> RProp Pos
       | "Prop" -> RProp Null
       | "Type" -> RType None ] ]
   ;
-  constr:
-    [ [ c = operconstr LEVEL "8" -> c ] ]
-  ;
   lconstr:
-    [ [ c = operconstr LEVEL "10" -> c ] ]
+    [ [ c = operconstr LEVEL "200" -> c ] ]
+  ;
+  constr:
+    [ [ c = operconstr LEVEL "9" -> 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"; ".." ->
+    [ "200" RIGHTA
+      [ c = binder_constr -> c ]
+    | "100" RIGHTA
+      [ c1 = operconstr; ":"; c2 = binder_constr -> CCast(loc,c1,DEFAULTcast,c2)
+      | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1,DEFAULTcast,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]) ]
-    | "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) ] ]
+    | "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
+              CPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
+                CNotation(loc,"( _ )",[c])
+            | _ -> 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) ] ]
+  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 ] ]
   ;
-  (* 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 ] ]
+  appl_arg:
+    [ [ id = lpar_id_coloneq; c=lconstr; ")" ->
+	  (c,Some (loc,ExplByName id))
+      | c=constr -> (c,None) ] ]
   ;
-  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) ] ]
+  atomic_constr:
+    [ [ g=global -> CRef g
+      | s=sort -> CSort (loc,s)
+      | n=INT -> CPrim (loc, Numeral (Bigint.of_string n))
+      | s=string -> CPrim (loc, String s)
+      | "_" -> CHole loc
+      | "?"; id=ident -> CPatVar(loc,(false,id)) ] ]
   ;
-  ne_name_comma_list:
-    [ [ nal = LIST1 name SEP "," -> nal ] ]
+  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)
+    ] ]
   ;
-  name_comma_list_tail:
-    [ [ ","; idl = ne_name_comma_list -> idl
-      | -> [] ] ]
+  single_fix:
+    [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ]
   ;
-  opt_casted_constr:
-    [ [ c = constr;  ":"; t = constr -> CCast (loc, c, t)
-      | c = constr -> c ] ]
+  fix_kw:
+    [ [ "fix" -> true
+      | "cofix" -> false ] ]
   ;
-  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)
-    ] ]
+  fix_decl:
+    [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":=";
+        c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ]
   ;
-  ne_vardecls_list:
-    [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl
-      | id = vardecls -> [id] ] ]
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> (Some id, CStructRec)
+      | "{"; IDENT "wf"; id=name; rel=lconstr; "}" -> (Some id, CWfRec rel)
+      | ->  (None, CStructRec)
+      ] ]
   ;
-  binders:
-    [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ]
+  match_constr:
+    [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with";
+        br=branches; "end" -> CCases(loc,ty,ci,br) ] ]
   ;
-  simple_params:
-    [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c)
-      | idl = LIST1 name SEP "," -> (idl, CHole loc)
-    ] ]
+  case_item:
+    [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ]
   ;
-  simple_binders:
-    [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ]
+  pred_pattern:
+    [ [ ona = OPT ["as"; id=name -> snd id];
+        ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ]
   ;
-  ne_simple_binders_list:
-    [ [ bll = LIST1 simple_binders -> List.flatten bll ] ]
+  case_type:
+    [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
   ;
-  type_option:
-    [ [ ":"; c = constr -> c 
-      | -> CHole loc ] ]
+  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)
+    ] ]
   ;
-  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) ] ]
+  branches:
+    [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ]
   ;
-  fixbinders:
-    [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ]
+  eqn:
+    [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ]
   ;
-  cofixbinder:
-    [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr ->
-          (id, [],type_, def) ] ]
+  pattern:
+    [ "200" RIGHTA [ ]
+    | "100" LEFTA
+      [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ]
+    | "99" RIGHTA [ ]
+    | "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 = 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
+              CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
+                CPatNotation(loc,"( _ )",[p])
+            | _ -> p)
+      | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n))
+      | s = string -> CPatPrim (loc, String s) ] ]
+  ;
+  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,DEFAULTcast,t))
+    ] ]
   ;
-  cofixbinders:
-    [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ]
+  binder:
+    [ [ id=name -> ([id],CHole loc)
+      | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ]
   ;
-  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) ] ]
+  type_cstr:
+    [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ]
   ;
-END;;
+  END;;
diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4
deleted file mode 100644
index fe579e98..00000000
--- a/parsing/g_constrnew.ml4
+++ /dev/null
@@ -1,338 +0,0 @@
-(************************************************************************)
-(*  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.4 2005/09/21 14:47:33 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:
-    [ "200" RIGHTA [ ]
-    | "99" RIGHTA [ ]
-    | "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
index 7349a6f8..6ed22c7e 100644
--- a/parsing/g_ltac.ml4
+++ b/parsing/g_ltac.ml4
@@ -6,16 +6,14 @@
 (*         *       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 $ *)
+(* $Id: g_ltac.ml4 8129 2006-03-05 09:05:12Z herbelin $ *)
 
 open Pp
 open Util
-open Ast
 open Topconstr
 open Rawterm
 open Tacexpr
 open Vernacexpr
-open Ast
 open Pcoq
 open Prim
 open Tactic
@@ -37,163 +35,156 @@ let arg_of_expr = function
     TacArg a -> a
   | e -> Tacexp (e:raw_tactic_expr)
     
+let tacarg_of_expr = function
+  | TacArg (Reference r) -> TacCall (dummy_loc,r,[])
+  | 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 Vernac_.command tactic_expr tactic_arg constr_may_eval;
 
-(*
-  GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun;
-*)
+  tactic_expr:
+    [ "5" LEFTA
+      [ ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1)
+      | ta = tactic_expr; ";"; 
+	"["; lta = LIST0 OPT tactic_expr SEP "|"; "]" ->
+	  let lta = List.map (function None -> TacId [] | Some t -> t) lta in 
+	  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 = 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)
+      | b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
+          TacMatchContext (b,false,mrl)
+      | b = match_key; IDENT "reverse"; IDENT "goal"; "with";
+        mrl = match_context_list; "end" ->
+          TacMatchContext (b,true,mrl)
+      |	b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" ->
+          TacMatch (b,c,mrl)
+      | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacFirst l
+      | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacSolve l
+      | IDENT "complete" ; ta = tactic_expr -> TacComplete ta
+      | IDENT "idtac"; l = LIST0 message_token -> TacId l
+      | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
+	  l = LIST0 message_token -> TacFail (n,l)
+      | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg ->
+	  TacArg (TacExternal (loc,com,req,la))
+      | 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" -> tacarg_of_expr a
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
+      | a = may_eval_arg -> a
+      | r = reference -> Reference r
+      | a = tactic_atom -> a
+      | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ]
+  ;
+  may_eval_arg:
+    [ [ c = constr_eval -> ConstrMayEval c
+      | IDENT "fresh"; s = OPT STRING -> TacFreshId s ] ]
+  ;
+  constr_eval:
+    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
+          ConstrEval (rtc,c)
+      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
+          ConstrContext (id,c)
+      | IDENT "type"; IDENT "of"; c = Constr.constr ->
+          ConstrTypeOf c ] ]
+  ;
+  constr_may_eval: (* For extensions *)
+    [ [ c = constr_eval -> c
+      | c = Constr.constr -> ConstrTerm c ] ]
+  ;
+  tactic_atom:
+    [ [ id = METAIDENT -> MetaIdArg (loc,id)
+      | "()" -> TacVoid ] ]
+  ;
+  match_key:
+    [ [ "match" -> false ] ]
+  ;
   input_fun:
-    [ [ l = base_ident -> Some l
-      | "()" -> None ] ]
+    [ [ "_" -> None 
+      | l = ident -> Some l ] ]
   ;
   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) ] ]
+    [ [ 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 = 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 ] ]
+    [ [ 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)
-      | IDENT "_"; "->"; te = tactic_expr -> All te ] ]
+    [ [ 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)
-      | IDENT "_"; "->"; te = tactic_expr -> All te ] ]
+    [ [ 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 ] ]
   ;
-  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) ] ]
+  message_token:
+    [ [ id = identref -> MsgIdent (AI id)
+      | s = STRING -> MsgString s
+      | n = integer -> MsgInt n ] ]
   ;
 
   (* Definitions for tactics *)
-  deftok:
-    [ [ IDENT "Meta"
-      | IDENT "Tactic" ] ]
-  ;
   tacdef_body:
     [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr ->
 	  (name, TacFun (it, body))
@@ -204,10 +195,8 @@ GEXTEND Gram
     [ [ tac = tactic_expr -> tac ] ]
   ;
   Vernac_.command: 
-    [ [ deftok; "Definition"; b = tacdef_body ->
-          VernacDeclareTacticDefinition (false, [b])
-      | IDENT "Recursive"; deftok; "Definition"; 
-        l = LIST1 tacdef_body SEP "And" ->
+    [ [ IDENT "Ltac";
+        l = LIST1 tacdef_body SEP "with" ->
           VernacDeclareTacticDefinition (true, l) ] ]
   ;
   END
diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4
deleted file mode 100644
index 7492ac8c..00000000
--- a/parsing/g_ltacnew.ml4
+++ /dev/null
@@ -1,195 +0,0 @@
-(************************************************************************)
-(*  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.3 2005/06/21 15:31:12 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 constr_may_eval;
-
-  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:
-    [ [ c = constr_eval -> ConstrMayEval c
-      | IDENT "fresh"; s = OPT STRING -> TacFreshId s ] ]
-  ;
-  constr_eval:
-    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
-	  ConstrEval (rtc,c)
-      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
-	  ConstrContext (id,c)
-      | IDENT "type"; IDENT "of"; c = Constr.constr ->
-	  ConstrTypeOf c ] ]
-  ;
-  constr_may_eval: (* For extensions *)
-    [ [ c = constr_eval -> c
-      | c = Constr.constr -> ConstrTerm c ] ]
-  ;
-  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
index dd4ef517..ed8dda5c 100644
--- a/parsing/g_minicoq.ml4
+++ b/parsing/g_minicoq.ml4
@@ -6,7 +6,7 @@
 (*         *       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 $ *)
+(* $Id: g_minicoq.ml4 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Util
diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli
index e19b1163..345d9575 100644
--- a/parsing/g_minicoq.mli
+++ b/parsing/g_minicoq.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: g_minicoq.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4
deleted file mode 100644
index 0b542608..00000000
--- a/parsing/g_module.ml4
+++ /dev/null
@@ -1,47 +0,0 @@
-(************************************************************************)
-(*  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
index 46ef81f3..f764bc28 100644
--- a/parsing/g_natsyntax.ml
+++ b/parsing/g_natsyntax.ml
@@ -6,112 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_natsyntax.ml,v 1.19.2.2 2004/09/08 13:47:51 herbelin Exp $ *)
+(* $Id: g_natsyntax.ml 7988 2006-02-04 20:28:29Z herbelin $ *)
 
-(* This file to allow writing (3) for (S (S (S O))) 
-   and still write (S y) for (S y) *)
+(* This file defines the printer for natural numbers in [nat] *)
 
+(*i*)
 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 Bigint
 open Coqlib
-open Symbols
+open Notation
 open Pp
 open Util
 open Names
@@ -122,8 +31,7 @@ open Names
 (* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
 
 let nat_of_int dloc n =
-  match n with
-  | POS n ->
+  if is_pos_or_zero n then begin
       if less_than (of_string "5000") n & Options.is_verbose () then begin
 	warning ("You may experience stack overflow and segmentation fault\
                   \nwhile parsing numbers in nat greater than 5000");
@@ -132,30 +40,17 @@ let nat_of_int dloc n =
       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 
+	if n <> zero then 
 	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
 	else 
 	  acc
       in 
       mk_nat ref_O n
-  | NEG n ->
+    end
+  else
       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 *)
 
@@ -168,19 +63,7 @@ let rec int_of_nat = function
 	  
 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))
+    Some (int_of_nat p)
   with
     Non_closed_number -> None
 
@@ -188,42 +71,7 @@ let uninterp_nat_pattern p =
 (* 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
-()
+  Notation.declare_numeral_interpreter "nat_scope"
+    (nat_path,["Coq";"Init";"Datatypes"])
+    nat_of_int
+    ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true)
diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli
index 1471aed2..174be771 100644
--- a/parsing/g_natsyntax.mli
+++ b/parsing/g_natsyntax.mli
@@ -6,6 +6,6 @@
 (*         *       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*)
+(*i $Id: g_natsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Nice syntax for naturals. *)
diff --git a/parsing/g_natsyntaxnew.mli b/parsing/g_natsyntaxnew.mli
index 50d38133..97fb8791 100644
--- a/parsing/g_natsyntaxnew.mli
+++ b/parsing/g_natsyntaxnew.mli
@@ -6,6 +6,6 @@
 (*         *       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*)
+(*i $Id: g_natsyntaxnew.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Nice syntax for naturals. *)
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index ce6d4e2f..d5ca5e0c 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -6,133 +6,89 @@
 (*         *       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*)
+(*i $Id: g_prim.ml4 7922 2006-01-23 19:11:11Z herbelin $ i*)
 
-open Coqast
 open Pcoq
 open Names
 open Libnames
 open Topconstr
-open Prim
 
-let _ = reset_all_grammars()
+let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"]
+let _ = 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]
 
-GEXTEND Gram
-  GLOBAL: ident natural integer bigint string preident ast
-    astlist qualid reference dirpath identref name base_ident var hyp;
+let local_make_qualid l id = make_qualid (make_dirpath l) id
 
- (* Compatibility: Prim.var is a synonym of Prim.ident *)
-  var:
-    [ [ id = ident -> id ] ]
-  ;
-  hyp:
-    [ [ id = ident -> id ] ]
-  ;
-  metaident:
-    [ [ s = METAIDENT -> Nmeta (loc,s) ] ]
-  ;
+GEXTEND Gram
+  GLOBAL: 
+    bigint natural integer identref name ident var preident
+    fullyqualid qualid reference dirpath
+    ne_string string;
   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 ] ]
+    [ [ s = IDENT -> id_of_string s ] ]
   ;
-  natural:
-    [ [ i = INT -> local_make_posint i ] ]
+  var: (* as identref, but interpret as a term identifier in ltac *)
+    [ [ id = ident -> (loc,id) ] ]
   ;
-  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 ] ]
+  identref:
+    [ [ id = ident -> (loc,id) ] ]
   ;
   field:
-    [ [ s = FIELD -> local_id_of_string s ] ]
-  ;
-  dirpath:
-    [ [ id = base_ident; l = LIST0 field ->
-        local_make_dirpath (local_append l id) ] ]
+    [ [ s = FIELD -> id_of_string s ] ]
   ;
   fields:
-    [ [ id = field; (l,id') = fields -> (local_append l id,id')
+    [ [ id = field; (l,id') = fields -> (l@[id],id')
       | id = field -> ([],id)
       ] ]
   ;
+  fullyqualid:
+    [ [ id = ident; (l,id')=fields -> loc,id::List.rev (id'::l)
+      | id = ident -> loc,[id]
+      ] ]
+  ;
   basequalid:
-    [ [ id = base_ident; (l,id')=fields -> local_make_qualid (local_append l id) id'
-      | id = base_ident -> local_make_short_qualid id
+    [ [ id = ident; (l,id')=fields -> local_make_qualid (l@[id]) id'
+      | id = ident -> make_short_qualid id
       ] ]
   ;
-  qualid:
-    [ [ qid = basequalid -> loc, qid ] ]
+  name:
+    [ [ IDENT "_" -> (loc, Anonymous)
+      | id = ident -> (loc, Name id) ] ]
   ;
   reference:
-    [ [ id = base_ident; (l,id') = fields ->
-        Qualid (loc, local_make_qualid (local_append l id) id')
-      | id = base_ident -> Ident (loc,id)
+    [ [ id = ident; (l,id') = fields ->
+        Qualid (loc, local_make_qualid (l@[id]) id')
+      | id = 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
+    ] ]
+  ;
+  dirpath:
+    [ [ id = ident; l = LIST0 field ->
+        make_dirpath (l@[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)
-      ] ]
+  integer:
+    [ [ i = INT      -> int_of_string i
+      | "-"; i = INT -> - int_of_string i ] ]
   ;
-  (* 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 ] ]
+  natural:
+    [ [ i = INT -> int_of_string i ] ]
+  ;
+  bigint: (* Negative numbers are dealt with specially *)
+    [ [ i = INT -> (Bigint.of_string i) ] ]
   ;
 END
diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4
deleted file mode 100644
index c1875634..00000000
--- a/parsing/g_primnew.ml4
+++ /dev/null
@@ -1,84 +0,0 @@
-(************************************************************************)
-(*  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
index 5262b785..886b33e2 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -6,7 +6,7 @@
 (*         *       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 $ *)
+(* $Id: g_proofs.ml4 7936 2006-01-28 18:36:54Z herbelin $ *)
 
 open Pcoq
 open Pp
@@ -18,10 +18,9 @@ open Vernacexpr
 open Prim
 open Constr
 
-let thm_token = Gram.Entry.create "vernac:thm_token"
+let thm_token = G_vernac.thm_token
 
 (* Proof commands *)
-if !Options.v7 then
 GEXTEND Gram
   GLOBAL: command;
 
@@ -35,27 +34,29 @@ GEXTEND Gram
     | ":"; l = LIST1 IDENT -> l ] ]
   ;
   command:
-    [ [ IDENT "Goal"; c = Constr.constr -> VernacGoal c
-      | "Proof" -> VernacProof (Tacexpr.TacId "")
-      | "Proof"; "with"; ta = tactic -> VernacProof ta
+    [ [ IDENT "Goal"; c = lconstr -> VernacGoal c
+      | IDENT "Proof" -> VernacProof (Tacexpr.TacId [])
+      | 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
-      | "Qed" -> VernacEndProof (Proved (true,None))
+      | IDENT "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 "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
-      | "Proof"; c = Constr.constr -> VernacExactProof c
+      | IDENT "Proof"; c = lconstr -> VernacExactProof c
       | IDENT "Undo" -> VernacUndo 1
       | IDENT "Undo"; n = natural -> VernacUndo n
       | IDENT "Focus" -> VernacFocus None
@@ -63,20 +64,20 @@ GEXTEND Gram
       | 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 "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"; "Proof" -> VernacShow ShowProof
+      | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof
       | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false)
       | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
-      | IDENT "Explain"; "Proof"; l = LIST0 integer ->
+      | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id)
+      | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer ->
 	  VernacShow (ExplainProof l)
-      | IDENT "Explain"; "Proof"; IDENT "Tree"; l = LIST0 integer -> 
+      | 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
@@ -84,26 +85,13 @@ GEXTEND Gram
       | 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)
+      | 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 -> 
+      | IDENT "PrintConstr"; c = constr -> 
 	  VernacExtend ("PrintConstr",
 	    [Genarg.in_gen Genarg.rawwit_constr c])
       ] ];
@@ -112,24 +100,23 @@ GEXTEND Gram
     [ [ 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)) ] ]
+    [ [ IDENT "Resolve"; lc = LIST1 constr -> HintsResolve lc
+      | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc
+      | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid
+      | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc
+      | IDENT "Extern"; n = natural; c = constr_pattern ; "=>";
+          tac = tactic ->
+	  HintsExtern (n,c,tac)
+      | IDENT "Destruct"; 
+          id = ident; ":=";
+          pri = natural;
+          dloc = destruct_location;
+          hyptyp = constr_pattern;
+          "=>"; tac = tactic ->
+            HintsDestruct(id,pri,dloc,hyptyp,tac) ] ]
     ;
-  END
+  constr_body:
+    [ [ ":="; c = lconstr -> c
+      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c,Term.DEFAULTcast,t) ] ]
+  ;
+END
diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4
deleted file mode 100644
index 04bf7a8b..00000000
--- a/parsing/g_proofsnew.ml4
+++ /dev/null
@@ -1,126 +0,0 @@
-(************************************************************************)
-(*  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
index 8f5aad33..45647903 100644
--- a/parsing/g_rsyntax.ml
+++ b/parsing/g_rsyntax.ml
@@ -6,215 +6,47 @@
 (*         *       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
+open Bigint
 
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
+let make_path dir id = Libnames.make_path dir (id_of_string id)
+
+let r_path = make_path rdefinitions "R"
 
 (* TODO: temporary hack *)
-let make_path dir id = Libnames.encode_kn dir (id_of_string id)
+let make_path dir id = Libnames.encode_con dir (id_of_string id)
 
-let glob_R = ConstRef (make_path rdefinitions "R")
+let r_kn = make_path rdefinitions "R"
+let glob_R = ConstRef r_kn
 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)
+  if equal one n then RRef (dloc, glob_R1)
   else RApp(dloc,RRef (dloc,glob_Rplus),
             [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
 
@@ -227,12 +59,13 @@ let r_of_posint dloc n =
       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)
+  if n <> zero 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
+  if is_strictly_neg z then
+    RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) 
+  else
+    r_of_posint dloc z
 
 (**********************************************************************)
 (* Printing R via scopes                                              *)
@@ -268,8 +101,11 @@ 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)
+  | RApp (_,RRef (_,o), [a]) when o = glob_Ropp ->
+      let n = bignat_of_r a in
+      if n = zero then raise Non_closed_number;
+      neg n
+  | a -> bignat_of_r a
 
 let uninterp_r p =
   try
@@ -277,56 +113,11 @@ let uninterp_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)
+let _ = Notation.declare_numeral_interpreter "R_scope"
+  (r_path,["Coq";"Reals";"Rdefinitions"])
+  r_of_int
   ([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)],
+    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 ()
+    false)
diff --git a/parsing/g_string_syntax.ml b/parsing/g_string_syntax.ml
new file mode 100644
index 00000000..6d879fb2
--- /dev/null
+++ b/parsing/g_string_syntax.ml
@@ -0,0 +1,67 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Libnames
+open Topconstr
+open G_ascii_syntax
+open Rawterm
+open Coqlib
+
+exception Non_closed_string
+
+(* make a string term from the string s *)
+
+let string_module = ["Coq";"Strings";"String"]
+
+let string_path = make_path string_module "string"
+
+let string_kn = make_kn string_module "string"
+let static_glob_EmptyString  = ConstructRef ((string_kn,0),1)
+let static_glob_String  = ConstructRef ((string_kn,0),2)
+
+let make_reference id = find_reference "String interpretation" string_module id
+let glob_String = lazy (make_reference "String")
+let glob_EmptyString = lazy (make_reference "EmptyString")
+
+open Lazy
+
+let interp_string dloc s =
+  let le = String.length s in
+  let rec aux n = 
+     if n = le then RRef (dloc, force glob_EmptyString) else
+     RApp (dloc,RRef (dloc, force glob_String),
+       [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
+  in aux 0
+
+let uninterp_string r =
+  try 
+    let b = Buffer.create 16 in
+    let rec aux = function
+    | RApp (_,RRef (_,k),[a;s]) when k = force glob_String ->
+	(match uninterp_ascii a with
+	  | Some c -> Buffer.add_char b (Char.chr c); aux s
+	  | _ -> raise Non_closed_string)
+    | RRef (_,z) when z = force glob_EmptyString ->
+	Some (Buffer.contents b)
+    | _ ->
+	raise Non_closed_string
+    in aux r
+  with 
+   Non_closed_string -> None
+
+let _ =
+  Notation.declare_string_interpreter "string_scope"
+    (string_path,["Coq";"Strings";"String"])
+    interp_string
+    ([RRef (dummy_loc,static_glob_String); 
+      RRef (dummy_loc,static_glob_EmptyString)],
+     uninterp_string, true)
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index fd64defc..1974d8bc 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -6,75 +6,124 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_tactic.ml4,v 1.83.2.5 2005/05/15 12:47:04 herbelin Exp $ *)
+(* $Id: g_tactic.ml4 8651 2006-03-21 21:54:43Z jforest $ *)
 
 open Pp
-open Ast
 open Pcoq
 open Util
 open Tacexpr
 open Rawterm
 open Genarg
+open Topconstr
+
+let compute = Cbv all_flags
+
+let tactic_kw = [ "->"; "<-" ]
+let _ = 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)
+
+let guess_lpar_ipat s strm =
+  match Stream.npeek 1 strm with
+    | [("","(")] ->
+        (match Stream.npeek 2 strm with
+          | [_; ("",("("|"["))] -> ()
+          | [_; ("IDENT",_)] ->
+              (match Stream.npeek 3 strm with
+                | [_; _; ("", s')] when s = s' -> ()
+                | _ -> raise Stream.Failure)
+          | _ -> raise Stream.Failure)
+    | _ -> raise Stream.Failure
+
+let guess_lpar_coloneq =
+  Gram.Entry.of_parser "guess_lpar_coloneq" (guess_lpar_ipat ":=")
+
+let guess_lpar_colon =
+  Gram.Entry.of_parser "guess_lpar_colon" (guess_lpar_ipat ":")
+
 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
+let mk_fix_tac (loc,id,bl,ann,ty) =
+  let n =
+    match bl,ann with
+        [([_],_)], None -> 1
+      | _, 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,CProdN(loc,bl,ty))
 
-(* Functions overloaded by quotifier *)
+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,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))
+  try ElimOnIdent (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 open_constr
+  GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
+  bindings red_expr int_or_var open_constr casted_open_constr 
   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 
@@ -88,18 +137,10 @@ GEXTEND Gram
       |	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 ] ]
-  ;
   open_constr:
     [ [ c = constr -> ((),c) ] ]
-   ;
-  castedopenconstr:
+  ;
+  casted_open_constr:
     [ [ c = constr -> ((),c) ] ]
   ;
   induction_arg:
@@ -108,40 +149,45 @@ GEXTEND Gram
     ] ]
   ;
   quantified_hypothesis:
-    [ [ id = base_ident -> NamedHyp id
+    [ [ id = 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) ] ]
+    [ [ 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:
-    [ [ nl = LIST0 integer; c = constr -> (nl,c) ] ]
+    [ [ 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]
-      | IDENT "_" -> IntroWildcard
-      | id = base_ident -> IntroIdentifier id
+      | "("; tc = LIST0 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc]
+      | "()" -> IntroOrAndPattern [[]]
+      | "_" -> IntroWildcard
+      | "?" -> IntroAnonymous
+      | id = ident -> IntroIdentifier id
       ] ]
   ;
   simple_binding:
-    [ [ id = base_ident; ":="; c = constr -> (loc, NamedHyp id, c)
-      | n = natural; ":="; c = constr -> (loc, AnonHyp n, c) ] ]
+    [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c)
+      | "("; n = natural; ":="; c = lconstr; ")" -> (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) ] ]
+    [ [ 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) ] ]
@@ -149,222 +195,246 @@ GEXTEND Gram
   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
+    [ [ 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" -> 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 ] ]
+    [ [ 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 "vm_compute" -> CbvVm
+      | 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" -> 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
+    [ [ 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 "vm_compute" -> CbvVm
+      | 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 -> ExtraRedExpr s ] ]
   ;
   hypident:
-    [ [ id = id_or_meta -> id,[],(InHyp,ref None)
-      | "("; "Type"; "of"; id = id_or_meta; ")" ->
-          id,[],(InHypTypeOnly,ref None)
+    [ [ id = id_or_meta ->
+          id,InHyp
+      | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" ->
+	  id,InHypTypeOnly
+      | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" ->
+	  id,InHypValueOnly
     ] ]
   ;
+  hypident_occ:
+    [ [ (id,l)=hypident; occs=occurrences -> (id,occs,l) ] ]
+  ;
   clause:
-    [ [ "in"; idl = LIST1 hypident ->
-        {onhyps=Some idl;onconcl=false; concl_occs=[]}
-      | -> {onhyps=Some[];onconcl=true;concl_occs=[]} ] ]
+    [ [ "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
       | -> [] ] ]
   ;
-  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) ] ]
+    [ [ "("; id = ident; bl=LIST0 Constr.binder; ann=fixannot;
+        ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ]
   ;
-  cofixdecl:
-    [ [ id = base_ident; ":"; c = constr -> (id,c) ] ]
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
+      | -> None ] ]
   ;
   hintbases:
     [ [ "with"; "*" -> None
       | "with"; l = LIST1 IDENT -> Some l
       | -> Some [] ] ]
   ;
+  auto_using:
+    [ [ "using"; l = LIST1 constr SEP "," -> l
+      | -> [] ] ]
+  ;
   eliminator:
     [ [ "using"; el = constr_with_bindings -> el ] ]
   ;
   with_names:
-    [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ]
+    [ [ "as"; ipat = simple_intropattern -> ipat | -> IntroAnonymous ] ]
+  ;
+  by_tactic:
+    [ [ IDENT "by"; tac = tactic -> TacComplete tac | -> TacId [] ] ]
   ;
   simple_tactic:
     [ [ 
       (* Basic tactics *)
-        IDENT "Intros"; IDENT "until"; id = quantified_hypothesis -> 
+        IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> 
 	  TacIntrosUntil id
-      | IDENT "Intros"; pl = intropatterns -> TacIntroPattern pl
-      | IDENT "Intro"; id = base_ident; IDENT "after"; id2 = identref ->
+      | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl
+      | IDENT "intro"; id = ident; IDENT "after"; id2 = identref ->
 	  TacIntroMove (Some id, Some id2)
-      | IDENT "Intro"; IDENT "after"; id2 = identref ->
+      | 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 "intro"; id = ident -> TacIntroMove (Some id, None)
+      | IDENT "intro" -> TacIntroMove (None, None)
 
-      | IDENT "Assumption" -> TacAssumption
-      | IDENT "Exact"; c = constr -> TacExact c
+      | IDENT "assumption" -> TacAssumption
+      | IDENT "exact"; c = constr -> TacExact c
+      | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c
 
-      | IDENT "Apply"; cl = constr_with_bindings -> TacApply cl
-      | IDENT "Elim"; cl = constr_with_bindings; el = OPT eliminator ->
+      | 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 ->
+      | 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 = ident; n = natural -> TacFix (Some id,n)
+      | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl ->
+	  TacMutualFix (id,n,List.map mk_fix_tac fd)
+      | "cofix" -> TacCofix None
+      | "cofix"; id = ident -> TacCofix (Some id)
+      | "cofix"; id = ident; "with"; fd = LIST1 fixdecl ->
+	  TacMutualCofix (id,List.map mk_cofix_tac fd)
+
+      | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" ->
+	  TacLetTac (Names.Name id,b,nowhere)
+      | IDENT "pose"; b = constr ->
+	  TacLetTac (Names.Anonymous,b,nowhere)
+      | 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)
+
+      (* Begin compatibility *)
+      | IDENT "assert"; id = lpar_id_coloneq; c = lconstr; ")" -> 
+	  TacAssert (None,IntroIdentifier id,c)
+      | IDENT "assert"; id = lpar_id_colon; c = lconstr; ")"; tac=by_tactic -> 
+	  TacAssert (Some tac,IntroIdentifier id,c)
+      (* End compatibility *)
+
+      | IDENT "assert"; c = constr; ipat = with_names; tac = by_tactic ->
+	  TacAssert (Some tac,ipat,c)
+      | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = with_names ->
+	  TacAssert (None,ipat,c)
+
+      | IDENT "cut"; c = constr -> TacCut c
+      | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc
+      | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c
+    (*  | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")"; "in";
+	  hid = hypident ->
+	    let (id,(hloc,_)) = hid in
+              TacInstantiate (n,c,HypLocation (id,hloc))
+      | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")" ->
+            TacInstantiate (n,c,ConclLocation ()) *)
+
+      | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings ->
 	  TacSpecialize (n,lcb)
-      | IDENT "LApply"; c = constr -> TacLApply c
+      | 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;
+      | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
+          TacSimpleInduction h
+      | IDENT "induction"; lc = LIST1 induction_arg; ids = with_names; 
+	  el = OPT eliminator -> TacNewInduction (lc,el,ids)
+      | 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
+      | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis ->
+          TacSimpleDestruct h
+      | IDENT "destruct"; lc = LIST1 induction_arg; ids = with_names; 
+	  el = OPT eliminator -> TacNewDestruct (lc,el,ids)
+      | 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 int_or_var; 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 int_or_var; IDENT "Decomp"; p = OPT natural ->
+      | IDENT "trivial"; lems = auto_using; db = hintbases ->
+	  TacTrivial (lems,db)
+      | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
+	  TacAuto (n,lems,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 int_or_var; 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)
+      | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l)
+      | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], 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)
-      | IDENT "Exists"; bl = bindings -> TacSplit (true,bl)
-      | IDENT "Exists" -> TacSplit (true,NoBindings)
-      | IDENT "Constructor"; n = num_or_meta; l = with_bindings ->
+      | 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
+      | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t
 
       (* Equivalence relations *)
-      | IDENT "Reflexivity" -> TacReflexivity
-      | IDENT "Symmetry"; cls = clause -> TacSymmetry cls
-      | IDENT "Transitivity"; c = constr -> TacTransitivity c
+      | 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 ];
+      | 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";
+      | IDENT "simple"; IDENT "inversion";
 	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
 	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
-      | IDENT "Inversion"; 
+      | IDENT "inversion"; 
 	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
 	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
-      | IDENT "Inversion_clear"; 
+      | IDENT "inversion_clear"; 
 	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
 	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
-      | IDENT "Inversion"; hyp = quantified_hypothesis; 
+      | 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)
-
+      | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl)
     ] ]
   ;
 END;;
diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4
deleted file mode 100644
index 5ffd2fd7..00000000
--- a/parsing/g_tacticnew.ml4
+++ /dev/null
@@ -1,405 +0,0 @@
-(************************************************************************)
-(*  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.7 2005/05/15 12:47:05 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 -> 1
-      | _, 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 open_constr 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)
-      ] ]
-  ;
-  open_constr:
-    [ [ c = constr -> ((),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:
-    [ [ 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; OPT [ (* compat V8.0pl1 *) constr ] -> ExtraRedExpr s ] ]
-  ;
-  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 int_or_var; 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 int_or_var; 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
index 87183e18..18a424a8 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -6,35 +6,39 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_vernac.ml4,v 1.93.2.3 2004/10/12 10:11:28 herbelin Exp $ *)
+(* $Id: g_vernac.ml4 8624 2006-03-13 17:38:17Z msozeau $ *)
+(*i camlp4deps: "parsing/grammar.cma" i*)
 
+open Pp
+open Util
 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
+open Extend
+open Ppextend
+open Goptions
 
-let evar_constr loc = CHole loc
+open Prim
+open Constr
+open Vernac_
+open Module
 
-let class_rawexpr = G_basevernac.class_rawexpr
-let thm_token = G_proofs.thm_token
+let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
+let _ = 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 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 
+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 !Options.v7 then
+let no_hook _ _ = ()
 GEXTEND Gram
   GLOBAL: vernac gallina_ext;
   vernac:
@@ -44,163 +48,121 @@ GEXTEND Gram
       | 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)
-*)
+      | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
     ] ]
   ;
-    
-  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 ] ]
+    [ [ gln = OPT[n=natural; ":" -> n];
+        tac = subgoal_command -> tac gln ] ]
   ;
-  vernac_list_tail:
-    [ [ v = located_vernac; l = vernac_list_tail -> v :: l
-      | "]"; "." -> [] ] ]
+  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"
+   "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 !Options.v7 then
 GEXTEND Gram
-  GLOBAL: gallina gallina_ext thm_token;
+  GLOBAL: gallina gallina_ext thm_token def_body;
 
+  gallina:
+      (* Definition, Theorem, Variable, Axiom, ... *)
+    [ [ thm = thm_token; id = identref; bl = LIST0 binder_let; ":";
+        c = lconstr ->
+          VernacStartTheoremProof (thm, id, (bl, c), false, no_hook)
+      | stre = assumption_token; bl = assum_list -> 
+	  VernacAssumption (stre, bl)
+      | stre = assumptions_token; bl = assum_list ->
+	  test_plurial_form bl;
+	  VernacAssumption (stre, bl)
+      | IDENT "Boxed";"Definition";id = identref; b = def_body -> 
+	  VernacDefinition ((Global,true,Definition), id, b, no_hook)
+      | IDENT "Unboxed";"Definition";id = identref; b = def_body -> 
+	  VernacDefinition ((Global,false,Definition), id, b, no_hook)
+      | (f,d) = def_token; id = identref; b = def_body -> 
+          VernacDefinition (d, id, b, f)
+      (* Gallina inductive declarations *)
+      | f = finite_token;
+        indl = LIST1 inductive_definition SEP "with" ->
+          VernacInductive (f,indl)
+      | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (recs,true)
+      | IDENT "Unboxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (recs,false)
+       | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (recs,Options.boxed_definitions())
+      | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
+          VernacCoFixpoint (corecs,false)
+      | 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 ] ]
+      | IDENT "Remark" -> Remark
+      | IDENT "Corollary" -> Corollary
+      | IDENT "Proposition" -> Proposition
+      | IDENT "Property" -> Property ] ]
   ;
   def_token:
-    [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition)
-      | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition)
-      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, SubClass)
+    [ [ "Definition" -> 
+	no_hook, (Global, Options.boxed_definitions(), Definition)
+      | IDENT "Let" -> 
+	no_hook, (Local, Options.boxed_definitions(), Definition)
+      | IDENT "Example" -> 
+	no_hook, (Global, Options.boxed_definitions(), Example)
+      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, false, SubClass)
       | IDENT "Local"; IDENT "SubClass"  ->
-	  Class.add_subclass_hook, (Local, SubClass) ] ] 
+          Class.add_subclass_hook, (Local, false, SubClass) ] ] 
   ;
   assumption_token:
     [ [ "Hypothesis" -> (Local, Logical)
       | "Variable" -> (Local, Definitional)
       | "Axiom" -> (Global, Logical)
       | "Parameter" -> (Global, Definitional)
-      | IDENT "Conjecture" -> (Global,Conjectural) ] ]
+      | IDENT "Conjecture" -> (Global, Conjectural) ] ]
   ;
   assumptions_token:
     [ [ IDENT "Hypotheses" -> (Local, Logical)
       | IDENT "Variables" -> (Local, Definitional)
+      | IDENT "Axioms" -> (Global, Logical)
       | 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; bl = binders_list; ":"; c = constr ->
-         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 = 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 ] ]
@@ -208,192 +170,250 @@ GEXTEND Gram
   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] ] ]
+  (* Simple definitions *)
+  def_body:
+    [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr ->
+      (match c with
+          CCast(_,c,k,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) ] ]
   ;
-  oneind_old_style:
-    [ [ id = identref; ":"; c = constr; ":="; lc = constructor_list ->
-          (id,c,lc) ] ]
+  reduce:
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
+      | -> None ] ]
   ;
-  oneind:
-    [ [ id = identref; indpar = simple_binders_list; ":"; c = constr; 
-        ":="; lc = constructor_list; ntn = OPT decl_notation ->
+  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) ] ]
   ;
-  simple_binders_list:
-    [ [ bl = ne_simple_binders_list -> bl
+  constructor_list:
+    [ [ "|"; l = LIST1 constructor SEP "|" -> l
+      | l = LIST1 constructor SEP "|" -> l
       |  -> [] ] ]
   ;
+(*
+  csort:
+    [ [ s = sort -> CSort (loc,s) ] ]
+  ;
+*)
   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 ] ]
+  (* (co)-fixpoints *)
+  rec_definition:
+    [ [ id = ident; bl = LIST1 binder_let;
+        annot = rec_annotation; type_ = type_cstr; 
+	":="; def = lconstr; ntn = decl_notation ->
+          let names = List.map snd (names_of_local_assums bl) in
+          let ni =
+            match fst 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, snd annot), bl, type_, def),ntn) ] ]
+  ;
+  corec_definition:
+    [ [ id = ident; bl = LIST0 binder_let; c = type_cstr; ":=";
+        def = lconstr ->
+          (id,bl,c ,def) ] ]
+  ;
+  rec_annotation:
+    [ [ "{"; IDENT "struct"; id=IDENT; "}" -> (Some (id_of_string id), CStructRec)
+      | "{"; IDENT "wf"; id=IDENT; rel=lconstr; "}" -> (Some (id_of_string id), CWfRec rel) 
+      | ->  (None, CStructRec)
+      ] ]
   ;
-  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) ] ]
+  type_cstr:
+    [ [ ":"; c=lconstr -> c 
+      | -> CHole loc ] ]
   ;
-  specifrec:
-    [ [ l = LIST1 onerec SEP "with" -> l ] ]
+  (* Inductive schemes *)
+  scheme:
+    [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global;
+        IDENT "Sort"; s = sort ->
+          (id,dep,ind,s) ] ]
   ;
-  onecorec:
-    [ [ id = base_ident; ":"; c = constr; ":="; def = constr ->
-          (id,[],c,def) ] ]
+  dep_scheme:
+    [ [ IDENT "Induction" -> true
+      | IDENT "Minimality" -> false ] ]
   ;
-  specifcorec:
-    [ [ l = LIST1 onecorec SEP "with" -> l ] ]
+  (* 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; 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 ] ]
+    [ [ 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)) ] ]
   ;
-  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]) ] ]
+  constructor:
+    [ [ id = identref; l = LIST0 binder_let; 
+        coe = of_type_with_opt_coercion; c = lconstr ->
+	  (coe,(id,G_constr.mkCProdN loc l c))
+      | id = identref; l = LIST0 binder_let ->
+	  (false,(id,G_constr.mkCProdN loc l (CHole loc))) ] ]
   ;
-  csort:
-    [ [ s = sort -> CSort (loc,s) ] ]
+  of_type_with_opt_coercion:
+    [ [ ":>" -> true
+      | ":"; ">" -> true
+      | ":" -> false ] ]
   ;
+END
+
+
+(* Modules and Sections *)
+GEXTEND Gram
+  GLOBAL: gallina_ext module_expr module_type;
+
   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) ] ]
+    [ [ (* Interactive module declaration *)
+        IDENT "Module"; export = export_token; id = identref; 
+	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
+	mexpr_o = OPT is_module_expr ->
+	  VernacDefineModule (export, 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"; export = export_token; id = identref; 
+	bl = LIST0 module_binder; mty_o = of_module_type ->
+	  VernacDeclareModule (export, id, bl, mty_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) ] ]
   ;
-  module_binders:
-    [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ]
+  export_token:
+    [ [ IDENT "Import" -> Some false
+      | IDENT "Export" -> Some true
+      |  -> None ] ]
   ;
-  module_binders_list:
-    [ [ bls = LIST0 module_binders -> List.flatten bls ] ]
+  specif_token:
+    [ [ IDENT "Implementation" -> Some false
+      | IDENT "Specification" -> Some true
+      |  -> None ] ]
   ;
   of_module_type:
-    [ [ ":"; mty = Module.module_type -> (mty, true) 
-      | "<:"; mty = Module.module_type -> (mty, false) ] ]
+    [ [ ":"; mty = module_type -> (mty, true) 
+      | "<:"; mty = module_type -> (mty, false) ] ]
   ;
   is_module_type:
-    [ [ ":="; mty = Module.module_type -> mty ] ]
+    [ [ ":="; mty = module_type -> mty ] ]
   ;
   is_module_expr:
-    [ [ ":="; mexpr = Module.module_expr -> mexpr ] ]
+    [ [ ":="; mexpr = 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 *)
+  (* Module binder  *)
+  module_binder:
+    [ [ "("; export = export_token; idl = LIST1 identref; ":";
+         mty = module_type; ")" -> (export,idl,mty) ] ]
+  ;
 
-      | IDENT "End"; id = identref -> VernacEndSegment id
+  (* Module expressions *)
+  module_expr:
+    [ [ qid = qualid -> CMEident qid
+      | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2)
+      | "("; me = module_expr; ")" -> me
+(* ... *)
+      ] ]
+  ;
+  with_declaration:
+    [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr ->
+          CWith_Definition (fqid,c)
+      | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid ->
+	  CWith_Module (fqid,qid)
+      ] ]
+  ;
+  module_type:
+    [ [ qid = qualid -> CMTEident qid
+(* ... *)
+      | mty = module_type; "with"; decl = with_declaration -> 
+	  CMTEwith (mty,decl) ] ]
+  ;
+END
 
+(* Extensions: implicits, coercions, etc. *)   
+GEXTEND Gram
+  GLOBAL: gallina_ext;
 
-(* Transparent and Opaque *)
-      | IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
+  gallina_ext:
+    [ [ (* Transparent and Opaque *)
+        IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
       | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l)
 
-(* Canonical structure *)
+      (* 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
+          let s = 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) *)
+	    ((Global,false,CanonicalStructure),(dummy_loc,s),d,
+	     (fun _ -> Recordops.declare_canonical_structure))
 
-(* Coercions *)
+      (* 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)
+          let s = coerce_global_to_id qid in
+	  VernacDefinition ((Global,false,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)
+           let s = coerce_global_to_id qid in
+	  VernacDefinition ((Local,false,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)
@@ -406,114 +426,230 @@ GEXTEND Gram
       | 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)
-  ] ]
+      (* 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
 
-(* Modules management *)   
-if !Options.v7 then
 GEXTEND Gram
-  GLOBAL: command;
+  GLOBAL: command check_command class_rawexpr;
 
-  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 ] ->
+    [ [ 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)
-(*      | "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 ->
+      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
 	  VernacDeclareMLModule l
-      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
-      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl)
-  ] 
-]
+
+      (* 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) ] ]
   ;
-END
+  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
 
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: command;
+      | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
+      | IDENT "ML"; IDENT "Modules" -> PrintMLModules
+      | IDENT "Graph" -> PrintGraph
+      | IDENT "Classes" ->  PrintClasses
+      | IDENT "Ltac"; qid = global -> PrintLtac qid
+      | IDENT "Coercions" -> PrintCoercions
+      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
+         -> PrintCoercionPaths (s,t)
+      | IDENT "Canonical"; IDENT "Projections" -> PrintCanonicalConversions
+      | 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
+      | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s
+      | IDENT "Setoids" -> PrintSetoids
+      | 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
+      | IDENT "Module"; qid = global -> LocateModule 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;
 
+GEXTEND Gram
   command:
     [ [ 
-
 (* State management *)
         IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
-      | IDENT "Write"; IDENT "State"; s = STRING -> VernacWriteState s
+      | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s
       | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s
-      | IDENT "Restore"; IDENT "State"; s = STRING -> 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
+      | IDENT "BackTo"; n = natural -> VernacBackTo n
+      | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> 
+	  VernacBacktrack (n,m,p)
 
 (* Tactic Debugger *)
       |	IDENT "Debug"; IDENT "On" -> VernacDebug true
@@ -522,3 +658,86 @@ GEXTEND Gram
  ] ];
     END
 ;;
+
+(* Grammar extensions *)
+	  
+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,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,(s,modl),sc)
+
+     | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; 
+	 pil = LIST1 production_item; ":="; t = Tactic.tactic
+         -> VernacTacticNotation (n,pil,t)
+
+     | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; 
+	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]
+	 -> VernacSyntaxExtension (local,(s,l))
+
+     (* "Print" "Grammar" should be here but is in "command" entry in order 
+        to factorize with other "Print"-based vernac entries *)
+  ] ]
+  ;
+  tactic_level:
+    [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ]
+  ;
+  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,nt,po) ] ]
+  ;
+END
diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4
deleted file mode 100644
index 976cc259..00000000
--- a/parsing/g_vernacnew.ml4
+++ /dev/null
@@ -1,728 +0,0 @@
-(************************************************************************)
-(*  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.2 2004/10/12 10:10:29 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_let; ":";
-        c = lconstr ->
-          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_xml.ml4 b/parsing/g_xml.ml4
new file mode 100644
index 00000000..b4580750
--- /dev/null
+++ b/parsing/g_xml.ml4
@@ -0,0 +1,247 @@
+(************************************************************************)
+(*  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_xml.ml4 8624 2006-03-13 17:38:17Z msozeau $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Pcoq
+open Rawterm
+open Genarg
+open Tacexpr
+open Libnames
+
+open Nametab
+
+(* Generic xml parser without raw data *)
+
+type attribute = string * (loc * string)
+type xml = XmlTag of loc * string * attribute list * xml list
+
+let check_tags loc otag ctag =
+  if otag <> ctag then
+    user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ 
+      str "does not match open xml tag " ++ str otag)
+
+let xml_eoi = (Gram.Entry.create "xml_eoi" : xml Gram.Entry.e)
+
+GEXTEND Gram
+  GLOBAL: xml_eoi;
+
+  xml_eoi:
+    [ [ x = xml; EOI -> x ] ]
+  ;
+  xml:
+    [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml;
+        "<"; "/"; ctag = IDENT; ">"  ->
+	  check_tags loc otag ctag;
+	  XmlTag (loc,ctag,attrs,l)
+      | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" ->
+	  XmlTag (loc,tag,attrs,[])
+    ] ]
+  ;
+  attr:
+    [ [ name = IDENT; "="; data = STRING -> (name, (loc, data)) ] ]
+  ;
+END
+
+(* Interpreting attributes *)
+
+let nmtoken (loc,a) =
+  try int_of_string a
+  with Failure _ -> user_err_loc (loc,"",str "nmtoken expected")
+  
+let interp_xml_attr_qualid = function
+  | "uri", s -> qualid_of_string s
+  | _ -> error "Ill-formed xml attribute"
+
+let get_xml_attr s al = 
+  try List.assoc s al
+  with Not_found -> error ("No attribute "^s)
+
+(* Interpreting specific attributes *)
+
+let ident_of_cdata (loc,a) = id_of_string a
+
+let uri_of_data s =
+  let n = String.index s ':' in
+  let p = String.index s '.' in
+  let s = String.sub s (n+2) (p-n-2) in
+  for i=0 to String.length s - 1 do if s.[i]='/' then s.[i]<-'.' done;
+  qualid_of_string s
+
+let constant_of_cdata (loc,a) = Nametab.locate_constant (uri_of_data a)
+
+let global_of_cdata (loc,a) = Nametab.locate (uri_of_data a)
+
+let inductive_of_cdata a = match global_of_cdata a with
+    | IndRef (kn,_) -> kn
+    | _ -> failwith "kn"
+
+let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a))
+
+let sort_of_cdata (loc,a) = match a with
+  | "Prop" -> RProp Null
+  | "Set" -> RProp Pos
+  | "Type" -> RType None
+  | _ -> user_err_loc (loc,"",str "sort expected")
+
+let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al)
+
+let get_xml_inductive_kn al = inductive_of_cdata (get_xml_attr "uri" al)
+
+let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al)
+
+let get_xml_inductive al =
+  (get_xml_inductive_kn al, nmtoken (get_xml_attr "noType" al))
+
+let get_xml_constructor al =
+  (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al))
+
+let get_xml_name al =
+  try Name (ident_of_cdata (List.assoc "binder" al))
+  with Not_found -> Anonymous
+
+let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al)
+
+let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al)
+
+(* Interpreting constr as a rawconstr *)
+
+let rec interp_xml_constr = function
+  | XmlTag (loc,"REL",al,[]) ->
+      RVar (loc, get_xml_ident al)
+  | XmlTag (loc,"VAR",al,[]) -> failwith ""
+  | XmlTag (loc,"LAMBDA",al,[x1;x2]) ->
+      let na,t = interp_xml_decl x1 in
+      RLambda (loc, na, t, interp_xml_target x2)
+  | XmlTag (loc,"PROD",al,[x1;x2]) ->
+      let na,t = interp_xml_decl x1 in
+      RProd (loc, na, t, interp_xml_target x2)
+  | XmlTag (loc,"LETIN",al,[x1;x2]) ->
+      let na,t = interp_xml_def x1 in
+      RLetIn (loc, na, t, interp_xml_target x2) 
+  | XmlTag (loc,"APPLY",_,x::xl) ->
+      RApp (loc, interp_xml_constr x, List.map interp_xml_constr xl)
+  | XmlTag (loc,"META",al,xl) ->
+      failwith "META: TODO"
+  | XmlTag (loc,"CONST",al,[]) ->
+      RRef (loc, ConstRef (get_xml_constant al))
+  | XmlTag (loc,"MUTCASE",al,x::y::yl) -> (* BUGGE *)
+      failwith "XML MUTCASE TO DO";
+(*
+      ROrderedCase (loc,RegularStyle,Some (interp_xml_patternsType x),
+      interp_xml_inductiveTerm y,
+      Array.of_list (List.map interp_xml_pattern yl),
+      ref None)
+*)
+  | XmlTag (loc,"MUTIND",al,[]) ->
+      RRef (loc, IndRef (get_xml_inductive al))
+  | XmlTag (loc,"MUTCONSTRUCT",al,[]) ->
+      RRef (loc, ConstructRef (get_xml_constructor al))
+  | XmlTag (loc,"FIX",al,xl) ->
+      let li,lnct = List.split (List.map interp_xml_FixFunction xl) in
+      let ln,lc,lt = list_split3 lnct in
+      RRec (loc, RFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt)
+  | XmlTag (loc,"COFIX",al,xl) ->
+      let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in
+      RRec (loc, RCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt)
+  | XmlTag (loc,"CAST",al,[x1;x2]) ->
+      RCast (loc, interp_xml_term x1, DEFAULTcast, interp_xml_type x2)
+  | XmlTag (loc,"SORT",al,[]) ->
+      RSort (loc, get_xml_sort al)
+  | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s)
+
+and interp_xml_tag s = function
+  | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl)
+  | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", 
+    str "Expect tag " ++ str s ++ str " but find " ++ str s)
+
+and interp_xml_constr_alias s x =
+  match interp_xml_tag s x with
+    | (_,_,[x]) -> interp_xml_constr x
+    | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+and interp_xml_term x = interp_xml_constr_alias "term" x
+and interp_xml_type x = interp_xml_constr_alias "type" x
+and interp_xml_target x = interp_xml_constr_alias "target" x
+and interp_xml_body x = interp_xml_constr_alias "body" x
+and interp_xml_pattern x = interp_xml_constr_alias "pattern" x
+and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x
+and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x
+
+and interp_xml_decl_alias s x =
+  match interp_xml_tag s x with
+    | (_,al,[x]) -> (get_xml_name al, interp_xml_constr x)
+    | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+and interp_xml_def x = interp_xml_decl_alias "def" x
+and interp_xml_decl x = interp_xml_decl_alias "decl" x
+
+and interp_xml_recursionOrder x =
+  let (loc, al, l) = interp_xml_tag "RecursionOrder" x in
+  let (locs, s) = get_xml_attr "type" al in
+    match s with
+	"Structural" -> 
+	  (match l with [] -> RStructRec
+	     | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected none)"))
+      | "WellFounded" -> 
+	  (match l with
+	       [c] -> RWfRec (interp_xml_type c)
+	     | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)"))
+      | _ ->
+          user_err_loc (locs,"",str "invalid recursion order")
+
+
+and interp_xml_FixFunction x =
+  match interp_xml_tag "FixFunction" x with
+  | (loc,al,[x1;x2;x3]) ->
+      ((nmtoken (get_xml_attr "recIndex" al),
+	interp_xml_recursionOrder x1),
+       (get_xml_ident al, interp_xml_type x2, interp_xml_body x3))
+  | (loc,al,[x1;x2]) -> (* For backwards compatibility *)
+      ((nmtoken (get_xml_attr "recIndex" al), RStructRec),
+       (get_xml_ident al, interp_xml_type x1, interp_xml_body x2))
+  | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+and interp_xml_CoFixFunction x =
+  match interp_xml_tag "CoFixFunction" x with
+  | (loc,al,[x1;x2]) ->
+      (get_xml_ident al, interp_xml_type x1, interp_xml_body x2)
+    | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+(* Interpreting tactic argument *)
+
+let rec (interp_xml_tactic_expr : xml -> glob_tactic_expr) = function
+  | XmlTag (loc,"TACARG",[],[x]) ->
+      TacArg (interp_xml_tactic_arg x)
+  | _ -> error "Ill-formed xml tree"
+
+and interp_xml_tactic_arg = function
+  | XmlTag (loc,"TERM",[],[x]) ->
+      ConstrMayEval (ConstrTerm (interp_xml_constr x,None))
+  | XmlTag (loc,"CALL",al,xl) ->
+      let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in
+      TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl)
+(*
+  | XmlTag (loc,"TACTIC",[],[x]) ->
+      Tacexp (interp_xml_tactic_expr x)
+  | _ -> error "Ill-formed xml tree"
+*)
+  | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s)
+
+let parse_tactic_arg ch =
+  interp_xml_tactic_arg
+    (Pcoq.Gram.Entry.parse xml_eoi
+        (Pcoq.Gram.parsable (Stream.of_channel ch)))
diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml
index 2d8d2ddd..554040d1 100644
--- a/parsing/g_zsyntax.ml
+++ b/parsing/g_zsyntax.ml
@@ -6,148 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_zsyntax.ml,v 1.16.2.2 2004/11/10 13:00:44 herbelin Exp $ *)
+(* $Id: g_zsyntax.ml 7988 2006-02-04 20:28:29Z herbelin $ *)
 
-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
+open Bigint
 
 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                                        *)
 (**********************************************************************)
@@ -156,16 +26,19 @@ open Libnames
 open Rawterm
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 let positive_module = ["Coq";"NArith";"BinPos"]
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let positive_path = make_path positive_module "positive"
 
 (* 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 make_kn dir id = Libnames.encode_kn dir id
+
+let positive_kn = 
+  make_kn (make_dir positive_module) (id_of_string "positive")
+let glob_positive = IndRef (positive_kn,0)
+let path_of_xI = ((positive_kn,0),1)
+let path_of_xO = ((positive_kn,0),2)
+let path_of_xH = ((positive_kn,0),3)
 let glob_xI = ConstructRef path_of_xI
 let glob_xO = ConstructRef path_of_xO
 let glob_xH = ConstructRef path_of_xH
@@ -177,34 +50,18 @@ let pos_of_bignat dloc x =
   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) when q <> zero -> 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 error_non_positive dloc = 
   user_err_loc (dloc, "interp_positive",
-    str "No non-positive numbers in type \"positive\"!")
+    str "Only strictly positive numbers in type \"positive\"")
 
-let pat_interp_positive dloc = function
-  | NEG n -> error_non_positive dloc
-  | POS n ->
-     if is_nonzero n then pat_pos_of_bignat dloc n else error_non_positive dloc
+let interp_positive dloc n =
+  if is_strictly_pos n then pos_of_bignat dloc n
+  else error_non_positive dloc
 
 (**********************************************************************)
 (* Printing positive via scopes                                       *)
@@ -213,12 +70,12 @@ let pat_interp_positive dloc = function
 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
+  | RRef (_, a) when a = glob_xH -> Bigint.one
   | _ -> raise Non_closed_number
 
 let uninterp_positive p =
   try 
-    Some (POS (bignat_of_pos p))
+    Some (bignat_of_pos p)
   with Non_closed_number -> 
     None
 
@@ -226,61 +83,49 @@ let uninterp_positive p =
 (* 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); 
+let _ = Notation.declare_numeral_interpreter "positive_scope"
+  (positive_path,positive_module)
+  interp_positive
+  ([RRef (dummy_loc, glob_xI);
     RRef (dummy_loc, glob_xO); 
     RRef (dummy_loc, glob_xH)],
    uninterp_positive,
-   None)
+   true)
 
 (**********************************************************************)
 (* 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 n_kn = make_kn (make_dir binnat_module) (id_of_string "N")
+let glob_n = IndRef (n_kn,0)
+let path_of_N0 = ((n_kn,0),1)
+let path_of_Npos = ((n_kn,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
+let n_path = make_path binnat_module "N"
+
+let n_of_binnat dloc pos_or_neg n = 
+  if n <> zero 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 error_negative dloc =
+  user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\"")
 
-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")
+let n_of_int dloc n =
+  if is_pos_or_zero n then n_of_binnat dloc true n
+  else error_negative dloc
 
 (**********************************************************************)
 (* 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)
+  | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
+  | RRef (_, a) when a = glob_N0 -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_n p =
@@ -290,60 +135,45 @@ let uninterp_n p =
 (************************************************************************)
 (* 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)
+let _ = Notation.declare_numeral_interpreter "N_scope"
+  (n_path,binnat_module)
+  n_of_int
   ([RRef (dummy_loc, glob_N0); 
     RRef (dummy_loc, glob_Npos)],
   uninterp_n,
-  None)
+  true)
    
 (**********************************************************************)
 (* 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 binint_module = ["Coq";"ZArith";"BinInt"]
+let z_path = make_path binint_module "Z"
+let z_kn = make_kn (make_dir binint_module) (id_of_string "Z")
+let glob_z = IndRef (z_kn,0)
+let path_of_ZERO = ((z_kn,0),1)
+let path_of_POS = ((z_kn,0),2)
+let path_of_NEG = ((z_kn,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
+let z_of_int dloc n = 
+  if n <> zero then
+    let sgn, n =
+      if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n 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)
+  | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
+  | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | RRef (_, a) when a = glob_ZERO -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_z p =
@@ -354,56 +184,11 @@ let uninterp_z p =
 (************************************************************************)
 (* 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)
+let _ = Notation.declare_numeral_interpreter "Z_scope"
+  (z_path,binint_module)
+  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
-()
+  true)
diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli
index 6a7aeb14..11e0b6ac 100644
--- a/parsing/g_zsyntax.mli
+++ b/parsing/g_zsyntax.mli
@@ -6,6 +6,6 @@
 (*         *       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*)
+(*i $Id: g_zsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Nice syntax for integers. *)
diff --git a/parsing/g_zsyntaxnew.mli b/parsing/g_zsyntaxnew.mli
index 51bb6d41..5168722e 100644
--- a/parsing/g_zsyntaxnew.mli
+++ b/parsing/g_zsyntaxnew.mli
@@ -6,6 +6,6 @@
 (*         *       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*)
+(*i $Id: g_zsyntaxnew.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Nice syntax for integers. *)
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index bf5f3bfe..6119b86e 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -6,7 +6,7 @@
 (*         *       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*)
+(*i $Id: lexer.ml4 7870 2006-01-15 20:29:09Z herbelin $ i*)
 
 open Pp
 open Token
@@ -82,23 +82,22 @@ let check_ident str =
   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 >] ->
+    (* utf-8 Greek letters U0380-03FF *)
+    | [< ' ('\xCE' | '\xCF'); ' ('\x80'..'\xBF'); s >] -> loop_id s
+    | [< ''\xE2'; 'c2; 'c3; s >] ->
 	  (match c2, c3 with
-	      (* utf8 letter-like unicode 2100-214F *) 
-	    | (('\132', '\128'..'\191') | ('\133', '\128'..'\143')) ->
+	      (* utf-8 letter-like U2100-214F *)
+	    | ( ('\x84', '\x80'..'\xBF')
+	      | ('\x85', '\x80'..'\x8F')
+	      (* utf-8 subscript U2080-2089 *) 
+	      | ('\x82', '\x80'..'\x89')) ->
                 loop_id s 
-		(* utf8 symbols (see [parse_226_tail]) *)
-	    | (('\134'..'\143' | '\152'..'\155' | '\159'
-               | '\164'..'\171'),_) ->
+	      (* utf-8 symbols (see [parse_226_tail]) *)
+	    | (('\x86'..'\x8F' | '\x94'..'\x9B'
+               | '\xA4'..'\xA5' | '\xA8'..'\xAB'),_) ->
 		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
+	    | _ -> 
+		bad_token str)
     | [< _ = Stream.empty >] -> ()
     | [< >] -> bad_token str
   in
@@ -170,27 +169,26 @@ 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 ident_tail len = parser
+  | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] ->
+      ident_tail (store len c) s
+  (* utf-8 Greek letters U0380-03FF *)
+  | [< ' ('\xCE' | '\xCF' as c1); ' ('\x80'..'\xBF' as c2) ; s >] ->
+      ident_tail (store (store len c1) c2) s
+  | [< s >] ->
+      match Stream.peek s with
+      | Some '\xE2' -> 
+	  (match List.tl (Stream.npeek 3 s) with
+	    (* utf-8 subscript U2080-2089 *) 
+	  | ['\x82' as c2; ('\x80'..'\x89' as c3)]
+	    (* utf-8 letter-like U2100-214F part 1 *)
+	  | ['\x84' as c2; ('\x80'..'\xBF' as c3)]
+	    (* utf-8 letter-like U2100-214F part 2 *)
+	  | ['\x85' as c2; ('\x80'..'\x8F' as c3)] ->
+	    Stream.junk s; Stream.junk s; Stream.junk s;
+	    ident_tail (store (store (store len '\xE2') c2) c3) s
+	  | _ -> len)
+      | _ -> len
 
 let rec number len = parser
   | [< ' ('0'..'9' as c); s >] -> number (store len c) s
@@ -198,21 +196,11 @@ let rec number len = parser
 
 let escape len c = store len c
 
-let rec string_v8 bp len = parser
+let rec string 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
+      if esc then string bp (store len '"') s else len
+  | [< 'c; s >] -> string bp (store 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 _ -> ())
@@ -293,14 +281,14 @@ let rec comment bp = parser bp2
        s >] -> comment bp s
   | [< ''*';
        _ = parser
-         | [< '')' >] ep -> push_string "*)";
+         | [< '')' >] -> 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
+  | [< 'z; s >] -> real_push_char z; comment bp s
 
 (* Parse a special token, using the [token_tree] *)
 
@@ -334,100 +322,81 @@ type token_226_tail =
   | TokSymbol of string option
   | TokIdent of string
 
+(* 1110xxxx 10yyyyzz 10zztttt utf-8 codes for xxxx=0010 *)
 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) >] ->
+  | [< ''\x82' as c2; ' ('\x80'..'\x89' as c3);
+      (* utf-8 subscript U2080-2089 *) 
+      len = ident_tail (store (store (store 0 '\xE2') c2) c3) >] ->
+      TokIdent (get_buff len) 
+  | [< ''\x84' as c2; ' ('\x80'..'\xBF' as c3);
+      (* utf-8 letter-like U2100-214F part 1 *)
+      len = ident_tail (store (store (store 0 '\xE2') 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) >] ->
+  | [< ''\x85' as c2; ' ('\x80'..'\x8F' as c3);
+      (* utf-8 letter-like U2100-214F part 2 *)
+      len = ident_tail (store (store (store 0 '\xE2') 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 *)
+  | [< ' ('\x86'..'\x8F' | '\x94'..'\x9B' | '\xA4'..'\xA5' 
+         | '\xA8'..'\xAB' as c2); 'c3;
+      (* utf-8 arrows A U2190-21FF *)
+      (* utf-8 mathematical operators U2200-22FF *)
+      (* utf-8 miscellaneous technical U2300-23FF *)
+      (* utf-8 box drawing U2500-257F has ceiling, etc. *)
+      (* utf-8 block elements U2580-259F *)
+      (* utf-8 geom. shapes U25A0-25FF (has triangles, losange, etc) *)
+      (* utf-8 miscellaneous symbols U2600-26FF *)
+      (* utf-8 arrows B U2900-297F *)
+      (* utf-8 mathematical operators U2A00-2AFF *)
       t = special (progress_special c3 (progress_special c2 
-	(progress_special '\226' tk))) >] ->
+	(progress_special '\xE2' tk))) >] ->
       TokSymbol t
-  | [< len = ident_tail (store 0 '\226') >] ->
-      TokIdent (get_buff len)
-
+  | [< '_; '_ >] ->
+      (* Unsupported utf-8 code *)
+      TokSymbol None
 
 (* 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
+let parse_after_dot bp c = parser
+  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
+    len = ident_tail (store 0 c) >] ->
+      ("FIELD", get_buff len)
+  (* utf-8 Greek letters U0380-03FF *)
+  | [< ' ('\xCE' | '\xCF' as c1); ' ('\x80'..'\xBF' 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] *)
+  | [< ''\xE2'; 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 ->
+  | [< '' ' | '\t' | '\n' |'\r' as c; s >] ->
       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); 
+  (* utf-8 Greek letters U0380-03FF [CE80-CEBF and CF80-CFBF] *)
+  | [< ' ('\xCE' | '\xCF' as c1); ' ('\x80'..'\xBF' 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 ->
+  | [< ''\xE2'; t = parse_226_tail (Some !token_tree) >] ep ->
       comment_stop bp;
       (match t with
 	| TokSymbol (Some t) -> ("", t), (bp, ep)
@@ -435,21 +404,6 @@ let rec next_token = parser bp
 	| 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))
@@ -537,3 +491,41 @@ let tparse (p_con, p_prm) =
   else
     (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm)
   i*)
+
+(* Terminal symbols interpretation *)
+
+let is_ident_not_keyword s =
+  match s.[0] with
+    | 'a'..'z' | 'A'..'Z' | '_' -> not (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)
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 133bca65..f1ab6446 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -6,7 +6,7 @@
 (*         *       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*)
+(*i $Id: lexer.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
 
 open Pp
 open Util
@@ -48,3 +48,5 @@ val com_state: unit -> com_state
 val restore_com_state: com_state -> unit
 
 val set_xml_output_comment : (string -> unit) -> unit
+
+val terminal : string -> string * string
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
index a8922536..d743fffa 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml4
@@ -6,19 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pcoq.ml4,v 1.80.2.4 2005/06/21 15:31:12 herbelin Exp $ i*)
+(*i $Id: pcoq.ml4 7826 2006-01-09 22:00:34Z herbelin $ i*)
 
 open Pp
 open Util
 open Names
+open Extend
 open Libnames
 open Rawterm
 open Topconstr
-open Ast
 open Genarg
 open Tacexpr
 open Ppextend
-open Extend
 
 (* The lexer of Coq *)
 
@@ -52,7 +51,7 @@ let grammar_delete e rls =
        List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
     (List.rev rls)
 
-(* grammar_object is the superclass of all grammar entry *)
+(* grammar_object is the superclass of all grammar entries *)
 module type Gramobj =
 sig
   type grammar_object
@@ -65,8 +64,9 @@ struct
   let weaken_entry e = Obj.magic e
 end
 
+type entry_type = argument_type
 type grammar_object = Gramobj.grammar_object
-type typed_entry = entry_type * grammar_object G.Entry.e
+type typed_entry = argument_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
@@ -182,7 +182,6 @@ let create_univ s =
 
 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"
 
@@ -311,10 +310,7 @@ module Prim =
     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 var = gec_gen rawwit_var "var"
 
     let name = Gram.Entry.create "Prim.name"
     let identref = Gram.Entry.create "Prim.identref"
@@ -323,16 +319,11 @@ module Prim =
     let base_ident = Gram.Entry.create "Prim.base_ident"
 
     let qualid = Gram.Entry.create "Prim.qualid"
+    let fullyqualid = Gram.Entry.create "Prim.fullyqualid"
     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
 
 
@@ -372,15 +363,14 @@ module Tactic =
     (* Entries that can be refered via the string -> Gram.Entry.e table *)
     (* Typically for tactic user extensions *)
     let open_constr = 
-      make_gen_entry utactic rawwit_open_constr "open_constr"
-    let castedopenconstr = 
-      make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr"
+      make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr"
+    let casted_open_constr =
+      make_gen_entry utactic (rawwit_open_constr_gen true) "casted_open_constr"
     let constr_with_bindings =
       make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings"
     let bindings =
       make_gen_entry utactic rawwit_bindings "bindings"
-(*v7*) let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg"
-(*v8*) let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval"
+    let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval"
     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"
@@ -390,10 +380,14 @@ module Tactic =
 
     (* Main entries for ltac *)
     let tactic_arg = Gram.Entry.create "tactic:tactic_arg"
-    let tactic = make_gen_entry utactic rawwit_tactic "tactic"
+    let tactic_expr = Gram.Entry.create "tactic:tactic_expr"
+
+    let tactic_main_level = 5
+    let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic"
 
     (* Main entry for quotations *)
     let tactic_eoi = eoi_entry tactic
+
   end
 
 
@@ -411,32 +405,6 @@ module 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
@@ -445,88 +413,6 @@ GEXTEND Gram
   ;
 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
@@ -536,24 +422,9 @@ let default_action_parser =
    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 constr_level = string_of_int
 
-let default_levels_v8 =
+let default_levels =
   [200,Gramext.RightA;
    100,Gramext.RightA;
    99,Gramext.RightA;
@@ -563,20 +434,16 @@ let default_levels_v8 =
    1,Gramext.LeftA;
    0,Gramext.RightA]
 
-let default_pattern_levels_v8 =
+let default_pattern_levels =
   [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)]
+  ref [(default_levels, default_pattern_levels)]
 
 (* 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
@@ -599,48 +466,35 @@ let error_level_assoc p current expected =
      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 after = ref None 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
+        | (p,_ as pa)::l when p > n -> pa :: add_level (Some p) l
+        | (p,a)::l when p = n ->
+	    if admissible_assoc (a,assoc) then raise Exit;
+	    error_level_assoc p a (out_some assoc)
+	| 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
+	  if forpat then (ccurrent, add_level None pcurrent)
+	  else (add_level None 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))
+	else Some (Gramext.After (constr_level (out_some !after)))),
+	Some assoc, Some (constr_level n)
       with
-          Found a ->
+          Exit ->
             level_stack := current :: !level_stack;
 	    (* Just inherit the existing associativity and name (None) *)
-	    Some (Gramext.Level (constr_level2 (n,a))), None, None
+	    Some (Gramext.Level (constr_level n)), None, None
 
 let remove_levels n =
   level_stack := list_skipn n !level_stack
@@ -663,19 +517,19 @@ let adjust_level assoc from = function
   | (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))) ->
+  | (NumLevel n,BorderProd (Right,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)) ->
+  | (NumLevel n,BorderProd (Right,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
+  | (NumLevel n,BorderProd (Left,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 ->
+  | (NumLevel n,BorderProd (Left,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)) ->
+  | (NumLevel n,BorderProd (Left,Some a)) ->
       if a = Gramext.LeftA then Some (Some (n,true)) else Some None
   (* None means NEXT *)
   | (NextLevel,_) -> Some None
@@ -686,39 +540,11 @@ let adjust_level assoc from = function
 	| 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
+      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
@@ -734,42 +560,22 @@ let compute_entry allow_create adjust forpat = function
       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
+let get_constr_entry forpat = function
+  | ETConstr(200,()) when not forpat ->
+      weaken_entry Constr.binder_constr, None, false
+  | e ->
+      compute_entry true (fun (n,()) -> Some n) forpat e
 
 (* 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)
+  compute_entry false (adjust_level ass from) forpat en
 
 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'
+        BorderProd(Right, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false
+    | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n'
     | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint
       | ETPattern, ETPattern) -> true
     | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2'
@@ -778,15 +584,14 @@ let is_self from e =
 let is_binder_level from e =
   match from, e with
       ETConstr(200,()),
-      ETConstr(NumLevel 200,(BorderProd(false,_)|InternalProd)) ->
-        not !Options.v7
+      ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true
     | _ -> 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
+    Gramext.Snterml (Gram.Entry.obj Constr.operconstr,"200")
+  else if is_self from typ then
+    Gramext.Sself
   else
     match typ with
     | ETConstrList (typ',[]) ->
@@ -803,4 +608,15 @@ let rec symbol_of_production assoc from forpat typ =
       | (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)
+          Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev)
+
+(*****************************)
+(* Coercions between entries *)
+
+let coerce_reference_to_id = function
+  | Ident (_,id) -> id
+  | Qualid (loc,_) ->
+      user_err_loc (loc, "coerce_reference_to_id",
+        str "This expression should be a simple identifier")
+
+let coerce_global_to_id = coerce_reference_to_id
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 15a2c2cc..fe6fd083 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -6,18 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pcoq.mli,v 1.63.2.3 2005/06/21 15:31:12 herbelin Exp $ i*)
+(*i $Id: pcoq.mli 7826 2006-01-09 22:00:34Z herbelin $ i*)
 
 open Util
 open Names
 open Rawterm
-open Ast
+open Extend
 open Genarg
 open Topconstr
 open Tacexpr
 open Vernacexpr
 open Libnames
-open Extend
 
 (* The lexer and parser of Coq. *)
 
@@ -25,21 +24,23 @@ val lexer : Token.lexer
 
 module Gram : Grammar.S with type te = Token.t
 
+(* The superclass of all grammar entries *)
 type grammar_object
+
+(* The type of typed grammar objects *)
 type typed_entry
 
-val type_of_typed_entry : typed_entry -> Extend.entry_type
+type entry_type = argument_type
+
+val type_of_typed_entry : typed_entry -> 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 ->
+  grammar_object Gram.Entry.e -> Gramext.position option ->
     (string option * Gramext.g_assoc option *
      (Token.t Gramext.g_symbol list * Gramext.g_action) list) list
     -> unit
@@ -80,22 +81,6 @@ val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_
 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
@@ -113,20 +98,15 @@ module Prim :
     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 bigint : Bigint.bigint Gram.Entry.e
     val integer : int Gram.Entry.e
     val string : string Gram.Entry.e
     val qualid : qualid located Gram.Entry.e
+    val fullyqualid : identifier list 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
+    val var : identifier located Gram.Entry.e
   end
 
 module Constr :
@@ -157,17 +137,18 @@ module Tactic :
   sig
     open Rawterm
     val open_constr : open_constr_expr Gram.Entry.e
-    val castedopenconstr : open_constr_expr Gram.Entry.e
+    val casted_open_constr : open_constr_expr Gram.Entry.e
     val constr_with_bindings : constr_expr with_bindings Gram.Entry.e
     val bindings : constr_expr bindings Gram.Entry.e
-(*v7*) val constrarg : (constr_expr,reference) may_eval Gram.Entry.e
-(*v8*) val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e
+    val constr_may_eval : (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_expr : raw_tactic_expr Gram.Entry.e
+    val tactic_main_level : int
     val tactic : raw_tactic_expr Gram.Entry.e
     val tactic_eoi : raw_tactic_expr Gram.Entry.e
   end
@@ -183,7 +164,10 @@ module Vernac_ :
     val vernac_eoi : vernac_expr Gram.Entry.e
   end
 
-val reset_all_grammars : unit -> unit
+(* Binding entry names to campl4 entries *)
+
+val symbol_of_production : Gramext.g_assoc option -> constr_entry ->
+  bool -> constr_production_entry -> Token.t Gramext.g_symbol
 
 (* Registering/resetting the level of an entry *)
 
@@ -192,3 +176,5 @@ val find_position :
     Gramext.position option * Gramext.g_assoc option * string option
 
 val remove_levels : int -> unit 
+
+val coerce_global_to_id : reference -> identifier
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
index ddf008cb..a43463c6 100644
--- a/parsing/ppconstr.ml
+++ b/parsing/ppconstr.ml
@@ -6,44 +6,64 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppconstr.ml,v 1.32.2.2 2004/12/29 10:17:11 herbelin Exp $ *)
+(* $Id: ppconstr.ml 8624 2006-03-13 17:38:17Z msozeau $ *)      
 
 (*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
+open Rawterm
+open Constrextern
+open Termops
 (*i*)
 
+let sep_p = fun _ -> str"."
+let sep_v = fun _ -> str"," ++ spc()
+let sep_pp = fun _ -> str":"
+let sep_bar = fun _ -> spc() ++ str"| "
+let pr_tight_coma () = str "," ++ cut ()
+
 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 lannot = 100
+let lprod = 200
+let llambda = 200
+let lif = 200
+let lletin = 200
+let lfix = 200
+let larrow = 90
+let lcast = 100
+let larg = 9
 let lapp = 10
-let ltop = (8,E)
+let lposint = 0
+let lnegint = 35 (* must be consistent with Notation "- x" *)
+let ltop = (200,E)
+let lproj = 1
+let lsimple = (1,E)
+
+let prec_less child (parent,assoc) =
+  if parent < 0 && child = lprod then true
+  else
+    let parent = abs parent in
+    match assoc with
+      | E -> (<=) child parent
+      | L -> (<) child parent
+      | Prec n -> child<=n
+      | Any -> true
 
-let prec_less child (parent,assoc) = match assoc with
-  | E -> child <= parent
-  | L -> child < parent
-  | Prec n -> child <= n
-  | Any -> true
+let prec_of_prim_token = function
+  | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint
+  | String _ -> latom
 
 let env_assoc_value v env =
   try List.nth env (v-1)
-  with Not_found -> anomaly "Inconsistent environment for pretty-print rule"
+  with Not_found -> anomaly ("Inconsistent environment for pretty-print rule")
 
 let decode_constrlist_value = function
   | CAppExpl (_,_,l) -> l
@@ -54,7 +74,7 @@ let decode_patlist_value = function
   | CPatCstr (_,_,l) -> l
   | _ -> anomaly "Ill-formed list argument of notation"
 
-open Symbols
+open Notation
 
 let rec print_hunk n decode pr env = function
   | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env)
@@ -73,315 +93,596 @@ 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
+  strm ++ str ("%"^key)
 
-open Rawterm
+let surround p = hov 1 (str"(" ++ p ++ str")")
+
+let pr_located pr ((b,e),x) =
+  if Options.do_translate() && (b,e)<>dummy_loc then
+    let (b,e) = unloc (b,e) in
+    comment b ++ pr x ++ comment e
+  else pr x
+
+let pr_com_at n =
+  if Options.do_translate() && n <> 0 then comment n 
+  else mt()
+
+let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
 
-let pr_opt pr = function
+let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
+
+let pr_optc pr = function
   | None -> mt ()
-  | Some x -> spc () ++ pr x
+  | Some x -> pr_sep_com spc pr x
 
-let pr_universe u = str "<univ>"
+let pr_universe = Univ.pr_uni 
 
 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_id = pr_id
+let pr_name = pr_name
+let pr_qualid = pr_qualid
 
 let pr_expl_args pr (a,expl) =
-  pr_explicitation expl ++ pr (lapp,L) a
+  match expl with
+  | None -> pr (lapp,L) a
+  | Some (_,ExplByPos n) ->
+      anomaly("Explicitation by position not implemented")
+  | Some (_,ExplByName id) -> 
+      str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
 
 let pr_opt_type pr = function
   | CHole _ -> mt ()
-  | t -> str ":" ++ pr ltop t
-
-let pr_tight_coma () = str "," ++ cut ()
+  | t -> cut () ++ str ":" ++ pr t
 
-let pr_name = function
-  | Anonymous -> str "_"
-  | Name id -> pr_id id
-
-let pr_located pr (loc,x) = pr x
+let pr_opt_type_spc pr = function
+  | CHole _ -> mt ()
+  | t ->  str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
+
+let pr_lident (b,_ as loc,id) =
+  if loc <> dummy_loc then
+    let (b,_) = unloc loc in
+    pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
+  else pr_id id
+
+let pr_lname = function
+    (loc,Name id) -> pr_lident (loc,id)
+  | lna -> pr_located pr_name lna
+
+let pr_or_var pr = function
+  | Genarg.ArgArg x -> pr x
+  | Genarg.ArgVar (loc,s) -> pr_lident (loc,s)
+
+let pr_prim_token = function
+  | Numeral n -> Bigint.pr_bigint n
+  | String s -> qs s
+
+let las = lapp
+let lpator = 100
+
+let rec pr_patt sep inh p =
+  let (strm,prec) = match p with
+  | CPatAlias (_,p,id) ->
+      pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
+  | CPatCstr (_,c,[]) -> pr_reference c, latom
+  | CPatCstr (_,c,args) ->
+      pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
+  | CPatAtom (_,None) -> str "_", latom
+  | CPatAtom (_,Some r) -> pr_reference r, latom
+  | CPatOr (_,pl) ->
+      hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
+  | CPatNotation (_,"( _ )",[p]) ->
+      pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
+  | CPatNotation (_,s,env) -> pr_patnotation (pr_patt mt) s env
+  | CPatPrim (_,p) -> pr_prim_token p, latom
+  | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1
+  in
+  let loc = cases_pattern_loc p in
+  pr_with_comments loc
+    (sep() ++ if prec_less prec inh then strm else surround strm)
+
+let pr_patt = pr_patt mt
+
+
+let pr_eqn pr (loc,pl,rhs) =
+  spc() ++ hov 4
+    (pr_with_comments loc
+      (str "| " ++
+      hov 0 (prlist_with_sep sep_v (pr_patt ltop) pl ++ str " =>") ++
+      pr_sep_com spc (pr ltop) rhs))
+
+let begin_of_binder = function
+    LocalRawDef((loc,_),_) -> fst (unloc loc)
+  | LocalRawAssum((loc,_)::_,_) -> fst (unloc loc)
+  | _ -> assert false
+
+let begin_of_binders = function
+  | b::_ -> begin_of_binder b
+  | _ -> 0
+
+let pr_binder many pr (nal,t) =
+  match t with
+  | CHole _ -> prlist_with_sep spc pr_lname nal
+  | _ ->
+    let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in
+    hov 1 (if many then surround s else s)
+
+let pr_binder_among_many pr_c = function
+  | LocalRawAssum (nal,t) ->
+      pr_binder true pr_c (nal,t)
+  | LocalRawDef (na,c) ->
+      let c,topt = match c with
+        | CCast(_,c,_,t) -> c, t
+        | _ -> c, CHole dummy_loc in
+      hov 1 (surround
+        (pr_lname na ++ pr_opt_type pr_c topt ++
+         str":=" ++ cut() ++ pr_c c))
+
+let pr_undelimited_binders pr_c =
+  prlist_with_sep spc (pr_binder_among_many pr_c)
+
+let pr_delimited_binders kw pr_c bl =
+  let n = begin_of_binders bl in
+  match bl with
+  | [LocalRawAssum (nal,t)] ->
+      pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,t)
+  | LocalRawAssum _ :: _ as bdl ->
+      pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl
+  | _ -> assert false
 
 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
-
+  hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++
+         pr_sep_com (fun () -> brk(0,1)) (pr ltop) a)
+
+let rec extract_prod_binders = function
+(*  | CLetIn (loc,na,b,c) as x ->
+      let bl,c = extract_prod_binders c in
+      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
+  | CProdN (loc,[],c) ->
+      extract_prod_binders c
+  | CProdN (loc,(nal,t)::bl,c) ->
+      let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
+      LocalRawAssum (nal,t) :: bl, c
+  | c -> [], c
+
+let rec extract_lam_binders = function
+(*  | CLetIn (loc,na,b,c) as x ->
+      let bl,c = extract_lam_binders c in
+      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
+  | CLambdaN (loc,[],c) ->
+      extract_lam_binders c
+  | CLambdaN (loc,(nal,t)::bl,c) ->
+      let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
+      LocalRawAssum (nal,t) :: bl, c
+  | c -> [], 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))
+let rename na na' t c =
+  match (na,na') with
+    | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c)
+    | (_,Name id), (_,Anonymous) -> (na,t,c)
+    | _ -> (na',t,c)
+  
+let split_product na' = function
+  | CArrow (loc,t,c) -> (na',t,c)
+  | CProdN (loc,[[na],t],c) -> rename na na' t c
+  | CProdN (loc,([na],t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
+  | CProdN (loc,(na::nal,t)::bl,c) ->
+      rename na 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 merge_binders (na1,ty1) cofun (na2,ty2) codom =
+  let na =
+    match snd na1, snd na2 with
+        Anonymous, Name id ->
+          if occur_var_constr_expr id cofun then
+            failwith "avoid capture"
+          else na2
+      | Name id, Anonymous ->
+          if occur_var_constr_expr id codom then
+            failwith "avoid capture"
+          else na1
+      | Anonymous, Anonymous -> na1
+      | Name id1, Name id2 ->
+          if id1 <> id2 then failwith "not same name" else na1 in
+  let ty =
+    match ty1, ty2 with
+        CHole _, _ -> ty2
+      | _, CHole _ -> ty1
+      | _ ->
+          Constrextern.check_same_type ty1 ty2;
+          ty2 in
+  (LocalRawAssum ([na],ty), codom)
+            
+let rec strip_domain bvar cofun c =
+  match c with
+    | CArrow(loc,a,b) ->
+        merge_binders bvar cofun ((dummy_loc,Anonymous),a) b
+    | CProdN(loc,[([na],ty)],c') ->
+        merge_binders bvar cofun (na,ty) c'
+    | CProdN(loc,([na],ty)::bl,c') ->
+        merge_binders bvar cofun (na,ty) (CProdN(loc,bl,c'))
+    | CProdN(loc,(na::nal,ty)::bl,c') ->
+        merge_binders bvar cofun (na,ty) (CProdN(loc,(nal,ty)::bl,c'))
+    | _ -> failwith "not a product"
+
+(* Note: binder sharing is lost *)
+let rec strip_domains (nal,ty) cofun c =
+  match nal with
+      [] -> assert false
+    | [na] ->
+        let bnd, c' = strip_domain (na,ty) cofun c in
+        ([bnd],None,c')
+    | na::nal ->
+        let f = CLambdaN(dummy_loc,[(nal,ty)],cofun) in
+        let bnd, c1 = strip_domain (na,ty) f c in
+        (try
+          let bl, rest, c2 = strip_domains (nal,ty) cofun c1 in
+          (bnd::bl, rest, c2)
+        with Failure _ -> ([bnd],Some (nal,ty), c1))
+
+(* Re-share binders *)
+let rec factorize_binders = function
+  | ([] | [_] as l) -> l
+  | LocalRawAssum (nal,ty) as d :: (LocalRawAssum (nal',ty')::l as l') ->
+      (try
+	let _ = Constrextern.check_same_type ty ty' in
+	factorize_binders (LocalRawAssum (nal@nal',ty)::l)
+      with _ ->
+	d :: factorize_binders l')
+  | d :: l -> d :: factorize_binders l
+
+(* Extract lambdas when a type constraint occurs *)
+let rec extract_def_binders c ty =
+  match c with
+    | CLambdaN(loc,bvar::lams,b) ->
+        (try
+          let f = CLambdaN(loc,lams,b) in
+          let bvar', rest, ty' = strip_domains bvar f ty in
+          let c' =
+            match rest, lams with
+                None,[] -> b
+              | None, _ -> f
+              | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in
+          let (bl,c2,ty2) = extract_def_binders c' ty' in
+          (factorize_binders (bvar'@bl), c2, ty2)
+        with Failure _ ->
+          ([],c,ty))
+    | _ -> ([],c,ty)
 
 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 (na,t,typ) = split_product na 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
+    (LocalRawAssum ([na],t)::bl,typ,def)
+
+let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
+  let pr_body =
+    if dangling_with_for then pr_dangling else pr in
+  pr_id id ++ str" " ++
+  hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++
+  pr_opt_type_spc pr t ++ str " :=" ++
+  pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
+
+let pr_fixdecl pr prd dangling_with_for (id,(n,ro),bl,t,c) =
+  let annot =
+    let ids = names_of_local_assums bl in
+      match ro with
+	  CStructRec ->
+	    if List.length ids > 1 then 
+	      spc() ++ str "{struct " ++ pr_name (snd (List.nth ids n)) ++ str"}"
+	    else mt() 
+	| CWfRec c ->
+	    spc () ++ str "{wf " ++ pr lsimple c ++ pr_name (snd (List.nth ids n)) ++ str"}"
+  in
+    pr_recursive_decl pr prd dangling_with_for id bl annot 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_cofixdecl pr prd dangling_with_for (id,bl,t,c) =
+  pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
 
-let pr_recursive fix pr_decl id = function
+let pr_recursive 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 "}")
+  | [d1] -> pr_decl false d1
+  | dl ->
+      prlist_with_sep (fun () -> fnl() ++ str "with ")
+        (pr_decl true) dl ++
+      fnl() ++ str "for " ++ pr_id id
+
+let is_var id = function
+  | CRef (Ident (_,id')) when id=id' -> true
+  | _ -> false
+
+let tm_clash = function
+  | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) 
+      when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false)
+	nal
+      -> Some id
+  | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) 
+      when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false)
+	nal
+      -> Some id
+  | _ -> None
+
+let pr_case_item pr (tm,(na,indnalopt)) =
+  hov 0 (pr (lcast,E) tm ++
+(*
+  (match na with
+    | Name id when not (is_var id tm) -> spc () ++ str "as " ++  pr_id id
+    | Anonymous when tm_clash (tm,indnalopt) <> None ->
+	(* hide [tm] name to avoid conflicts *)
+	spc () ++ str "as _" (* ++ pr_id (out_some (tm_clash (tm,indnalopt)))*)
+    | _ -> mt ()) ++
+*)
+  (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
+    | Some na -> spc () ++ str "as " ++  pr_name na
+    | None -> mt ()) ++
+  (match indnalopt with
+    | None -> mt ()
+(*
+    | Some (_,ind,nal) ->
+        spc () ++ str "in " ++ 
+        hov 0 (pr_reference ind ++ prlist (pr_arg pr_name) nal))
+*)
+    | Some t -> spc () ++ str "in " ++ pr lsimple t))
 
-let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr)
-let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr)
+let pr_case_type pr po =
+  match po with
+    | None | Some (CHole _) -> mt()
+    | Some p ->
+        spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p)
 
-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_return_type pr po = pr_case_type pr po
 
-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_simple_return_type pr na po =
+  (match na with
+    | Some (Name id) ->
+        spc () ++ str "as " ++  pr_id id
+    | _ -> mt ()) ++
+  pr_case_type pr po
 
 let pr_proj pr pr_app a f l =
-  hov 0 (pr (latom,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
+  hov 0 (pr lsimple 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_appexpl pr f l =
+      hov 2 (
+	str "@" ++ pr_reference f ++
+	prlist (pr_sep_com spc (pr (lapp,L))) 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)
+  hov 2 (
+    pr (lapp,L) a  ++ 
+    prlist (fun a -> spc () ++ pr_expl_args pr a) l)
 
-let rec pr inherited a =
+let rec pr sep 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) *)
+  | CFix (_,id,fix) ->
+      hov 0 (str"fix " ++
+             pr_recursive
+               (pr_fixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) fix),
+      lfix
+  | CCoFix (_,id,cofix) ->
+      hov 0 (str "cofix " ++
+             pr_recursive
+              (pr_cofixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) cofix),
+      lfix
+  | CArrow (_,a,b) ->
+      hov 0 (pr mt (larrow,L) a ++ str " ->" ++
+             pr (fun () ->brk(1,0)) (-larrow,E) b),
+      larrow
+  | CProdN _ ->
+      let (bl,a) = extract_prod_binders a in
       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 2 (pr_delimited_binders (fun () -> str"forall" ++ spc())
+                 (pr mt ltop) bl) ++
+        str "," ++ pr spc ltop a),
+      lprod
+  | CLambdaN _ ->
+      let (bl,a) = extract_lam_binders a in
       hov 0 (
-	hov 0 (
-	pr_annotation pr po ++
+        hov 2 (pr_delimited_binders (fun () -> str"fun" ++ spc())
+                 (pr mt ltop) bl) ++
+
+        str " =>" ++ pr spc ltop a),
+      llambda
+  | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
+      when x=x' ->
+      hv 0 (
+        hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++
+        pr spc ltop b),
+      lletin
+  | CLetIn (_,x,a,b) ->
+      hv 0 (
+        hov 2 (str "let " ++ pr_lname x ++ str " :=" ++
+               pr spc ltop a ++ str " in") ++
+        pr spc ltop b),
+      lletin
+  | CAppExpl (_,(Some i,f),l) ->
+      let l1,l2 = list_chop i l in
+      let c,l1 = list_sep_last l1 in
+      let p = pr_proj (pr mt) pr_appexpl c f l1 in
+      if l2<>[] then
+	p ++ prlist (pr spc (lapp,L)) l2, lapp
+      else
+	p, lproj
+  | CAppExpl (_,(None,Ident (_,var)),[t])
+  | CApp (_,(_,CRef(Ident(_,var))),[t,None])
+        when var = Topconstr.ldots_var ->
+      hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg
+  | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp
+  | CApp (_,(Some i,f),l) ->
+      let l1,l2 = list_chop i l in
+      let c,l1 = list_sep_last l1 in
+      assert (snd c = None);
+      let p = pr_proj (pr mt) pr_app (fst c) f l1 in
+      if l2<>[] then 
+	p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp
+      else
+	p, lproj
+  | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp
+  | CCases (_,rtntypopt,c,eqns) ->
+      v 0
+        (hv 0 (str "match" ++ brk (1,2) ++
 	  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
-*)
+	    prlist_with_sep sep_v
+              (pr_case_item (pr_dangling_with_for mt)) c
+            ++ pr_case_type (pr_dangling_with_for mt) rtntypopt) ++
+	spc () ++ str "with") ++
+        prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"),
+      latom
+  | CLetTuple (_,nal,(na,po),c,b) ->
+      hv 0 (
+        str "let " ++
+	hov 0 (str "(" ++
+               prlist_with_sep sep_v pr_name nal ++
+               str ")" ++
+	       pr_simple_return_type (pr mt) na po ++ str " :=" ++
+               pr spc ltop c ++ str " in") ++
+        pr spc ltop b),
+      lletin
+  | CIf (_,c,(na,po),b1,b2) ->
+      (* On force les parenthèses autour d'un "if" sous-terme (même si le
+	 parsing est lui plus tolérant) *)
+      hv 0 (
+	hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++
+	spc () ++
+	hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
+	hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
+      lif
+     
+  | CHole _ -> str "_", 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
+  | CCast (_,a,_,b) ->
+      hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":" ++ pr mt (-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
+      pr (fun()->str"(") (max_int,L) t ++ str")", latom
+  | CNotation (_,s,env) -> pr_notation (pr mt) s env
+  | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
+  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
   | 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 loc = constr_loc a in
+  pr_with_comments loc
+    (sep() ++ if prec_less prec inherited then strm else surround strm)
+
+and pr_dangling_with_for sep inherited a =
+  match a with
+  | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
+  | _ -> pr sep inherited a
+
+let pr = pr mt
+
+let rec strip_context n iscast t =
+  if n = 0 then
+    [], if iscast then match t with CCast (_,c,_,_) -> c | _ -> t else t
+  else match t with
+    | CLambdaN (loc,(nal,t)::bll,c) ->
+	let n' = List.length nal in
+	if n' > n then
+	  let nal1,nal2 = list_chop n nal in
+	  [LocalRawAssum (nal1,t)], CLambdaN (loc,(nal2,t)::bll,c)
+	else
+	let bl', c = strip_context (n-n') iscast
+	  (if bll=[] then c else CLambdaN (loc,bll,c)) in
+	LocalRawAssum (nal,t) :: bl', c 
+    | CProdN (loc,(nal,t)::bll,c) ->
+	let n' = List.length nal in
+	if n' > n then
+	  let nal1,nal2 = list_chop n nal in
+	  [LocalRawAssum (nal1,t)], CProdN (loc,(nal2,t)::bll,c)
+	else
+	let bl', c = strip_context (n-n') iscast
+	  (if bll=[] then c else CProdN (loc,bll,c)) in
+	LocalRawAssum (nal,t) :: bl', c 
+    | CArrow (loc,t,c) ->
+	let bl', c = strip_context (n-1) iscast c in
+	LocalRawAssum ([loc,Anonymous],t) :: bl', c 
+    | CCast (_,c,_,_) -> strip_context n false c
+    | CLetIn (_,na,b,c) -> 
+	let bl', c = strip_context (n-1) iscast c in
+	LocalRawDef (na,b) :: bl', c
+    | _ -> anomaly "strip_context"
+
+let pr_constr_expr c = pr lsimple c
+let pr_lconstr_expr c = pr ltop c
+let pr_pattern_expr c = pr lsimple c
+let pr_cases_pattern_expr = pr_patt ltop
+
+let pr_binders = pr_undelimited_binders (pr ltop)
+
+let pr_pattern_occ prc = function
+    ([],c) -> prc c
+  | (nl,c) -> hov 1 (prc c ++ spc() ++ str"at " ++
+                     hov 0 (prlist_with_sep spc int nl))
+
+let pr_unfold_occ pr_ref = function
+    ([],qid) -> pr_ref qid
+  | (nl,qid) -> hov 1 (pr_ref qid ++ spc() ++ str"at " ++
+                       hov 0 (prlist_with_sep spc int nl))
 
 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.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"
+     if r.rDelta then pr_arg str "delta"
      else mt ()
    else
-     pr_arg str "Delta" ++ (if r.rDelta then str "-" else mt ()) ++
+     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_metaid id = str"?" ++ pr_id id
 
-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
+let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function
+  | Red false -> str "red"
+  | Hnf -> str "hnf"
+  | Simpl o -> str "simpl" ++ pr_opt (pr_pattern_occ pr_constr) o  
   | Cbv f ->
       if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
-	str "Compute"
+	str "compute"
       else
-	hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f)
+	hov 1 (str "cbv" ++ pr_red_flag pr_ref f)
   | Lazy f -> 
-      hov 1 (str "Lazy" ++ spc () ++ pr_red_flag pr_ref f)
+      hov 1 (str "lazy" ++ 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)
+      hov 1 (str "unfold" ++ spc() ++
+             prlist_with_sep pr_coma (pr_unfold_occ pr_ref) l)
+  | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l)
+  | Pattern l ->
+      hov 1 (str "pattern" ++
+        pr_arg (prlist_with_sep pr_coma (pr_pattern_occ pr_constr)) l)
+        
   | Red true -> error "Shouldn't be accessible from user"
   | ExtraRedExpr s -> str s
+  | CbvVm -> str "vm_compute"
 
-let rec pr_may_eval pr pr2 = function
+let rec pr_may_eval test prc prlc 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)
+        (str "eval" ++ brk (1,1) ++
+         pr_red_expr (prc,prlc,pr2) r ++
+	 str " in" ++ spc() ++ prc 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
+	(str "context " ++ pr_id id ++ spc () ++
+	 str "[" ++ prlc c ++ str "]")
+  | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c)
+  | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")")
+  | ConstrTerm c -> prc c
 
-let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c)
+let pr_may_eval a = pr_may_eval (fun _ -> false) a
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
index 039cd745..7441f130 100644
--- a/parsing/ppconstr.mli
+++ b/parsing/ppconstr.mli
@@ -1,3 +1,4 @@
+
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,8 +6,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-
-(*i $Id: ppconstr.mli,v 1.7.2.2 2005/01/21 17:19:37 herbelin Exp $ i*)
+ 
+(*i $Id: ppconstr.mli 7907 2006-01-21 11:03:29Z herbelin $ i*)
 
 open Pp
 open Environ
@@ -14,28 +15,55 @@ open Term
 open Libnames
 open Pcoq
 open Rawterm
-open Extend
-open Coqast
 open Topconstr
 open Names
 open Util
+open Genarg
+
+val extract_lam_binders :
+  constr_expr -> local_binder list * constr_expr
+val extract_prod_binders :
+  constr_expr -> local_binder list * constr_expr
+val extract_def_binders :
+  constr_expr -> constr_expr ->
+  local_binder list * constr_expr * constr_expr
+val split_fix :
+  int -> constr_expr -> constr_expr -> 
+  local_binder list *  constr_expr * constr_expr
+
+val prec_less : int -> int * Ppextend.parenRelation -> bool
+ 
+val pr_tight_coma : unit -> std_ppcmds
 
-val split_fix : int -> constr_expr -> constr_expr -> 
-  (name located list * constr_expr) list * constr_expr * constr_expr
+val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds
+val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
+val pr_metaid : identifier -> std_ppcmds
 
-val pr_global : Idset.t -> global_reference -> std_ppcmds
+val pr_lident : identifier located -> std_ppcmds
+val pr_lname : name located -> std_ppcmds
 
-val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+val pr_with_comments : loc -> std_ppcmds -> std_ppcmds
+val pr_com_at : int -> std_ppcmds
+val pr_sep_com :
+  (unit -> std_ppcmds) ->
+  (constr_expr -> std_ppcmds) ->
+  constr_expr -> std_ppcmds
+
+val pr_id : identifier -> 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 -> std_ppcmds) * ('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_may_eval :
+  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+    ('a,'b) may_eval -> 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
+
+val pr_binders : local_binder list -> std_ppcmds
+val pr_pattern_expr : Tacexpr.pattern_expr -> std_ppcmds
+val pr_constr_expr : constr_expr -> std_ppcmds
+val pr_lconstr_expr : constr_expr -> std_ppcmds
+val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
index 4103ea00..e6c12f4f 100644
--- a/parsing/pptactic.ml
+++ b/parsing/pptactic.ml
@@ -6,69 +6,64 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pptactic.ml,v 1.54.2.5 2005/12/23 22:16:46 herbelin Exp $ *)
+(* $Id: pptactic.ml 8651 2006-03-21 21:54:43Z jforest $ *)
 
 open Pp
 open Names
 open Nameops
 open Util
-open Extend
 open Tacexpr
 open Rawterm
 open Topconstr
 open Genarg
 open Libnames
 open Pattern
+open Ppextend
+open Ppconstr
+open Printer
 
-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
+let pr_global x = Nametab.pr_global_env Idset.empty x
 
 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
+let declare_extra_tactic_pprule (s,tags,prods) =
+  Hashtbl.add prtac_tab (s,tags) prods
 
-let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab_v7 (s,tags)
+let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags)
 
 type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (constr_expr -> std_ppcmds) -> 
+    (constr_expr -> std_ppcmds) -> 
+    (tolerability -> 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
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (tolerability -> 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
+    (Term.constr -> std_ppcmds) -> 
+    (Term.constr -> std_ppcmds) -> 
+    (tolerability -> 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 declare_extra_genarg_pprule (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 f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in
+  let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in
+  let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in
+  genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule
 
 let pr_arg pr x = spc () ++ pr x
 
@@ -84,14 +79,10 @@ 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 
@@ -108,12 +99,7 @@ let pr_bindings prc prlc = function
       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
+        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | NoBindings -> mt ()
 
 let pr_bindings_no_with prc prlc = function
@@ -122,21 +108,11 @@ let pr_bindings_no_with prc prlc = function
       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
+        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") 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)
+  prc c ++ hv 0 (pr_bindings prc prlc bl)
 
 let pr_with_constr prc = function
   | None -> mt ()
@@ -146,109 +122,10 @@ 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_message_token prid = function
+  | MsgString s -> qs s
+  | MsgInt n -> int n
+  | MsgIdent id -> prid id
 
 let rec pr_raw_generic prc prlc prtac prref x =
   match Genarg.genarg_tag x with
@@ -259,24 +136,20 @@ let rec pr_raw_generic prc prlc prtac prref x =
   | 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)
+  | IdentArgType -> pr_arg pr_id (out_gen rawwit_ident x)
+  | VarArgType -> pr_arg (pr_located pr_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)
+      pr_arg (pr_may_eval prc prlc 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)
-  | OpenConstrArgType -> pr_arg prc (snd (out_gen rawwit_open_constr x))
-  | CastedOpenConstrArgType ->
-      pr_arg prc (snd (out_gen rawwit_casted_open_constr x))
+      pr_arg (pr_red_expr (prc,prlc,prref)) (out_gen rawwit_red_expr x)
+  | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (rawwit_tactic n) x)
+  | OpenConstrArgType b -> pr_arg prc (snd (out_gen (rawwit_open_constr_gen b) x))
   | ConstrWithBindingsArgType -> 
       pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x)
   | BindingsArgType -> 
@@ -293,10 +166,7 @@ let rec pr_raw_generic prc prlc prtac prref x =
             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
+      try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str " [no printer for " ++ str s ++ str "] "
 
 
@@ -309,23 +179,22 @@ let rec pr_glob_generic prc prlc prtac x =
   | 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)
+  | IdentArgType -> pr_arg pr_id (out_gen globwit_ident x)
+  | VarArgType -> pr_arg (pr_located pr_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_arg (pr_may_eval prc prlc
         (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)
-  | OpenConstrArgType -> pr_arg prc (snd (out_gen globwit_open_constr x))
-  | CastedOpenConstrArgType ->
-      pr_arg prc (snd (out_gen globwit_casted_open_constr x))
+        (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference)))
+        (out_gen globwit_red_expr x)
+  | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (globwit_tactic n) x)
+  | OpenConstrArgType b -> pr_arg prc (snd (out_gen (globwit_open_constr_gen b) x))
   | ConstrWithBindingsArgType -> 
       pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x)
   | BindingsArgType -> 
@@ -342,10 +211,7 @@ let rec pr_glob_generic prc prlc prtac x =
             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
+      try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str " [no printer for " ++ str s ++ str "] "
 
 open Closure
@@ -359,8 +225,8 @@ let rec pr_generic prc prlc prtac x =
   | 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)
+  | IdentArgType -> pr_arg pr_id (out_gen wit_ident x)
+  | VarArgType -> pr_arg pr_id (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)
@@ -369,11 +235,10 @@ let rec pr_generic prc prlc prtac 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)
-  | OpenConstrArgType -> pr_arg prc (snd (out_gen wit_open_constr x))
-  | CastedOpenConstrArgType ->
-      pr_arg prc (snd (out_gen wit_casted_open_constr x))
+      pr_arg (pr_red_expr (prc,prlc,pr_evaluable_reference)) 
+        (out_gen wit_red_expr x)
+  | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (wit_tactic n) x)
+  | OpenConstrArgType b -> pr_arg prc (snd (out_gen (wit_open_constr_gen b) x))
   | ConstrWithBindingsArgType -> 
       pr_arg (pr_with_bindings prc prlc) (out_gen wit_constr_with_bindings x)
   | BindingsArgType -> 
@@ -390,10 +255,7 @@ let rec pr_generic prc prlc prtac x =
             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
+      try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str " [no printer for " ++ str s ++ str "]"
 
 let rec pr_tacarg_using_rule pr_gen = function
@@ -402,364 +264,735 @@ let rec pr_tacarg_using_rule pr_gen = function
   | [], [] -> 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
+let surround p = hov 1 (str"(" ++ p ++ str")")
+
+let pr_extend_gen prgen lev s l =
   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)
+    let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
+    let p = pr_tacarg_using_rule prgen (pl,l) in
+    if lev' > lev then surround p else p
   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_raw_extend prc prlc prtac = 
+  pr_extend_gen (pr_raw_generic prc prlc prtac 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)
+
+(**********************************************************************)
+(* The tactic printer                                                 *)
+
+let sep_v = fun _ -> str"," ++ spc()
+
+let strip_prod_binders_expr n ty =
+  let rec strip_ty acc n ty =
+    match ty with
+        Topconstr.CProdN(_,bll,a) ->
+          let nb =
+            List.fold_left (fun i (nal,_) -> i + List.length nal) 0 bll in
+          if nb >= n then (List.rev (bll@acc), a)
+          else strip_ty (bll@acc) (n-nb) a
+      | Topconstr.CArrow(_,a,b) ->
+          if n=1 then
+            (List.rev (([(dummy_loc,Anonymous)],a)::acc), b)
+          else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b
+      | _ -> error "Cannot translate fix tactic: not enough products" in
+  strip_ty [] n ty
+
+let pr_ltac_or_var pr = function
+  | ArgArg x -> pr x
+  | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
+
+let pr_arg pr x = spc () ++ pr x
+
+let pr_ltac_constant sp =
+  pr_qualid (Nametab.shortest_qualid_of_tactic sp)
+
+let pr_evaluable_reference_env env = function 
+  | EvalVarRef id -> pr_id id
+  | EvalConstRef sp -> 
+      Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp)
+
+let pr_inductive env ind =
+  Nametab.pr_global_env (Termops.vars_of_env env) (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_esubst prc l =
+  let pr_qhyp = function
+      (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
+    | (_,NamedHyp id,c) ->
+        str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
+  in
+  prlist_with_sep spc pr_qhyp l
+
+let pr_bindings_gen for_ex prlc prc = function
+  | ImplicitBindings l ->
+      spc () ++
+      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
+            prlist_with_sep spc prc l)
+  | ExplicitBindings l ->
+      spc () ++
+      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
+            pr_esubst prlc l)
+  | NoBindings -> mt ()
+
+let pr_bindings prlc prc = pr_bindings_gen false prlc prc
+
+let pr_with_bindings prlc prc (c,bl) =
+  hov 1 (prc c ++ pr_bindings prlc prc bl)
+
+let pr_with_constr prc = function
+  | None -> mt ()
+  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
+
+let pr_with_names = function
+  | IntroAnonymous -> mt ()
+  | ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
+
+let pr_pose prlc prc na c = match na with
+  | Anonymous -> spc() ++ prc c
+  | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
+
+let pr_assertion _prlc prc ipat c = match ipat with
+(* Use this "optimisation" or use only the general case ?
+  | IntroIdentifier id ->
+      spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
+*)
+  | ipat ->
+      spc() ++ prc c ++ pr_with_names ipat
+
+let pr_assumption prlc prc ipat c = match ipat with
+(* Use this "optimisation" or use only the general case ?
+  | IntroIdentifier id ->
+      spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
+*)
+  | ipat ->
+      spc() ++ prc c ++ pr_with_names ipat
+
+let pr_by_tactic prt = function
+  | TacId [] -> mt ()
+  | tac -> spc() ++ str "by " ++ prt tac
+
+let pr_occs pp = function
+    [] -> pp
+  | nl -> hov 1 (pp ++ spc() ++ str"at " ++
+                 hov 0 (prlist_with_sep spc int nl))
+
+let pr_hyp_location pr_id = function
+  | id, occs, InHyp -> spc () ++ pr_occs (pr_id id) occs
+  | id, occs, InHypTypeOnly ->
+      spc () ++ pr_occs (str "(type of " ++ pr_id id ++ str ")") occs
+  | id, occs, InHypValueOnly ->
+      spc () ++ pr_occs (str "(value of " ++ pr_id id ++ str ")") occs
+
+let pr_in pp = spc () ++ hov 0 (str "in" ++ pp)
+
+let pr_simple_clause pr_id = function
+  | [] -> mt ()
+  | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
+
+let pr_clauses pr_id = function
+    { onhyps=None; onconcl=true; concl_occs=nl } ->
+      pr_in (pr_occs (str " *") nl)
+  | { onhyps=None; onconcl=false } -> pr_in (str " * |-")
+  | { onhyps=Some l; onconcl=true; concl_occs=nl } -> 
+      pr_in (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l
+             ++ pr_occs (str" |- *") nl)
+  | { onhyps=Some l; onconcl=false } ->
+      pr_in (prlist_with_sep (fun()->str",") (pr_hyp_location pr_id) l)
+
+let pr_clause_pattern pr_id = function
+  | (None, []) -> mt ()
+  | (glopt,l) ->
+      str " in" ++
+      prlist
+        (fun (id,nl) -> prlist (pr_arg int) nl 
+	  ++ spc () ++ pr_id id) l ++
+        pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt
+
+let pr_induction_arg prc = function
+  | ElimOnConstr c -> prc c
+  | ElimOnIdent (loc,id) -> pr_with_comments loc (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_lazy lz = if lz then str "lazy " else mt ()
+
+let pr_match_pattern pr_pat = function
+  | Term a -> pr_pat a
+  | Subterm (None,a) -> str "context [" ++ pr_pat a ++ str "]"
+  | Subterm (Some id,a) ->
+      str "context " ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
+
+let pr_match_hyps pr_pat = function
+  | Hyp (nal,mp) -> pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
+
+let pr_match_rule m pr pr_pat = function
+  | Pat ([],mp,t) when m ->
+      pr_match_pattern pr_pat mp ++
+      spc () ++ str "=>" ++ brk (1,4) ++ pr t
+  | Pat (rl,mp,t) ->
+      prlist_with_sep (fun () -> str",") (pr_match_hyps pr_pat) rl ++
+      spc () ++ str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+      str "=>" ++ brk (1,4) ++ pr t
+  | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ 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) ->
+      hov 0 (str k ++ pr_lident id ++ str " :=" ++ brk (1,1) ++
+             pr (TacArg t))
+  | (id,Some c,t) ->
+      hv 0 (str k ++ pr_lident id ++ str" :" ++ brk(1,2) ++
+      pr c ++
+      str " :=" ++ brk (1,1) ++ pr (TacArg t))
+
+let pr_let_clauses pr = function
+  | hd::tl ->
+      hv 0
+        (pr_let_clause "let " pr hd ++
+         prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl)
+  | [] -> anomaly "LetIn must declare at least one binding"
+
+let pr_rec_clause pr (id,(l,t)) =
+  hov 0
+    (pr_lident id ++ prlist pr_funvar l ++ str " :=") ++ spc () ++ pr t
+
+let pr_rec_clauses pr l = 
+  prlist_with_sep (fun () -> fnl () ++ str "with ") (pr_rec_clause pr) l
+
+let pr_seq_body pr tl =
+  hv 0 (str "[ " ++
+        prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
+        str " ]")
+
+let pr_hintbases = function
+  | None -> spc () ++ str "with *"
+  | Some [] -> mt ()
+  | Some l ->
+      spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l)
+
+let pr_auto_using prc = function
+  | [] -> mt ()
+  | l -> spc () ++ 
+      hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_coma prc 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_tacarg_using_rule pr_gen = function
+  | Egrammar.TacTerm s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
+  | Egrammar.TacNonTerm _ :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al)
+  | [], [] -> mt ()
+  | _ -> failwith "Inconsistent arguments of extended tactic"
+
+let pr_then () = str ";"
 
-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 ltop = (5,E)
+let lseq = 5
+let ltactical = 3
+let lorelse = 2
+let llet = 1
+let lfun = 1
+let lcomplete = 1
+let labstract = 3
+let lmatch = 1
+let latom = 0
+let lcall = 1
+let leval = 1
+let ltatom = 1
+
+let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
+
+open Closure
+
+let make_pr_tac 
+  (pr_tac_level,pr_constr,pr_lconstr,pr_pat,
+   pr_cst,pr_ind,pr_ref,pr_ident,
+   pr_extend,strip_prod_binders) =
+
+let pr_bindings env =
+  pr_bindings (pr_lconstr env) (pr_constr env) in
+let pr_ex_bindings env =
+  pr_bindings_gen true (pr_lconstr env) (pr_constr env) in
+let pr_with_bindings env =
+  pr_with_bindings (pr_lconstr env) (pr_constr env) in
+let pr_eliminator env cb =
+  str "using" ++ pr_arg (pr_with_bindings env) cb in
+let pr_extend env =
+  pr_extend (pr_constr env) (pr_lconstr env) (pr_tac_level env) in
+let pr_red_expr env = 
+  pr_red_expr (pr_constr env,pr_lconstr env,pr_cst env) in
+
+let pr_constrarg env c = spc () ++ pr_constr env c in
+let pr_lconstrarg env c = spc () ++ pr_lconstr env c in
 let pr_intarg n = spc () ++ int n in
 
+let pr_binder_fix env (nal,t) =
+(*  match t with
+  | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
+  | _ ->*)
+    let s =
+      prlist_with_sep spc (pr_lname) nal ++ str ":" ++
+      pr_lconstr env t in
+    spc() ++ hov 1 (str"(" ++ s ++ str")") in
+
+let pr_fix_tac env (id,n,c) =
+  let rec set_nth_name avoid n = function
+      (nal,ty)::bll ->
+        if n <= List.length nal then
+          match list_chop (n-1) nal with
+              _, (_,Name id) :: _ -> id, (nal,ty)::bll
+            | bef, (loc,Anonymous) :: aft ->
+                let id = next_ident_away_from (id_of_string"y") avoid in
+                id, ((bef@(loc,Name id)::aft, ty)::bll)
+            | _ -> assert false
+        else
+          let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
+          (id,(nal,ty)::bll')
+    | [] -> assert false in
+  let (bll,ty) = strip_prod_binders n c in
+  let names =
+    List.fold_left
+      (fun ln (nal,_) -> List.fold_left
+          (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
+          ln nal)
+      [] bll in
+  let idarg,bll = set_nth_name names n bll in
+  let annot =
+    if List.length names = 1 then mt()
+    else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in
+  hov 1 (str"(" ++ pr_id id ++ 
+        prlist (pr_binder_fix env) bll ++ annot ++ str" :" ++
+        pr_lconstrarg env ty ++ str")") in
+(*  spc() ++
+  hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
+    env c)
+*)
+let pr_cofix_tac env (id,c) =
+  hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg env c ++ str")") 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 ")"
+let rec pr_atom0 env = 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"
+  | TacReflexivity -> str "reflexivity"
+  | t -> str "(" ++ pr_atom1 env 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)
+and pr_atom1 env = function
+  | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl
+  | TacSuperAuto _ | TacExtend (_,
+    ("GTauto"|"GIntuition"|"TSimplif"|
+     "LinearIntuition"),_) ->
+      errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0")
+  | TacExtend (loc,s,l) ->
+      pr_with_comments loc (pr_extend env 1 s l)
+  | TacAlias (loc,s,l,_) ->
+      pr_with_comments loc (pr_extend env 1 s (List.map snd l))
 
   (* Basic tactics *)
-  | TacIntroPattern [] as t -> pr_atom0 t
+  | TacIntroPattern [] as t -> pr_atom0 env t
   | TacIntroPattern (_::_ as p) -> 
-      hov 1 (str "Intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern 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)) ->
+      hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h)
+  | TacIntroMove (None,None) as t -> pr_atom0 env 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)
+      (str "intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++
+       pr_lident id2)
+  | TacAssumption as t -> pr_atom0 env t
+  | TacExact c -> hov 1 (str "exact" ++ pr_constrarg env c)
+  | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg env c)
+  | TacApply cb -> hov 1 (str "apply" ++ spc () ++ pr_with_bindings env 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)
+      hov 1 (str "elim" ++ pr_arg (pr_with_bindings env) cb ++ 
+        pr_opt (pr_eliminator env) cbo)
+  | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg env c)
+  | TacCase cb -> hov 1 (str "case" ++ spc () ++ pr_with_bindings env cb)
+  | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg env 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)
+      hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++
+             str"with " ++ prlist_with_sep spc (pr_fix_tac env) 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)
+      hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++
+             str"with " ++ prlist_with_sep spc (pr_cofix_tac env) l)
+  | TacCut c -> hov 1 (str "cut" ++ pr_constrarg env c)
+  | TacAssert (Some tac,ipat,c) -> 
+      hov 1 (str "assert" ++ 
+             pr_assumption (pr_lconstr env) (pr_constr env) ipat c ++ 
+             pr_by_tactic (pr_tac_level env ltop) tac)
+  | TacAssert (None,ipat,c) -> 
+      hov 1 (str "pose proof" ++
+             pr_assertion (pr_lconstr env) (pr_constr env) ipat c)
   | TacGeneralize l ->
-      hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l)
+      hov 1 (str "generalize" ++ spc () ++
+             prlist_with_sep spc (pr_constr env) l)
   | TacGeneralizeDep c ->
-      hov 1 (str "Generalize" ++ spc () ++ str "Dependent" ++ spc () ++
-      pr_constr c)
+      hov 1 (str "generalize" ++ spc () ++ str "dependent" ++
+             pr_constrarg env c)
+  | TacLetTac (na,c,cl) when cl = nowhere ->
+      hov 1 (str "pose" ++ pr_pose (pr_lconstr env) (pr_constr env) na 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)
+      hov 1 (str "set" ++ pr_pose (pr_lconstr env) (pr_constr env) na c ++
+             pr_clauses pr_ident cl)
+(*  | TacInstantiate (n,c,ConclLocation ()) ->
+      hov 1 (str "instantiate" ++ spc() ++
+             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+                    pr_lconstrarg env c ++ str ")" ))
+  | TacInstantiate (n,c,HypLocation (id,hloc)) ->
+      hov 1 (str "instantiate" ++ spc() ++
+             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+                    pr_lconstrarg env c ++ str ")" ) 
+	     ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None)))
+*)
   (* 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)
+  | TacSimpleInduction h ->
+      hov 1 (str "simple induction" ++ pr_arg pr_quantified_hypothesis h)
+  | TacNewInduction (h,e,ids) ->
+      hov 1 (str "induction" ++ spc () ++
+	     prlist_with_sep spc (pr_induction_arg (pr_constr env)) h ++
+             pr_opt (pr_eliminator env) e)
   | 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)
+      hov 1 (str "simple destruct" ++ pr_arg pr_quantified_hypothesis h)
+  | TacNewDestruct (h,e,ids) ->
+      hov 1 (str "destruct" ++ spc () ++
+             prlist_with_sep spc (pr_induction_arg (pr_constr env)) h ++ 
+	     pr_with_names ids ++
+             pr_opt (pr_eliminator env) e)
   | TacDoubleInduction (h1,h2) ->
       hov 1
-        (str "Double Induction" ++ 
+        (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)
+      hov 1 (str "decompose record" ++ pr_constrarg env c)
   | TacDecomposeOr c ->
-      hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c)
+      hov 1 (str "decompose sum" ++ pr_constrarg env 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))
+      hov 1 (str "decompose" ++ spc () ++
+        hov 0 (str "[" ++ prlist_with_sep spc (pr_ind env) l
+	  ++ str "]" ++ pr_constrarg env c))
   | TacSpecialize (n,c) ->
-      hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c)
+      hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ 
+             pr_with_bindings env c)
   | TacLApply c -> 
-      hov 1 (str "LApply" ++ pr_constr c)
+      hov 1 (str "lapply" ++ pr_constrarg env 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 (pr_or_var 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)
+  | TacTrivial ([],Some []) as x -> pr_atom0 env x
+  | TacTrivial (lems,db) ->
+      hov 0 (str "trivial" ++ 
+             pr_auto_using (pr_constr env) lems ++ pr_hintbases db)
+  | TacAuto (None,[],Some []) as x -> pr_atom0 env x
+  | TacAuto (n,lems,db) ->
+      hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ 
+             pr_auto_using (pr_constr env) lems ++ pr_hintbases db)
   | TacDAuto (n,p) ->
-      hov 1 (str "Auto" ++ pr_opt (pr_or_var int) n ++ str "Decomp" ++ 
-      pr_opt int p)
+      hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ pr_opt int p)
 
   (* Context management *)
-  | TacClear l ->
-      hov 1 (str "Clear" ++ spc () ++ prlist_with_sep spc pr_ident l)
+  | TacClear (keep,l) ->
+      hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++
+             prlist_with_sep spc pr_ident l)
   | TacClearBody l ->
-      hov 1 (str "ClearBody" ++ spc () ++ prlist_with_sep spc pr_ident 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 "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 "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)
+  | TacLeft l -> hov 1 (str "left" ++ pr_bindings env l)
+  | TacRight l -> hov 1 (str "right" ++ pr_bindings env l)
+  | TacSplit (false,l) -> hov 1 (str "split" ++ pr_bindings env l)
+  | TacSplit (true,l) -> hov 1 (str "exists" ++ pr_ex_bindings env l)
   | TacAnyConstructor (Some t) ->
-      hov 1 (str "Constructor" ++ pr_arg pr_tac0 t)
-  | TacAnyConstructor None as t -> pr_atom0 t
+      hov 1 (str "constructor" ++ pr_arg (pr_tac_level env (latom,E)) t)
+  | TacAnyConstructor None as t -> pr_atom0 env t
   | TacConstructor (n,l) ->
-      hov 1 (str "Constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l)
+      hov 1 (str "constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings env 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)
+      hov 1 (pr_red_expr env r ++
+             pr_clauses pr_ident h)
+  | TacChange (occ,c,h) ->
+      hov 1 (str "change" ++ brk (1,1) ++
+      (match occ with
+          None -> mt()
+        | Some([],c1) -> hov 1 (pr_constr env c1 ++ spc() ++ str "with ")
+        | Some(ocl,c1) ->
+            hov 1 (pr_constr env c1 ++ spc() ++
+	           str "at " ++ prlist_with_sep spc int ocl) ++ spc() ++
+	           str "with ") ++
+      pr_constr env 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
+  | TacReflexivity as x -> pr_atom0 env x
+  | TacSymmetry cls -> str "symmetry " ++ pr_clauses pr_ident cls
+  | TacTransitivity c -> str "transitivity" ++ pr_constrarg env c
 
   (* Equality and inversion *)
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      hov 1 (str "Dependent " ++ pr_induction_kind k ++ 
+      hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++
       pr_quantified_hypothesis hyp ++
-      pr_with_names ids ++ pr_with_constr pr_constr c)
+      pr_with_names ids ++ pr_with_constr (pr_constr env) 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 ++ 
+      hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ 
+      spc () ++ str "using" ++ spc () ++ pr_constr env 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
+in
+
+let rec pr_tac env inherited tac =
+  let (strm,prec) = match tac with
+  | TacAbstract (t,None) ->
+      str "abstract " ++ pr_tac env (labstract,L) t, labstract
   | TacAbstract (t,Some s) -> 
       hov 0
-       (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s)
+       (str "abstract (" ++ pr_tac env (labstract,L) t ++ str")" ++ spc () ++
+        str "using " ++ pr_id s),
+      labstract
   | TacLetRecIn (l,t) -> 
       hv 0
-        (str "Rec " ++ pr_rec_clauses prtac l ++
-        spc () ++ str "In" ++ fnl () ++ prtac t)
+        (str "let rec " ++ pr_rec_clauses (pr_tac env ltop) l ++ str " in" ++
+         fnl () ++ pr_tac env (llet,E) t),
+      llet
   | 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"
+       (hv 0 (pr_let_clauses (pr_tac env ltop) llc
+       ++ str " in") ++
+       fnl () ++ pr_tac env (llet,E) u),
+      llet
+  | TacMatch (lz,t,lrul) ->
+      hov 0 (pr_lazy lz ++ str "match " ++ pr_tac env ltop t ++ 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")
+	  (fun r -> fnl () ++ str "| " ++
+            pr_match_rule true (pr_tac env ltop) pr_pat r)
+	lrul
+        ++ fnl() ++ str "end"),
+      lmatch
+  | TacMatchContext (lz,lr,lrul) ->
+      hov 0 (pr_lazy lz ++ 
+	str (if lr then "match reverse goal with" else "match goal with")
 	++ prlist
-	  (fun r -> fnl () ++ str "|" ++ spc () ++
-            pr_match_rule false pr_pat prtac r)
-	lrul)
+	  (fun r -> fnl () ++ str "| " ++
+            pr_match_rule false (pr_tac env ltop) pr_pat r)
+	lrul
+        ++ fnl() ++ str "end"),
+      lmatch
   | 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
+(*      let env = List.fold_right (option_fold_right Idset.add) lvar env in*)
+      hov 2 (str "fun" ++
+        prlist pr_funvar lvar ++ str " =>" ++ spc () ++
+        pr_tac env (lfun,E) body),
+      lfun
+  | TacThens (t,tl) -> 
+      hov 1 (pr_tac env (lseq,E) t ++ pr_then () ++ spc () ++
+             pr_seq_body (pr_tac env ltop) tl),
+      lseq
+  | TacThen (t1,t2) ->
+      hov 1 (pr_tac env (lseq,E) t1 ++ pr_then () ++ spc () ++
+             pr_tac env (lseq,L) t2),
+      lseq
+  | TacTry t ->
+      hov 1 (str "try" ++ spc () ++ pr_tac env (ltactical,E) t),
+      ltactical
+  | TacDo (n,t) ->
+      hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ 
+             pr_tac env (ltactical,E) t),
+      ltactical
+  | TacRepeat t ->
+      hov 1 (str "repeat" ++ spc () ++ pr_tac env (ltactical,E) t),
+      ltactical
+  | TacProgress t ->
+      hov 1 (str "progress" ++ spc () ++ pr_tac env (ltactical,E) t),
+      ltactical
+  | TacInfo t ->
+      hov 1 (str "info" ++ spc () ++ pr_tac env (ltactical,E) t),
+      ltactical
+  | TacOrelse (t1,t2) ->
+      hov 1 (pr_tac env (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++
+             pr_tac env (lorelse,E) t2),
+      lorelse
+  | TacFail (n,l) -> 
+      str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
+      prlist (pr_arg (pr_message_token pr_ident)) l, latom
+  | TacFirst tl ->
+      str "first" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet
+  | TacSolve tl ->
+      str "solve" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet
+  | TacComplete t ->
+      str "complete" ++ spc () ++ pr_tac env (lcomplete,E) t, lcomplete
+  | TacId l ->
+      str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom
+  | TacAtom (loc,TacAlias (_,s,l,_)) ->
+      pr_with_comments loc
+        (pr_extend env (level_of inherited) s (List.map snd l)),
+      latom
+  | TacAtom (loc,t) ->
+      pr_with_comments loc (hov 1 (pr_atom1 env t)), ltatom
+  | TacArg(Tacexp e) -> pr_tac_level env (latom,E) e, latom
+  | TacArg(ConstrMayEval (ConstrTerm c)) ->
+      str "constr:" ++ pr_constr env c, latom
+  | TacArg(ConstrMayEval c) ->
+      pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c, leval
+  | TacArg(TacFreshId sopt) -> str "fresh" ++ pr_opt qs sopt, latom
+  | TacArg(Integer n) -> int n, latom
+  | TacArg(TacCall(loc,f,l)) ->
+      pr_with_comments loc
+        (hov 1 (pr_ref f ++ spc () ++
+         prlist_with_sep spc (pr_tacarg env) l)),
+      lcall
+  | TacArg a -> pr_tacarg env a, latom
+  in
+  if prec_less prec inherited then strm
+  else str"(" ++ strm ++ str")"
+
+and pr_tacarg env = function
+  | TacDynamic (loc,t) ->
+      pr_with_comments loc (str ("<dynamic ["^(Dyn.tag t)^"]>"))
+  | MetaIdArg (loc,s) -> pr_with_comments loc (str ("$" ^ s))
+  | IntroPattern ipat -> str "ipattern:" ++ 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)
+  | ConstrMayEval c ->
+      pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c
+  | TacFreshId sopt -> str "fresh" ++ pr_opt qs sopt
+  | TacExternal (_,com,req,la) ->
+      str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ 
+      spc() ++ prlist_with_sep spc (pr_tacarg env) la
+  | (TacCall _|Tacexp _|Integer _) as a ->
+      str "ltac:" ++ pr_tac env (latom,E) (TacArg a)
+
+in (pr_tac, pr_match_rule)
+
+let strip_prod_binders_rawterm n (ty,_) =
+  let rec strip_ty acc n ty =
+    if n=0 then (List.rev acc, (ty,None)) else
+      match ty with
+          Rawterm.RProd(loc,na,a,b) ->
+            strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b
+        | _ -> error "Cannot translate fix tactic: not enough products" in
+  strip_ty [] n ty
+
+let strip_prod_binders_constr n ty =
+  let rec strip_ty acc n ty =
+    if n=0 then (List.rev acc, ty) else
+      match Term.kind_of_term ty with
+          Term.Prod(na,a,b) ->
+            strip_ty (([dummy_loc,na],a)::acc) (n-1) b
+        | _ -> error "Cannot translate fix tactic: not enough products" in
+  strip_ty [] n ty
+
+let drop_env f _env = f
+
+let rec raw_printers =
+    (pr_raw_tactic_level, 
+     drop_env pr_constr_expr,
+     drop_env pr_lconstr_expr,
+     pr_pattern_expr,
+     drop_env pr_reference,
+     drop_env pr_reference,
+     pr_reference,
+     pr_or_metaid pr_lident,
+     pr_raw_extend,
+     strip_prod_binders_expr)
+
+and pr_raw_tactic_level env n (t:raw_tactic_expr) =
+  fst (make_pr_tac raw_printers) env n t
+
+and pr_raw_match_rule env t =
+  snd (make_pr_tac raw_printers) env t
 
 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,_,_) =
+    (pr_glob_tactic_level, 
+     (fun env -> pr_and_constr_expr (pr_rawconstr_env env)),
+     (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)),
+     (fun c -> pr_constr_pattern_env (Global.env()) c),
+     (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
+     (fun env -> pr_or_var (pr_inductive env)),
+     pr_ltac_or_var (pr_located pr_ltac_constant),
+     pr_lident,
+     pr_glob_extend,
+     strip_prod_binders_rawterm)
+
+and pr_glob_tactic_level env n (t:glob_tactic_expr) =
+  fst (make_pr_tac glob_printers) env n t
+
+and pr_glob_match_rule env t =
+  snd (make_pr_tac glob_printers) env t
+
+let ((pr_tactic_level:Environ.env -> tolerability -> Proof_type.tactic_expr -> std_ppcmds),_) =
   make_pr_tac
-    (pr_glob_tactic,
-     pr_glob_tactic0,
-     Printer.prterm,
-     Printer.pr_pattern,
-     pr_evaluable_reference,
+    (pr_glob_tactic_level,
+     pr_constr_env,
+     pr_lconstr_env,
+     pr_constr_pattern,
+     pr_evaluable_reference_env,
      pr_inductive,
      pr_ltac_constant,
      pr_id,
-     pr_extend)
+     pr_extend,
+     strip_prod_binders_constr)
+
+let pr_raw_tactic env = pr_raw_tactic_level env ltop
+let pr_glob_tactic env = pr_glob_tactic_level env ltop
+let pr_tactic env = pr_tactic_level env ltop
+
+let _ = Tactic_debug.set_tactic_printer
+  (fun x -> pr_glob_tactic (Global.env()) x)
+
+let _ = Tactic_debug.set_match_pattern_printer
+  (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp)
+
+let _ = Tactic_debug.set_match_rule_printer
+  (fun rl ->
+    pr_match_rule false (pr_glob_tactic (Global.env())) pr_constr_pattern rl)
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
index 5c3035ba..ccdf3776 100644
--- a/parsing/pptactic.mli
+++ b/parsing/pptactic.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pptactic.mli,v 1.9.2.3 2005/12/23 22:16:46 herbelin Exp $ i*)
+(*i $Id: pptactic.mli 7937 2006-01-28 19:58:11Z herbelin $ i*)
 
 open Pp
 open Genarg
@@ -15,27 +15,33 @@ open Pretyping
 open Proof_type
 open Topconstr
 open Rawterm
+open Ppextend
+open Environ
 
 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
+    (constr_expr -> std_ppcmds) -> 
+    (constr_expr -> std_ppcmds) -> 
+    (tolerability -> 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
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (tolerability -> 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
+    (Term.constr -> std_ppcmds) -> 
+    (Term.constr -> std_ppcmds) -> 
+    (tolerability -> 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
@@ -43,44 +49,42 @@ val declare_extra_genarg_pprule :
 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 declare_extra_tactic_pprule : 
+  string * argument_type list * (int * grammar_terminals) -> unit
 
 val exists_extra_tactic_pprule : string -> argument_type list -> bool
 
-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) ->
+  (tolerability -> 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
+  (tolerability -> raw_tactic_expr -> std_ppcmds) -> int ->
+    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
+  (tolerability -> glob_tactic_expr -> std_ppcmds) -> int ->
+    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
+  (tolerability -> glob_tactic_expr -> std_ppcmds) -> int ->
+    string -> closed_generic_argument list -> std_ppcmds
+
+val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds
+
+val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds
+ 
+val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
+
+val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds
+
+val pr_hintbases : string list option -> std_ppcmds
+
+val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml
new file mode 100644
index 00000000..0b6e5771
--- /dev/null
+++ b/parsing/ppvernac.ml
@@ -0,0 +1,841 @@
+(************************************************************************)
+(*  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: ppvernac.ml 8624 2006-03-13 17:38:17Z msozeau $ *)  
+
+open Pp
+open Names
+open Nameops
+open Nametab 
+open Util
+open Extend
+open Vernacexpr
+open Ppconstr
+open Pptactic
+open Rawterm
+open Genarg
+open Pcoq
+open Libnames
+open Ppextend
+open Topconstr
+open Decl_kinds
+open Tacinterp
+
+let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
+
+let pr_lident (b,_ as loc,id) =
+  if loc <> dummy_loc then
+    let (b,_) = unloc loc in
+    pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
+  else pr_id id
+
+let string_of_fqid fqid =
+ String.concat "." (List.map string_of_id fqid)
+
+let pr_fqid fqid = str (string_of_fqid fqid)
+
+let pr_lfqid (_,_ as loc,fqid) =
+  if loc <> dummy_loc then
+   let (b,_) = unloc loc in
+    pr_located pr_fqid (make_loc (b,b+String.length(string_of_fqid fqid)),fqid)
+  else
+   pr_fqid fqid
+
+let pr_lname = function
+    (loc,Name id) -> pr_lident (loc,id)
+  | lna -> pr_located pr_name lna
+
+let pr_ltac_id = Nameops.pr_id
+
+let pr_module = Libnames.pr_reference
+
+let pr_import_module = Libnames.pr_reference
+
+let sep_end () = str"."
+
+(* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *)
+
+let pr_raw_tactic_env l env t = 
+  pr_glob_tactic env (Tacinterp.glob_tactic_env l env t)
+
+let pr_gen env t =
+  pr_raw_generic 
+    pr_constr_expr
+    pr_lconstr_expr
+    (pr_raw_tactic_level env) pr_reference t
+
+let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac
+
+let rec extract_signature = function
+  | [] -> []
+  | Egrammar.TacNonTerm (_,(_,t),_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+let rec match_vernac_rule tys = function
+    [] -> raise Not_found
+  | pargs::rls ->
+      if extract_signature pargs = tys then pargs
+      else match_vernac_rule tys rls
+
+let sep = fun _ -> spc()
+let sep_p = fun _ -> str"."
+let sep_v = fun _ -> str","
+let sep_v2 = fun _ -> str"," ++ spc()
+let sep_pp = fun _ -> str":"
+
+let pr_ne_sep sep pr = function
+    [] -> mt()
+  | l -> sep() ++ pr l
+
+let pr_entry_prec = function
+  | Some Gramext.LeftA -> str"LEFTA "
+  | Some Gramext.RightA -> str"RIGHTA "
+  | Some Gramext.NonA -> str"NONA "
+  | None -> mt()
+
+let pr_prec = function
+  | Some Gramext.LeftA -> str", left associativity"
+  | Some Gramext.RightA -> str", right associativity"
+  | Some Gramext.NonA -> str", no associativity"
+  | None -> mt()
+
+let pr_set_entry_type = function
+  | ETIdent -> str"ident"
+  | ETReference -> str"global"
+  | ETPattern -> str"pattern"
+  | ETConstr _ -> str"constr"
+  | ETOther (_,e) -> str e
+  | ETBigint -> str "bigint"
+  | ETConstrList _ -> failwith "Internal entry type"
+
+let strip_meta id =
+  let s = string_of_id id in
+  if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
+  else id
+
+let pr_production_item = function
+  | VNonTerm (loc,nt,Some p) -> str nt ++ str"(" ++ pr_id (strip_meta p) ++ str")"
+  | VNonTerm (loc,nt,None) -> str nt
+  | VTerm s -> qs s
+
+let pr_comment pr_c = function
+  | CommentConstr c -> pr_c c
+  | CommentString s -> qs s
+  | CommentInt n -> int n
+
+let pr_in_out_modules = function
+  | SearchInside l -> spc() ++ str"inside" ++ spc() ++ prlist_with_sep sep pr_module l
+  | SearchOutside [] -> mt()
+  | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l
+
+let pr_search_about = function
+  | SearchRef r -> pr_reference r
+  | SearchString s -> qs s
+
+let pr_search a b pr_p = match a with
+  | SearchHead qid -> str"Search" ++ spc() ++ pr_reference qid ++ pr_in_out_modules b
+  | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+  | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+  | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b
+
+let pr_locality local = if local then str "Local " else str ""
+
+let pr_explanation imps = function
+  | ExplByPos n -> pr_id (Impargs.name_of_implicit (List.nth imps (n-1)))
+  | ExplByName id -> pr_id id
+
+let pr_class_rawexpr = function
+  | FunClass -> str"Funclass"
+  | SortClass -> str"Sortclass"
+  | RefClass qid -> pr_reference qid
+
+let pr_option_ref_value = function
+  | QualidRefValue id -> pr_reference id
+  | StringRefValue s -> qs s
+
+let pr_printoption a b = match a with
+  | Goptions.PrimaryTable table -> str table ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b
+  | Goptions.SecondaryTable (table,field) -> str table ++ spc() ++ str field ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b
+
+let pr_set_option a b = 
+  let pr_opt_value = function 
+    | IntValue n -> spc() ++ int n
+    | StringValue s -> spc() ++ str s
+    | BoolValue b -> mt()
+  in pr_printoption a None ++ pr_opt_value b
+
+let pr_topcmd _ = str"(* <Warning> : No printer for toplevel commands *)"
+
+let pr_destruct_location = function
+  | Tacexpr.ConclLocation ()  -> str"Conclusion"
+  | Tacexpr.HypLocation b -> if b then str"Discardable Hypothesis" else str"Hypothesis"
+
+let pr_opt_hintbases l = match l with
+  | [] -> mt()
+  | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z
+
+let pr_hints local db h pr_c pr_pat = 
+  let opth = pr_opt_hintbases db  in
+  let pph =
+    match h with
+    | HintsResolve l ->
+        str "Resolve " ++ prlist_with_sep sep pr_c l
+    | HintsImmediate l ->
+        str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l
+    | HintsUnfold l ->
+        str "Unfold " ++ prlist_with_sep sep pr_reference l
+    | HintsConstructors c ->
+        str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c
+    | HintsExtern (n,c,tac) ->
+        str "Extern" ++ spc() ++ int n ++ spc() ++ pr_pat c ++ str" =>" ++
+        spc() ++ pr_raw_tactic tac
+    | HintsDestruct(name,i,loc,c,tac) ->
+        str "Destruct " ++ pr_id name ++ str" :=" ++ spc() ++
+        hov 0 (int i ++ spc() ++ pr_destruct_location loc ++ spc() ++
+               pr_c c ++ str " =>") ++ spc() ++
+        pr_raw_tactic tac in
+  hov 2 (str"Hint "++pr_locality local ++ pph ++ opth)
+
+let pr_with_declaration pr_c = function
+  | CWith_Definition (id,c) ->
+      let p = pr_c c in
+      str"Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p
+  | CWith_Module (id,qid) ->
+      str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
+      pr_located pr_qualid qid
+
+let rec pr_module_type pr_c = function
+  | CMTEident qid -> spc () ++ pr_located pr_qualid qid
+  | CMTEwith (mty,decl) ->
+      let m = pr_module_type pr_c mty in
+      let p = pr_with_declaration pr_c decl in
+      m ++ spc() ++ str"with" ++ spc() ++ p
+
+let pr_of_module_type prc (mty,b) =
+  str (if b then ":" else "<:") ++
+  pr_module_type prc mty
+
+let pr_require_token = function
+  | Some true -> str "Export "
+  | Some false -> str "Import "
+  | None -> mt()
+
+let pr_module_vardecls pr_c (export,idl,mty) =
+  let m = pr_module_type pr_c mty in
+  (* Update the Nametab for interpreting the body of module/modtype *)
+  let lib_dir = Lib.library_dp() in
+  List.iter (fun (_,id) ->
+    Declaremods.process_module_bindings [id]
+      [make_mbid lib_dir (string_of_id id),
+       Modintern.interp_modtype (Global.env()) mty]) idl;
+  (* Builds the stream *)
+  spc() ++
+  hov 1 (str"(" ++ pr_require_token export ++
+   prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
+
+let pr_module_binders l pr_c = 
+  (* Effet de bord complexe pour garantir la declaration des noms des
+  modules parametres dans la Nametab des l'appel de pr_module_binders
+  malgre l'aspect paresseux des streams *)
+  let ml = List.map (pr_module_vardecls pr_c) l in
+  prlist (fun id -> id) ml
+
+let pr_module_binders_list l pr_c = pr_module_binders l pr_c
+
+let rec pr_module_expr = function
+  | CMEident qid -> pr_located pr_qualid qid
+  | CMEapply (me1,(CMEident _ as me2)) ->
+      pr_module_expr me1 ++ spc() ++ pr_module_expr me2
+  | CMEapply (me1,me2) ->
+      pr_module_expr me1 ++ spc() ++
+      hov 1 (str"(" ++ pr_module_expr me2 ++ str")")
+
+let pr_type_option pr_c = function
+  | CHole loc -> mt()
+  | _ as c -> brk(0,2) ++ str":" ++ pr_c c
+
+let pr_decl_notation prc =
+  pr_opt (fun (ntn,c,scopt) -> fnl () ++
+    str "where " ++ qs ntn ++ str " := " ++ prc c ++
+    pr_opt (fun sc -> str ": " ++ str sc) scopt)
+
+let pr_vbinders l =
+  hv 0 (pr_binders l)
+
+let pr_binders_arg =
+  pr_ne_sep spc pr_binders
+
+let pr_and_type_binders_arg bl =
+  pr_binders_arg bl
+
+let pr_onescheme (id,dep,ind,s) =
+  hov 0 (pr_lident id ++ str" :=") ++ spc() ++
+  hov 0 ((if dep then str"Induction for" else str"Minimality for")
+  ++ spc() ++ pr_reference ind) ++ spc() ++ 
+  hov 0 (str"Sort" ++ spc() ++ pr_sort s)
+
+let begin_of_inductive = function
+    [] -> 0
+  | (_,((loc,_),_))::_ -> fst (unloc loc)
+
+let pr_class_rawexpr = function
+  | FunClass -> str"Funclass"
+  | SortClass -> str"Sortclass"
+  | RefClass qid -> pr_reference qid
+
+let pr_assumption_token many = function
+  | (Local,Logical) ->
+      str (if many then "Hypotheses" else "Hypothesis")
+  | (Local,Definitional) ->
+      str (if many then "Variables" else "Variable")
+  | (Global,Logical) ->
+      str (if many then "Axioms" else "Axiom")
+  | (Global,Definitional) -> 
+      str (if many then "Parameters" else "Parameter")
+  | (Global,Conjectural) -> str"Conjecture"
+  | (Local,Conjectural) -> 
+      anomaly "Don't know how to translate a local conjecture"
+
+let pr_params pr_c (xl,(c,t)) =
+  hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++
+         (if c then str":>" else str":" ++
+         spc() ++ pr_c t))
+
+let rec factorize = function
+  | [] -> []
+  | (c,(idl,t))::l ->
+      match factorize l with
+	| (xl,t')::l' when t' = (c,t) -> (idl@xl,t')::l'
+	| l' -> (idl,(c,t))::l'
+
+let pr_ne_params_list pr_c l =
+  match factorize l with
+    | [p] -> pr_params pr_c p
+    | l ->
+	prlist_with_sep spc
+          (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l
+(*
+  prlist_with_sep pr_semicolon (pr_params pr_c)
+*)
+
+let pr_thm_token k = str (string_of_theorem_kind k)
+
+let pr_syntax_modifier = function
+  | SetItemLevel (l,NextLevel) ->
+      prlist_with_sep sep_v2 str l ++
+      spc() ++ str"at next level"
+  | SetItemLevel (l,NumLevel n) ->
+      prlist_with_sep sep_v2 str l ++
+      spc() ++ str"at level" ++ spc() ++ int n
+  | SetLevel n -> str"at level" ++ spc() ++ int n
+  | SetAssoc Gramext.LeftA -> str"left associativity"
+  | SetAssoc Gramext.RightA -> str"right associativity"
+  | SetAssoc Gramext.NonA -> str"no associativity"
+  | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
+  | SetOnlyParsing -> str"only parsing"
+  | SetFormat s -> str"format " ++ pr_located qs s
+
+let pr_syntax_modifiers = function
+  | [] -> mt()
+  | l -> spc() ++ 
+      hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
+
+let print_level n =
+  if n <> 0 then str " (at level " ++ int n ++ str ")" else mt ()
+
+let pr_grammar_tactic_rule n (_,pil,t) =
+  hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ 
+    hov 0 (prlist_with_sep sep pr_production_item pil ++
+    spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
+
+let pr_box b = let pr_boxkind = function
+  | PpHB n -> str"h" ++ spc() ++ int n
+  | PpVB n -> str"v" ++ spc() ++ int n
+  | PpHVB n -> str"hv" ++ spc() ++ int n
+  | PpHOVB n -> str"hov" ++ spc() ++ int n
+  | PpTB -> str"t"
+in str"<" ++ pr_boxkind b ++ str">"
+ 
+let pr_paren_reln_or_extern = function
+  | None,L -> str"L"
+  | None,E -> str"E"
+  | Some pprim,Any -> qs pprim
+  | Some pprim,Prec p -> qs pprim ++ spc() ++ str":" ++ spc() ++ int p
+  | _ -> mt()
+
+(**************************************)
+(* Pretty printer for vernac commands *)
+(**************************************)
+let make_pr_vernac pr_constr pr_lconstr =
+
+let pr_constrarg c = spc () ++ pr_constr c in
+let pr_lconstrarg c = spc () ++ pr_lconstr c in
+let pr_intarg n = spc () ++ int n in
+
+let rec pr_vernac = function
+  
+  (* Proof management *)
+  | VernacAbortAll -> str "Abort All"
+  | VernacRestart -> str"Restart"
+  | VernacSuspend -> str"Suspend"
+  | VernacUnfocus -> str"Unfocus"
+  | VernacGoal c -> str"Goal" ++ pr_lconstrarg c
+  | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id
+  | VernacResume id -> str"Resume" ++ pr_opt pr_lident id
+  | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i
+  | VernacBacktrack (i,j,k) -> 
+      str "Backtrack" ++  spc() ++ prlist_with_sep sep int [i;j;k]
+  | VernacFocus i -> str"Focus" ++ pr_opt int i
+  | VernacGo g -> 
+      let pr_goable = function
+	| GoTo i -> int i
+	| GoTop -> str"top"
+	| GoNext -> str"next"
+	| GoPrev -> str"prev" 
+      in str"Go" ++ spc() ++  pr_goable g
+  | VernacShow s -> 
+      let pr_showable = function
+	| ShowGoal n -> str"Show" ++ pr_opt int n
+	| ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n
+	| ShowProof -> str"Show Proof"
+	| ShowNode -> str"Show Node"
+	| ShowScript -> str"Show Script"
+	| ShowExistentials -> str"Show Existentials"
+	| ShowTree -> str"Show Tree"
+	| ShowProofNames -> str"Show Conjectures"
+	| ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro")
+	| ShowMatch id -> str"Show Match " ++ pr_lident id
+	| ExplainProof l -> str"Explain Proof" ++ spc() ++ prlist_with_sep sep int l
+	| ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l 
+      in pr_showable s
+  | VernacCheckGuard -> str"Guarded"
+  | VernacDebug b -> pr_topcmd b
+
+  (* Resetting *)
+  | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id
+  | VernacResetInitial -> str"Reset Initial"
+  | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i
+  | VernacBackTo i -> str"BackTo" ++ pr_intarg i
+
+  (* State management *)
+  | VernacWriteState s -> str"Write State" ++ spc () ++ qs s
+  | VernacRestoreState s -> str"Restore State" ++ spc() ++ qs s
+
+  (* Control *)
+  | VernacList l ->
+      hov 2 (str"[" ++ spc() ++
+             prlist (fun v -> pr_located pr_vernac v ++ sep_end () ++ fnl()) l
+             ++ spc() ++ str"]") 
+  | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose"
+  ++ spc()) else spc()  ++ qs s
+  | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v
+  | VernacVar id -> pr_lident id
+  
+  (* Syntax *) 
+  | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e)
+  | VernacOpenCloseScope (local,opening,sc) ->
+      str (if opening then "Open " else "Close ") ++ pr_locality local ++
+      str "Scope" ++ spc() ++ str sc
+  | VernacDelimiters (sc,key) ->
+      str"Delimit Scope" ++ spc () ++ str sc ++
+      spc() ++ str "with " ++ str key
+  | VernacBindScope (sc,cll) ->
+      str"Bind Scope" ++ spc () ++ str sc ++
+      spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll
+  | VernacArgumentsScope (q,scl) -> let pr_opt_scope = function 
+      |	None -> str"_"
+      |	Some sc -> str sc in 
+    str"Arguments Scope" ++ spc() ++ pr_reference q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
+  | VernacInfix (local,(s,mv),q,sn) -> (* A Verifier *)
+      hov 0 (hov 0 (str"Infix " ++ pr_locality local
+      ++ qs s ++ str " :=" ++ spc() ++ pr_reference q) ++
+      pr_syntax_modifiers mv ++
+      (match sn with
+    | None -> mt()
+    | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
+  | VernacNotation (local,c,(s,l),opt) ->
+      let ps =
+	let n = String.length s in
+	if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' 
+	then
+          let s' = String.sub s 1 (n-2) in
+          if String.contains s' '\'' then qs s else str s'
+	else qs s in
+      hov 2( str"Notation" ++ spc() ++ pr_locality local ++ ps ++
+      str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++
+      (match opt with
+        | None -> mt()
+        | Some sc -> str" :" ++ spc() ++ str sc))
+  | VernacSyntaxExtension (local,(s,l)) ->
+      str"Reserved Notation" ++ spc() ++ pr_locality local ++ qs s ++
+      pr_syntax_modifiers l
+
+  (* Gallina *)
+  | VernacDefinition (d,id,b,f) -> (* A verifier... *)
+      let pr_def_token dk = str (string_of_definition_kind dk) in
+      let pr_reduce = function
+        | None -> mt()
+        | Some r ->
+            str"Eval" ++ spc() ++
+            pr_red_expr (pr_constr, pr_lconstr, pr_reference) r ++
+            str" in" ++ spc() in
+      let pr_def_body = function
+        | DefineBody (bl,red,body,d) ->
+            let ty = match d with
+              | None -> mt()
+              | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
+	    in
+            (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
+        | ProveBody (bl,t) ->
+            (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
+      let (binds,typ,c) = pr_def_body b in
+      hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++
+      (match c with
+        | None -> mt()
+        | Some cc -> str" :=" ++ spc() ++ cc))
+
+  | VernacStartTheoremProof (ki,id,(bl,c),b,d) ->
+      hov 1 (pr_thm_token ki ++ spc() ++ pr_lident id ++ spc() ++
+      (match bl with
+        | [] -> mt()
+        | _ -> pr_binders bl ++ spc())
+      ++ str":" ++ pr_spc_lconstr c)
+  | VernacEndProof Admitted -> str"Admitted"
+  | VernacEndProof (Proved (opac,o)) -> (match o with
+    | None -> if opac then str"Qed" else str"Defined"
+    | Some (id,th) -> (match th with
+      |	None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id
+      |	Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) 
+  | VernacExactProof c ->
+      hov 2 (str"Proof" ++ pr_lconstrarg c)
+  | VernacAssumption (stre,l) ->
+      let n = List.length (List.flatten (List.map fst (List.map snd l))) in
+      hov 2
+        (pr_assumption_token (n > 1) stre ++ spc() ++ 
+	 pr_ne_params_list pr_lconstr_expr l)
+  | VernacInductive (f,l) ->
+
+      let pr_constructor (coe,(id,c)) =
+        hov 2 (pr_lident id ++ str" " ++
+               (if coe then str":>" else str":") ++
+                pr_spc_lconstr c) in
+      let pr_constructor_list l = match l with
+        | [] -> mt()
+        | _ ->
+            pr_com_at (begin_of_inductive l) ++
+            fnl() ++
+            str (if List.length l = 1 then "   " else " | ") ++
+            prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l in
+      let pr_oneind key (id,ntn,indpar,s,lc) =
+	hov 0 (
+          str key ++ spc() ++
+          pr_lident id ++ pr_and_type_binders_arg indpar ++ spc() ++ str":" ++ 
+	  spc() ++ pr_lconstr_expr s ++ 
+	  str" :=") ++ pr_constructor_list lc ++ 
+	pr_decl_notation pr_constr ntn in
+
+      hov 1 (pr_oneind (if f then "Inductive" else "CoInductive") (List.hd l))
+      ++ 
+      (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
+
+
+  | VernacFixpoint (recs,b) ->
+      let name_of_binder = function
+        | LocalRawAssum (nal,_) -> nal
+        | LocalRawDef (_,_) -> [] in
+      let pr_onerec = function
+        | (id,(n,ro),bl,type_,def),ntn ->
+            let (bl',def,type_) =
+              if Options.do_translate() then extract_def_binders def type_
+              else ([],def,type_) in
+            let bl = bl @ bl' in
+            let ids = List.flatten (List.map name_of_binder bl) in
+            let name =
+              try snd (List.nth ids n)
+              with Failure _ ->
+                warn (str "non-printable fixpoint \""++pr_id id++str"\"");
+                Anonymous in
+            let annot =
+	      match (ro : Topconstr.recursion_order_expr) with
+		  CStructRec -> 
+		    if List.length ids > 1 then 
+                      spc() ++ str "{struct " ++ pr_name name ++ str"}"
+		    else mt()
+		| CWfRec c -> spc() ++ str "{wf " ++ pr_name name ++ spc() ++ pr_lconstr_expr c ++ str"}"
+	    in
+            pr_id id ++ pr_binders_arg bl ++ annot ++ spc()
+            ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
+            ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ 
+	    pr_decl_notation pr_constr ntn
+      in
+      let start = if b then "Boxed Fixpoint" else "Fixpoint" in
+      hov 1 (str start ++ spc() ++
+        prlist_with_sep (fun _ -> fnl() ++ fnl() ++ str"with ") pr_onerec recs)
+
+  | VernacCoFixpoint (corecs,b) ->
+      let pr_onecorec (id,bl,c,def) =
+        let (bl',def,c) =
+              if Options.do_translate() then extract_def_binders def c
+              else ([],def,c) in
+        let bl = bl @ bl' in
+        pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
+        spc() ++ pr_lconstr_expr c ++
+        str" :=" ++ brk(1,1) ++ pr_lconstr def in
+      let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in
+      hov 1 (str start ++ spc() ++
+      prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)  
+  | VernacScheme l ->
+      hov 2 (str"Scheme" ++ spc() ++
+             prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l)
+
+  (* Gallina extensions *)
+  | VernacRecord (b,(oc,name),ps,s,c,fs) ->
+      let pr_record_field = function
+        | (oc,AssumExpr (id,t)) ->
+            hov 1 (pr_lname id ++
+            (if oc then str" :>" else str" :") ++ spc() ++
+            pr_lconstr_expr t)
+        | (oc,DefExpr(id,b,opt)) -> (match opt with
+	    | Some t ->
+                hov 1 (pr_lname id ++
+                (if oc then str" :>" else str" :") ++ spc() ++
+                pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
+	    | None ->
+                hov 1 (pr_lname id ++ str" :=" ++ spc() ++
+                pr_lconstr b)) in
+      hov 2
+        (str (if b then "Record" else "Structure") ++
+         (if oc then str" > " else str" ") ++ pr_lident name ++ 
+          pr_and_type_binders_arg ps ++ str" :" ++ spc() ++ 
+	  pr_lconstr_expr s ++ str" := " ++
+         (match c with
+           | None -> mt()
+           | Some sc -> pr_lident sc) ++
+	spc() ++ str"{"  ++
+        hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}"))
+  | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id)
+  | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id)
+  | VernacRequire (exp,spe,l) -> hov 2
+      (str "Require" ++ spc() ++ pr_require_token exp ++
+      (match spe with
+      |	None -> mt()
+      |	Some flag ->
+          (if flag then str"Specification" else str"Implementation") ++
+          spc ()) ++
+      prlist_with_sep sep pr_module l)
+  | VernacImport (f,l) ->
+      (if f then str"Export" else str"Import") ++ spc() ++
+      prlist_with_sep sep pr_import_module l
+  | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_reference q
+  | VernacCoercion (s,id,c1,c2) ->
+      hov 1 (
+	str"Coercion" ++ (match s with | Local -> spc() ++
+	  str"Local" ++ spc() | Global -> spc()) ++
+	pr_reference id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
+	spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
+  | VernacIdentityCoercion (s,id,c1,c2) ->
+      hov 1 (
+	str"Identity Coercion" ++ (match s with | Local -> spc() ++
+	  str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ 
+	spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
+	spc() ++ pr_class_rawexpr c2)
+
+  (* Modules and Module Types *)
+  | VernacDefineModule (export,m,bl,ty,bd) ->
+      let b = pr_module_binders_list bl pr_lconstr in 
+      hov 2 (str"Module" ++ spc() ++ pr_require_token export ++
+             pr_lident m ++ b ++
+             pr_opt (pr_of_module_type pr_lconstr) ty ++
+             pr_opt (fun me -> str ":= " ++ pr_module_expr me) bd)
+  | VernacDeclareModule (export,id,bl,m1) ->
+      let b = pr_module_binders_list bl pr_lconstr in 
+      hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++
+             pr_lident id ++ b ++
+             pr_of_module_type pr_lconstr m1)
+  | VernacDeclareModuleType (id,bl,m) ->
+      let b = pr_module_binders_list bl pr_lconstr in 
+      hov 2 (str"Module Type " ++ pr_lident id ++ b ++
+             pr_opt (fun mt -> str ":= " ++ pr_module_type pr_lconstr mt) m)
+
+  (* Solving *)
+  | VernacSolve (i,tac,deftac) ->
+      (if i = 1 then mt() else int i ++ str ": ") ++
+      pr_raw_tactic tac
+      ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt ()
+      with UserError _|Stdpp.Exc_located _ -> mt())
+
+  | VernacSolveExistential (i,c) ->
+      str"Existential " ++ int i ++ pr_lconstrarg c
+
+  (* Auxiliary file and library management *)
+  | VernacRequireFrom (exp,spe,f) -> hov 2
+      (str"Require" ++ spc() ++ pr_require_token exp ++
+      (match spe with
+        | None -> mt()
+        | Some false -> str"Implementation" ++ spc()
+        | Some true -> str"Specification" ++ spc ()) ++
+      qs f)
+  | VernacAddLoadPath (fl,s,d) -> hov 2
+      (str"Add" ++
+       (if fl then str" Rec " else spc()) ++
+       str"LoadPath" ++ spc() ++ qs s ++
+       (match d with 
+         | None -> mt()
+         | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) 
+  | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s
+  | VernacAddMLPath (fl,s) ->
+      str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s
+  | VernacDeclareMLModule l ->
+      hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
+  | VernacChdir s -> str"Cd" ++ pr_opt qs s
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition (rc,l) ->
+      let pr_tac_body (id, body) =
+        let idl, body =
+          match body with
+	    | Tacexpr.TacFun (idl,b) -> idl,b
+            | _ -> [], body in
+        pr_located pr_ltac_id id ++ 
+	prlist (function None -> str " _"
+                       | Some id -> spc () ++ pr_id id) idl
+	++ str" :=" ++ brk(1,1) ++
+	let idl = List.map out_some (List.filter (fun x -> not (x=None)) idl)in
+        pr_raw_tactic_env 
+	  (idl @ List.map snd (List.map fst l))
+	  (Global.env())
+	  body in
+      hov 1
+        (((*if !Options.p1 then
+	  (if rc then str "Recursive " else mt()) ++
+	  str "Tactic Definition " else*)
+	    (* Rec by default *) str "Ltac ") ++
+        prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l)
+  | VernacHints (local,dbnames,h) ->
+      pr_hints local dbnames h pr_constr pr_pattern_expr
+  | VernacSyntacticDefinition (id,c,local,onlyparsing) ->
+      hov 2
+        (str"Notation " ++ pr_locality local ++ pr_id id ++ str" :=" ++
+         pr_constrarg c ++
+         pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []))
+  | VernacDeclareImplicits (q,None) ->
+      hov 2 (str"Implicit Arguments" ++ spc() ++ pr_reference q)
+  | VernacDeclareImplicits (q,Some l) ->
+      let r = Nametab.global q in
+      Impargs.declare_manual_implicits r l;
+      let imps = Impargs.implicits_of_global r in
+      hov 1 (str"Implicit Arguments" ++ spc() ++ pr_reference q ++ spc() ++
+             str"[" ++ prlist_with_sep sep (pr_explanation imps) l ++ str"]")
+  | VernacReserve (idl,c) ->
+      hov 1 (str"Implicit Type" ++
+        str (if List.length idl > 1 then "s " else " ") ++
+        prlist_with_sep spc pr_lident idl ++ str " :" ++ spc () ++
+        pr_lconstr c)
+  | VernacSetOpacity (fl,l) ->
+      hov 1 ((if fl then str"Opaque" else str"Transparent") ++
+             spc() ++ prlist_with_sep sep pr_reference l)
+  | VernacUnsetOption na ->
+      hov 1 (str"Unset" ++ spc() ++ pr_printoption na None)
+  | VernacSetOption (na,v) -> hov 2 (str"Set" ++ spc() ++ pr_set_option na v)
+  | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l))
+  | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l))
+  | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l))
+  | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None)
+  | VernacCheckMayEval (r,io,c) -> 
+      let pr_mayeval r c = match r with 
+      | Some r0 ->
+          hov 2 (str"Eval" ++ spc() ++
+          pr_red_expr (pr_constr,pr_lconstr,pr_reference) r0 ++
+          spc() ++ str"in" ++ spc () ++ pr_constr c)
+      | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c) 
+      in 
+      (if io = None then mt() else int (out_some io) ++ str ": ") ++ 
+      pr_mayeval r c
+  | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c)
+  | VernacPrint p -> 
+      let pr_printable = function
+	| PrintFullContext -> str"Print All"
+	| PrintSectionContext s ->
+            str"Print Section" ++ spc() ++ Libnames.pr_reference s
+	| PrintGrammar (uni,ent) ->
+            msgerrnl (str "warning: no direct translation of Print Grammar entry"); 
+            str"Print Grammar" ++ spc() ++ str ent
+	| PrintLoadPath -> str"Print LoadPath"
+	| PrintModules -> str"Print Modules"
+	| PrintMLLoadPath -> str"Print ML Path"
+	| PrintMLModules -> str"Print ML Modules"
+	| PrintGraph -> str"Print Graph"
+	| PrintClasses -> str"Print Classes"
+	| PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_reference qid
+	| PrintCoercions -> str"Print Coercions"
+	| PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t
+	| PrintCanonicalConversions -> str"Print Canonical Structures"
+	| PrintTables -> str"Print Tables"
+	| PrintOpaqueName qid -> str"Print Term" ++ spc() ++ pr_reference qid
+	| PrintHintGoal -> str"Print Hint"
+	| PrintHint qid -> str"Print Hint" ++ spc() ++ pr_reference qid
+	| PrintHintDb -> str"Print Hint *"
+	| PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s
+	| PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s
+	| PrintUniverses fopt -> str"Dump Universes" ++ pr_opt str fopt
+	| PrintName qid -> str"Print" ++ spc()  ++ pr_reference qid
+	| PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid
+	| PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid
+	| PrintInspect n -> str"Inspect" ++ spc() ++ int n
+  | PrintSetoids -> str"Print Setoids"
+	| PrintScopes -> str"Print Scopes"
+	| PrintScope s -> str"Print Scope" ++ spc() ++ str s 
+	| PrintVisibility s -> str"Print Visibility" ++ pr_opt str s 
+	| PrintAbout qid -> str"About" ++ spc()  ++ pr_reference qid
+	| PrintImplicit qid -> str"Print Implicit" ++ spc()  ++ pr_reference qid
+      in pr_printable p
+  | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_pattern_expr
+  | VernacLocate loc -> 
+      let pr_locate =function
+	| LocateTerm qid ->  pr_reference qid
+	| LocateFile f -> str"File" ++ spc() ++ qs f
+	| LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid
+	| LocateModule qid -> str"Module" ++ spc () ++ pr_module qid
+	| LocateNotation s -> qs s
+      in str"Locate" ++ spc() ++ pr_locate loc
+  | VernacComments l ->
+      hov 2
+        (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l)
+  | VernacNop -> mt()
+  
+  (* Toplevel control *)
+  | VernacToplevelControl exn -> pr_topcmd exn
+
+  (* For extension *)
+  | VernacExtend (s,c) -> pr_extend s c
+  | VernacProof Tacexpr.TacId _ -> str "Proof"
+  | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te 
+
+and pr_extend s cl =
+  let pr_arg a =
+    try pr_gen (Global.env()) a
+    with Failure _ -> str ("<error in "^s^">") in
+  try
+    let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in
+    let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in
+    let (pp,_) =
+      List.fold_left
+        (fun (strm,args) pi ->
+          match pi with
+              Egrammar.TacNonTerm _ -> 
+                (strm ++ pr_gen (Global.env()) (List.hd args),
+                List.tl args)
+            | Egrammar.TacTerm s -> (strm ++ spc() ++ str s, args))
+        (mt(),cl) rl in
+    hov 1 pp
+  with Not_found ->
+    hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")")
+
+in pr_vernac
+
+let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end ()
diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli
new file mode 100644
index 00000000..21d983f5
--- /dev/null
+++ b/parsing/ppvernac.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: ppvernac.mli 7744 2005-12-27 09:16:06Z herbelin $ i*)
+
+open Pp
+open Genarg
+open Vernacexpr
+open Names
+open Nameops
+open Nametab
+open Util
+open Ppconstr
+open Pptactic
+open Rawterm
+open Pcoq
+open Libnames
+open Ppextend
+open Topconstr
+
+val sep_end : unit -> std_ppcmds
+
+val pr_vernac : vernac_expr -> std_ppcmds
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
index 1505745c..a22f5796 100644
--- a/parsing/prettyp.ml
+++ b/parsing/prettyp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: prettyp.ml,v 1.50.2.2 2005/11/21 09:16:28 herbelin Exp $ *)
+(* $Id: prettyp.ml 7938 2006-01-28 22:03:33Z herbelin $ *)
 
 open Pp
 open Util
@@ -20,7 +20,6 @@ open Inductiveops
 open Sign
 open Reduction
 open Environ
-open Instantiate
 open Declare
 open Impargs
 open Libobject
@@ -28,6 +27,7 @@ open Printer
 open Printmod
 open Libnames
 open Nametab
+open Recordops
 
 (*********************)
 (** Basic printing   *)
@@ -58,8 +58,7 @@ let print_impl_args_by_name = function
       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)
+  print_impl_args_by_name (List.filter is_status_implicit l)
 
 (*********************)
 (** Printing Scopes  *)
@@ -71,7 +70,7 @@ let print_ref reduce ref =
       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 ()
+  hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) ++ fnl ()
 
 let print_argument_scopes = function
   | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl()
@@ -89,9 +88,32 @@ let need_expansion impl ref =
   impl <> [] & let _,lastimpl = list_chop nprods impl in
   List.filter is_status_implicit lastimpl <> []
 
+type opacity =
+  | FullyOpaque
+  | TransparentMaybeOpacified of bool
+
+let opacity env = function
+  | VarRef v when pi2 (Environ.lookup_named v env) <> None -> 
+      Some (TransparentMaybeOpacified (Conv_oracle.is_opaque_var v))
+  | ConstRef cst ->
+      let cb = Environ.lookup_constant cst env in
+      if cb.const_body = None then None
+      else if cb.const_opaque then Some FullyOpaque
+      else Some (TransparentMaybeOpacified (Conv_oracle.is_opaque_cst cst))
+  | _ -> None
+
+let print_opacity ref =
+  match opacity (Global.env()) ref with
+    | None -> mt ()
+    | Some s -> pr_global ref ++ str " is " ++ 
+        str (match s with
+          | FullyOpaque -> "opaque"
+          | TransparentMaybeOpacified true -> "basically transparent but considered opaque for reduction"
+          | TransparentMaybeOpacified false -> "transparent") ++ fnl()
+    
 let print_name_infos ref =
   let impl = implicits_of_global ref in
-  let scopes = Symbols.find_arguments_scope ref in
+  let scopes = Notation.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 *)
@@ -127,7 +149,7 @@ let print_inductive_implicit_args =
 
 let print_inductive_argument_scopes =
   print_args_data_of_inductive_ids 
-    Symbols.find_arguments_scope ((<>) None) print_argument_scopes
+    Notation.find_arguments_scope ((<>) None) print_argument_scopes
 
 (*********************)
 (* "Locate" commands *)
@@ -160,8 +182,7 @@ let pr_located_qualid = function
 	| 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)
+      str "Notation" ++ spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn)
   | Dir dir ->
       let s,dir = match dir with
 	| DirOpenModule (dir,_) -> "Open Module", dir
@@ -180,9 +201,9 @@ let print_located_qualid ref =
   let (loc,qid) = qualid_of_reference ref in
   let module N = Nametab in
   let expand = function
-    | TrueGlobal ref -> 
+    | TrueGlobal ref ->
 	Term ref, N.shortest_qualid_of_global Idset.empty ref
-    | SyntacticDef kn -> 
+    | SyntacticDef kn ->
 	Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in
   match List.map expand (N.extended_locate_all qid) with
     | [] -> 
@@ -196,7 +217,7 @@ let print_located_qualid ref =
 	(fun (o,oqid) ->
 	  hov 2 (pr_located_qualid o ++
 	  (if oqid <> qid then
-	    spc() ++ str "(visible as " ++ pr_qualid oqid ++ str")"
+	    spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")"
 	  else
 	    mt ()))) l
 
@@ -204,8 +225,8 @@ let print_located_qualid ref =
 (**** Printing declarations and judgments *)
 
 let print_typed_value_in_env env (trm,typ) =
-  (prterm_env env trm ++ fnl () ++
-     str "     : " ++ prtype_env env typ ++ fnl ())
+  (pr_lconstr_env env trm ++ fnl () ++
+     str "     : " ++ pr_ltype_env env typ ++ fnl ())
 
 let print_typed_value x = print_typed_value_in_env (Global.env ()) x
 
@@ -218,20 +239,20 @@ let print_safe_judgment env j =
   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
+   abstractions. This should be done recursively inside pr_lconstr, 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
+  let pbody = pr_lconstr body in
+  let ptyp = pr_ltype 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 ())
+  (str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" ++ fnl ())
 
 let print_named_decl (id,c,typ) =
   let s = string_of_id id in
@@ -246,25 +267,19 @@ let assumptions_for_print lna =
 (* *)
 
 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))
+  if params = [] then mt () 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)
+      (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_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 params = mib.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
@@ -280,7 +295,7 @@ let print_one_inductive (sp,tyi) =
   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 " :=") ++
+    str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++
   brk(0,2) ++ print_constructors envpar cstrnames cstrtypes
 
 let pr_mutual_inductive finite indl =
@@ -304,11 +319,11 @@ let print_section_variable sp =
   print_name_infos (VarRef sp)
 
 let print_body = function
-  | Some lc  -> prterm (Declarations.force lc)
+  | Some lc  -> pr_lconstr (Declarations.force lc)
   | None -> (str"<no body>")
 
 let print_typed_body (val_0,typ) =
-  (print_body val_0 ++ fnl () ++ str "     : " ++ prtype typ ++ fnl ())
+  (print_body val_0 ++ fnl () ++ str "     : " ++ pr_ltype typ ++ fnl ())
 
 let print_constant with_values sep sp =
   let cb = Global.lookup_constant sp in
@@ -318,11 +333,11 @@ let print_constant with_values sep sp =
     match val_0 with 
     | None -> 
 	str"*** [ " ++ 
-	print_basename sp ++ str " : " ++ cut () ++ prtype typ ++ 
+	print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ 
 	str" ]" ++ fnl ()
     | _ -> 
 	print_basename sp ++ str sep ++ cut () ++
-	(if with_values then print_typed_body (val_0,typ) else prtype typ) ++
+	(if with_values then print_typed_body (val_0,typ) else pr_ltype typ) ++
 	fnl ())
 
 let print_constant_with_infos sp =
@@ -333,17 +348,18 @@ let print_inductive sp = (print_mutual sp)
 let print_syntactic_def sep kn =
   let qid = Nametab.shortest_qualid_of_syndef Idset.empty 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 ())
+  str "Notation " ++ pr_qualid qid ++ str sep ++ 
+  Constrextern.without_symbols pr_lrawconstr 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))
+	(* Outside sections, VARIABLES still exist but only with universes 
+           constraints *)
+	(try Some(print_section_variable (basename sp)) with Not_found -> None)
     | (_,"CONSTANT") ->
-	Some (print_constant with_values sep kn)
+	Some (print_constant with_values sep (constant_of_kn kn))
     | (_,"INDUCTIVE") ->
 	Some (print_inductive kn)
     | (_,"MODULE") ->
@@ -369,7 +385,7 @@ let rec print_library_entry with_values ent =
 	print_leaf_entry with_values sep (oname,lobj)
     | (oname,Lib.OpenedSection (dir,_)) -> 
         Some (str " >>>>>>> Section " ++ pr_name oname)
-    | (oname,Lib.ClosedSection _) -> 
+    | (oname,Lib.ClosedSection) -> 
         Some (str " >>>>>>> Closed Section " ++ pr_name oname)
     | (_,Lib.CompilingLibrary (dir,_)) ->
 	Some (str " >>>>>>> Library " ++ pr_dirpath dir)
@@ -419,9 +435,9 @@ let read_sec_context r =
     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 ->
+    | (_,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 ->
+    | (_,Lib.ClosedSection)::rest ->
         error "Cannot print the contents of a closed section"
     | [] -> []
     | hd::rest -> get_cxt (hd::in_cxt) rest 
@@ -474,9 +490,7 @@ let print_name ref =
       "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
@@ -487,19 +501,21 @@ let print_opaque_name qid =
     | IndRef (sp,_) ->
         print_mutual sp
     | ConstructRef cstr -> 
-	let ty = Inductive.type_of_constructor env cstr in
+	let ty = Inductiveops.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
+  | Term ref -> 
+      print_ref false ref ++ print_name_infos ref ++ print_opacity ref
+  | Syntactic kn ->
+      print_syntactic_def " := " kn
+  | Dir _ | ModuleType _ | Undefined _ ->
+      mt () end
   ++
   hov 0 (str "Expands to: " ++ pr_located_qualid k)
 
@@ -512,38 +528,6 @@ let print_impargs ref =
   (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 
@@ -563,17 +547,17 @@ let inspect depth =
 
 open Classops
 
-let print_coercion_value v = prterm (get_coercion_value v)
+let print_coercion_value v = pr_lconstr (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)
+  hov 2 (
+    str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++
+    str"] : ") ++
+  print_class i ++ str" >-> " ++ print_class j
 
 let _ = Classops.install_path_printer print_path
 
@@ -604,4 +588,9 @@ let print_path_between cls clt =
   in
   print_path ((i,j),p)
 
+let print_canonical_projections () =
+  prlist_with_sep pr_fnl (fun ((r1,r2),o) -> 
+    pr_global r2 ++ str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )")
+    (canonical_projections ())
+
 (*************************************************************************)
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
index c8471330..13c11db7 100644
--- a/parsing/prettyp.mli
+++ b/parsing/prettyp.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: prettyp.mli 7740 2005-12-26 20:07:21Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -42,7 +42,6 @@ val build_inductive : mutual_inductive -> int ->
 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
 
@@ -57,6 +56,7 @@ 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 print_canonical_projections : unit -> std_ppcmds
 
 val inspect : int -> std_ppcmds
 
diff --git a/parsing/printer.ml b/parsing/printer.ml
index dfacc764..82676b79 100644
--- a/parsing/printer.ml
+++ b/parsing/printer.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: printer.ml,v 1.58.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+(* $Id: printer.ml 7855 2006-01-12 08:21:57Z herbelin $ *)
 
 open Pp
 open Util
@@ -18,139 +18,100 @@ open Sign
 open Environ
 open Global
 open Declare
-open Coqast
-open Ast
-open Termast
 open Libnames
-open Extend
 open Nametab
 open Ppconstr
+open Evd
+open Proof_type
+open Refiner
+open Pfedit
+open Ppconstr
+open Constrextern
 
 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
+(** Terms                                                             *)
 
-(**********************************************************************)
-(* Generic printing: choose old or new printers *)
+  (* [at_top] means ids of env must be avoided in bound variables *)
+let pr_constr_core at_top env t =
+  pr_constr_expr (extern_constr at_top env t)
+let pr_lconstr_core at_top env t =
+  pr_lconstr_expr (extern_constr at_top env t)
+
+let pr_lconstr_env_at_top env = pr_lconstr_core true env
+let pr_lconstr_env env = pr_lconstr_core false env
+let pr_constr_env env = pr_constr_core false env
+
+  (* NB do not remove the eta-redexes! Global.env() has side-effects... *)
+let pr_lconstr t = pr_lconstr_env (Global.env()) t
+let pr_constr t = pr_constr_env (Global.env()) t
+
+let pr_type_core at_top env t =
+  pr_constr_expr (extern_type at_top env t)
+let pr_ltype_core at_top env t =
+  pr_lconstr_expr (extern_type at_top env t)
+
+let pr_ltype_env_at_top env = pr_ltype_core true env
+let pr_ltype_env env = pr_ltype_core false env
+let pr_type_env env = pr_type_core false env
+
+let pr_ltype t = pr_ltype_env (Global.env()) t
+let pr_type t = pr_type_env (Global.env()) t
+
+let pr_ljudge_env env j =
+  (pr_lconstr_env env j.uj_val, pr_lconstr_env env j.uj_type)
+
+let pr_ljudge j = pr_ljudge_env (Global.env()) j
+
+let pr_lrawconstr_env env c =
+  pr_lconstr_expr (extern_rawconstr (vars_of_env env) c)
+let pr_rawconstr_env env c = 
+  pr_constr_expr (extern_rawconstr (vars_of_env env) c)
+
+let pr_lrawconstr c =
+  pr_lconstr_expr (extern_rawconstr Idset.empty c)
+let pr_rawconstr c =
+  pr_constr_expr (extern_rawconstr Idset.empty c)
 
-(* [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)
+  pr_cases_pattern_expr (extern_cases_pattern Idset.empty t)
+
+let pr_constr_pattern_env env c =
+  pr_constr_expr (extern_constr_pattern (names_of_rel_context env) c)
+let pr_constr_pattern t =
+  pr_constr_expr (extern_constr_pattern empty_names_context t)
+
+let _ = Termops.set_print_constr pr_lconstr_env
 
 (**********************************************************************)
-(* 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
+(* Global references *)
+
+let pr_global_env = pr_global_env
+let pr_global = pr_global_env Idset.empty
+
+let pr_constant env cst = pr_global_env (vars_of_env env) (ConstRef cst)
+let pr_existential env ev = pr_lconstr_env env (mkEvar ev)
+let pr_inductive env ind = pr_lconstr_env env (mkInd ind)
+let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr)
+
+let pr_evaluable_reference ref =
+ let ref' = match ref with
+  | EvalConstRef const -> ConstRef const
+  | EvalVarRef sp -> VarRef sp in
+ pr_global ref'
+
+(**********************************************************************)
+(* Contexts and declarations                                          *)
 
 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
+	let pb = pr_lconstr_env env c in
 	(str" := " ++ pb ++ cut () ) in
-  let pt = prtype_env env typ in
+  let pt = pr_ltype_env env typ in
   let ptyp = (str" : " ++ pt) in
   (pr_id id ++ hov 0 (pbody ++ ptyp))
 
@@ -159,9 +120,9 @@ let pr_rel_decl env (na,c,typ) =
     | None -> mt ()
     | Some c ->
 	(* Force evaluation *) 
-	let pb = prterm_env env c in
+	let pb = pr_lconstr_env env c in
 	(str":=" ++ spc () ++ pb ++ spc ()) in
-  let ptyp = prtype_env env typ in
+  let ptyp = pr_ltype_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)
@@ -177,22 +138,25 @@ let pr_named_context_of env =
 	  (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d)
           env ~init:(mt ()))
 
+let pr_named_context env ne_context = 
+  hv 0 (Sign.fold_named_context
+	  (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d)
+          ne_context ~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] -> 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)
+        str "(" ++ pb ++ str")" ++ spc () ++ penvtl
   in 
   hov 0 (prec env (List.rev rel_context))
 
+let pr_rel_context_of env =
+  pr_rel_context env (rel_context env)
+
 (* Prints an env (variables and de Bruijn). Separator: newline *)
 let pr_context_unlimited env =
   let sign_env =
@@ -247,3 +211,168 @@ let pr_context_limit n 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)
+
+
+(* display complete goal *)
+let pr_goal g =
+  let env = evar_env g in
+  let penv = pr_context_of env in
+  let pc = pr_ltype_env_at_top env g.evar_concl in
+  str"  " ++ hv 0 (penv ++ fnl () ++
+		   str (emacs_str (String.make 1 (Char.chr 253)))  ++
+                   str "============================" ++ fnl ()  ++
+                   str" "  ++ pc) ++ fnl ()
+
+(* display the conclusion of a goal *)
+let pr_concl n g =
+  let env = evar_env g in
+  let pc = pr_ltype_env_at_top env g.evar_concl in
+  str (emacs_str (String.make 1 (Char.chr 253)))  ++
+  str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" "  ++ pc
+
+(* display evar type: a context and a type *)
+let pr_evgl_sign gl = 
+  let ps = pr_named_context_of (evar_env gl) in
+  let pc = pr_lconstr gl.evar_concl in
+  hov 0 (str"["  ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]")
+
+(* Print an enumerated list of existential variables *)
+let rec pr_evars_int i = function
+  | [] -> (mt ())
+  | (ev,evd)::rest ->
+      let pegl = pr_evgl_sign evd in 
+      let pei = pr_evars_int (i+1) rest in
+      (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++
+              str (string_of_existential ev)  ++ str " : " ++ pegl)) ++ 
+      fnl () ++ pei
+
+let pr_subgoal n =
+  let rec prrec p = function
+    | [] -> error "No such goal"
+    | g::rest ->
+       	if p = 1 then
+          let pg = pr_goal g in
+          v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg)
+       	else 
+	  prrec (p-1) rest
+  in 
+  prrec n
+
+(* Print open subgoals. Checks for uninstantiated existential variables *)
+let pr_subgoals sigma = function 
+  | [] -> 
+      let exl = Evarutil.non_instantiated sigma in 
+      if exl = [] then 
+	(str"Proof completed."  ++ fnl ())
+      else
+        let pei = pr_evars_int 1 exl in
+        (str "No more subgoals but non-instantiated existential " ++
+           str "variables :"  ++fnl () ++ (hov 0 pei))
+  | [g] ->
+      let pg = pr_goal g in
+      v 0 (str ("1 "^"subgoal") ++cut () ++ pg)
+  | g1::rest ->
+      let rec pr_rec n = function
+        | [] -> (mt ())
+        | g::rest ->
+            let pc = pr_concl n g in
+            let prest = pr_rec (n+1) rest in
+            (cut () ++ pc ++ prest) 
+      in
+      let pg1 = pr_goal g1 in
+      let prest = pr_rec 2 rest in
+      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () 
+	   ++ pg1 ++ prest ++ fnl ())
+
+
+let pr_subgoals_of_pfts pfts = 
+  let gls = fst (Refiner.frontier (proof_of_pftreestate pfts)) in 
+  let sigma = (top_goal_of_pftreestate pfts).sigma in
+  pr_subgoals sigma gls
+
+let pr_open_subgoals () =
+  let pfts = get_pftreestate () in
+  match focus() with
+    | 0 -> 
+	pr_subgoals_of_pfts pfts
+    | n -> 
+	let pf = proof_of_pftreestate pfts in
+	let gls = fst (frontier pf) in 
+	assert (n > List.length gls);
+	if List.length gls < 2 then 
+	  pr_subgoal n gls
+	else 
+	  v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++
+	  pr_subgoal n gls)
+
+let pr_nth_open_subgoal n =
+  let pf = proof_of_pftreestate (get_pftreestate ()) in
+  pr_subgoal n (fst (frontier pf))
+
+(* Elementary tactics *)
+
+let pr_prim_rule = function
+  | Intro id -> 
+      str"intro " ++ pr_id id
+	
+  | Intro_replacing id -> 
+      (str"intro replacing "  ++ pr_id id)
+	
+  | Cut (b,id,t) ->
+      if b then
+        (str"assert " ++ pr_constr t)
+      else
+        (str"cut " ++ pr_constr t ++ str ";[intro " ++ pr_id id ++ str "|idtac]")
+	
+  | FixRule (f,n,[]) ->
+      (str"fix " ++ pr_id f ++ str"/" ++ int n)
+      
+  | FixRule (f,n,others) -> 
+      let rec print_mut = function
+	| (f,n,ar)::oth -> 
+           pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth
+        | [] -> mt () in
+      (str"fix " ++ pr_id f ++ str"/" ++ int n ++
+         str" with " ++ print_mut others)
+
+  | Cofix (f,[]) ->
+      (str"cofix " ++ pr_id f)
+
+  | Cofix (f,others) ->
+      let rec print_mut = function
+	| (f,ar)::oth ->
+	  (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth)
+        | [] -> mt () in
+      (str"cofix " ++ pr_id f ++  str" with " ++ print_mut others)
+
+  | Refine c -> 
+      str(if occur_meta c then "refine " else "exact ") ++
+      Constrextern.with_meta_as_hole pr_constr c
+      
+  | Convert_concl (c,_) ->
+      (str"change "  ++ pr_constr c)
+      
+  | Convert_hyp (id,None,t) ->
+      (str"change "  ++ pr_constr t  ++ spc ()  ++ str"in "  ++ pr_id id)
+
+  | Convert_hyp (id,Some c,t) ->
+      (str"change "  ++ pr_constr c  ++ spc ()  ++ str"in "
+       ++ pr_id id ++ str" (type of "  ++ pr_id id ++ str ")")
+      
+  | Thin ids ->
+      (str"clear "  ++ prlist_with_sep pr_spc pr_id ids)
+      
+  | ThinBody ids ->
+      (str"clearbody "  ++ prlist_with_sep pr_spc pr_id ids)
+      
+  | Move (withdep,id1,id2) ->
+      (str (if withdep then "dependent " else "") ++
+	 str"move "  ++ pr_id id1 ++ str " after " ++ pr_id id2)
+
+  | Rename (id1,id2) ->
+      (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2)
+
+(* Backwards compatibility *)
+
+let prterm = pr_lconstr
+
diff --git a/parsing/printer.mli b/parsing/printer.mli
index c44be124..66471d41 100644
--- a/parsing/printer.mli
+++ b/parsing/printer.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: printer.mli,v 1.26.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: printer.mli 7855 2006-01-12 08:21:57Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -19,42 +19,82 @@ open Rawterm
 open Pattern
 open Nametab
 open Termops
+open Evd
+open Proof_type
+open Rawterm
 (*i*)
 
 (* These are the entry points for printing terms, context, tac, ... *)
-(*i
-val gentacpr  : Tacexpr.raw_tactic_expr -> std_ppcmds
-i*)
-
-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
 
+(* Terms *)
+
+val pr_lconstr_env         : env -> constr -> std_ppcmds
+val pr_lconstr_env_at_top  : env -> constr -> std_ppcmds
+val pr_lconstr             : constr -> std_ppcmds
+
+val pr_constr_env          : env -> constr -> std_ppcmds
+val pr_constr              : constr -> std_ppcmds
+
+val pr_ltype_env           : env -> types -> std_ppcmds
+val pr_ltype               : types -> std_ppcmds
+
+val pr_type_env            : env -> types -> std_ppcmds
+val pr_type                : types -> std_ppcmds
+
+val pr_ljudge_env          : env -> unsafe_judgment -> std_ppcmds * std_ppcmds
+val pr_ljudge              : unsafe_judgment -> std_ppcmds * std_ppcmds
+
+val pr_lrawconstr_env      : env -> rawconstr -> std_ppcmds
+val pr_lrawconstr          : rawconstr -> std_ppcmds
+
+val pr_rawconstr_env       : env -> rawconstr -> std_ppcmds
+val pr_rawconstr           : rawconstr -> std_ppcmds
+
+val pr_constr_pattern_env  : env -> constr_pattern -> std_ppcmds
+val pr_constr_pattern      : constr_pattern -> std_ppcmds
+
+val pr_cases_pattern       : cases_pattern -> std_ppcmds
+
+(* Printing global references using names as short as possible *)
+
+val pr_global_env          : Idset.t -> global_reference -> std_ppcmds
+val pr_global              : global_reference -> 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_evaluable_reference : evaluable_global_reference -> std_ppcmds
+
+(* Contexts *)
+
+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       : env -> named_context -> std_ppcmds
+val pr_named_context_of    : env -> std_ppcmds
+val pr_rel_context         : env -> rel_context -> std_ppcmds
+val pr_rel_context_of      : env -> std_ppcmds
+val pr_context_of          : env -> std_ppcmds
+
+(* Proofs *)
+
+val pr_goal                : goal -> std_ppcmds
+val pr_subgoals            : evar_map -> goal list -> std_ppcmds
+val pr_subgoal             : int -> goal list -> std_ppcmds
+
+val pr_open_subgoals       : unit -> std_ppcmds
+val pr_nth_open_subgoal    : int -> std_ppcmds
+val pr_evars_int           : int -> (evar * evar_info) list -> std_ppcmds
+
+val pr_prim_rule           : prim_rule -> std_ppcmds
+
+(* Emacs/proof general support *)
+
+val emacs_str              : string -> string
+
+(* Backwards compatibility *)
+
+val prterm                 : constr -> std_ppcmds (* = pr_lconstr *)
diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4
new file mode 100644
index 00000000..768bc45c
--- /dev/null
+++ b/parsing/q_constr.ml4
@@ -0,0 +1,124 @@
+(************************************************************************)
+(*  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.58 2005/12/30 10:55:32 herbelin Exp $ *)
+
+open Rawterm
+open Term
+open Names
+open Pattern
+open Q_util
+open Util
+open Pcaml
+
+let loc = dummy_loc
+let dloc = <:expr< Util.dummy_loc >>
+
+let apply_ref f l = 
+  <:expr< 
+    Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$)
+  >>
+
+EXTEND
+  GLOBAL: expr;
+  expr:
+    [ [ "PATTERN"; "["; c = constr; "]" ->
+      <:expr< snd (Pattern.pattern_of_rawconstr $c$) >> ] ]
+  ;
+  sort:
+    [ [ "Set"  -> RProp Pos
+      | "Prop" -> RProp Null
+      | "Type" -> RType None ] ]
+  ;
+  ident:
+    [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ]
+  ;
+  name:
+    [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ]
+  ;
+  string:
+    [ [ UIDENT | LIDENT ] ]
+  ;
+  constr:
+    [ "200" RIGHTA
+      [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr ->
+        <:expr< Rawterm.RProd ($dloc$,Name $id$,$c1$,$c2$) >>
+      | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr ->
+        <:expr< Rawterm.RLambda ($dloc$,Name $id$,$c1$,$c2$) >>
+      | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr ->
+        <:expr< Rawterm.RLetin ($dloc$,Name $id$,$c1$,$c2$) >>
+      (* fix todo *)
+      ]
+    | "100" RIGHTA
+      [ c1 = constr; ":"; c2 = SELF -> 
+        <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
+    | "90" RIGHTA
+      [ c1 = constr; "->"; c2 = SELF -> 
+        <:expr< Rawterm.RProd ($dloc$,Anonymous,$c1$,$c2$) >> ]
+    | "75" RIGHTA
+      [ "~"; c = constr -> 
+        apply_ref <:expr< coq_not_ref >> [c] ]
+    | "70" RIGHTA
+      [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT ->
+        apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ]
+    | "10" LEFTA
+      [ f = constr; args = LIST1 NEXT ->
+        let args = mlexpr_of_list (fun x -> x) args in
+        <:expr< Rawterm.RApp ($dloc$,$f$,$args$) >> ]
+    | "0"
+      [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >>
+      | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >>
+      | "_" -> <:expr< Rawterm.RHole ($dloc$,QuestionMark) >>
+      | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >>
+      | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" ->
+          apply_ref <:expr< coq_sumbool_ref >> [c1;c2]
+      | "%"; e = string -> <:expr< Rawterm.RRef ($dloc$,Lazy.force $lid:e$) >>
+      | c = match_constr -> c
+      | "("; c = constr LEVEL "200"; ")" -> c ] ]
+  ;
+  match_constr:
+    [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type;
+        "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> 
+          let br = mlexpr_of_list (fun x -> x) br in
+     <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> 
+    ] ]
+  ;
+  match_type:
+    [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name;  
+        "return"; ty = constr LEVEL "100" -> 
+          let nal = mlexpr_of_list (fun x -> x) nal in
+          <:expr< Some $ty$ >>, 
+          <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> 
+      | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ]
+  ;
+  eqn:
+    [ [ (lid,pl) = pattern; "=>"; rhs = constr -> 
+        let lid = mlexpr_of_list (fun x -> x) lid in
+        <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> 
+    ] ]
+  ;
+  pattern: 
+    [ [ "%"; e = string; lip = LIST0 patvar ->
+        let lp = mlexpr_of_list (fun (_,x) -> x) lip in
+        let lid = List.flatten (List.map fst lip) in
+        lid, <:expr< Rawterm.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >>
+      | p = patvar -> p
+      | "("; p = pattern; ")" -> p ] ]
+  ;
+  patvar:
+    [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> 
+      | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> 
+    ] ]
+  ;
+  END;;
+
+(* Example 
+open Coqlib
+let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ]
+*)
+
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
index e8e1830a..35801f73 100644
--- a/parsing/q_coqast.ml4
+++ b/parsing/q_coqast.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: q_coqast.ml4,v 1.47.2.6 2005/05/15 12:47:05 herbelin Exp $ *)
+(* $Id: q_coqast.ml4 8651 2006-03-21 21:54:43Z jforest $ *)
 
 open Util
 open Names
@@ -21,7 +21,7 @@ let purge_str s =
 
 let anti loc x =
   let e =
-    let loc = 
+    let loc =
       ifdef OCAML_308 then
         loc
       else
@@ -30,87 +30,6 @@ let anti loc 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
 
@@ -139,6 +58,7 @@ let mlexpr_of_reference = function
 let mlexpr_of_intro_pattern = function
   | Genarg.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO"
   | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >>
+  | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >>
   | Genarg.IntroIdentifier id ->
       <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
 
@@ -165,12 +85,12 @@ 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)) >>
+  | id, occs, Tacexpr.InHyp ->
+      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHyp) >>
+  | id, occs, Tacexpr.InHypTypeOnly ->
+      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHypTypeOnly) >>
+  | id, occs, Tacexpr.InHypValueOnly ->
+      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHypValueOnly) >>
 
 let mlexpr_of_clause cl =
   <:expr< {Tacexpr.onhyps=
@@ -179,13 +99,6 @@ let mlexpr_of_clause cl =
            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;
@@ -218,7 +131,6 @@ let rec mlexpr_of_constr = function
   | 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$
@@ -248,6 +160,7 @@ let mlexpr_of_red_expr = function
   | Rawterm.Pattern l ->
       let f = mlexpr_of_list mlexpr_of_occ_constr in
       <:expr< Rawterm.Pattern $f l$ >>
+  | Rawterm.CbvVm -> <:expr< Rawterm.CbvVm >>
   | Rawterm.ExtraRedExpr s ->
       <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ >>
 
@@ -259,15 +172,14 @@ let rec mlexpr_of_argtype loc = function
   | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >>
   | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >>
   | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >>
-  | Genarg.HypArgType -> <:expr< Genarg.HypArgType >>
+  | Genarg.VarArgType -> <:expr< Genarg.VarArgType >>
   | Genarg.StringArgType -> <:expr< Genarg.StringArgType >>
   | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >>
-  | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >>
-  | Genarg.CastedOpenConstrArgType -> <:expr< Genarg.CastedOpenConstrArgType >>
+  | Genarg.OpenConstrArgType b -> <:expr< Genarg.OpenConstrArgType $mlexpr_of_bool b$ >>
   | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >>
   | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >>
   | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >>
-  | Genarg.TacticArgType -> <:expr< Genarg.TacticArgType >>
+  | Genarg.TacticArgType n -> <:expr< Genarg.TacticArgType $mlexpr_of_int n$ >>
   | Genarg.SortArgType -> <:expr< Genarg.SortArgType >>
   | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >>
   | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >>
@@ -335,6 +247,11 @@ 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 mlexpr_of_message_token = function
+  | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >>
+  | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >>
+  | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >>
+
 let rec mlexpr_of_atomic_tactic = function
   (* Basic tactics *)
   | Tacexpr.TacIntroPattern pl ->
@@ -350,6 +267,8 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacAssumption >>
   | Tacexpr.TacExact c ->
       <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >>
+  | Tacexpr.TacExactNoCheck c ->
+      <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >>
   | Tacexpr.TacApply cb ->
       <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >>
   | Tacexpr.TacElim (cb,cbo) ->
@@ -384,11 +303,10 @@ let rec mlexpr_of_atomic_tactic = function
 
   | 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.TacAssert (t,ipat,c) ->
+      let ipat = mlexpr_of_intro_pattern ipat in
+      <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ 
+	      $mlexpr_of_constr c$ >>
   | Tacexpr.TacGeneralize cl ->
       <:expr< Tacexpr.TacGeneralize $mlexpr_of_list mlexpr_of_constr cl$ >>
   | Tacexpr.TacGeneralizeDep c ->
@@ -399,23 +317,25 @@ let rec mlexpr_of_atomic_tactic = function
       <: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) ->
+  | Tacexpr.TacSimpleInduction h ->
+      <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$) >>
+  | Tacexpr.TacNewInduction (cl,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 [])>>
+      let ids = mlexpr_of_intro_pattern ids in
+(*       let ids = mlexpr_of_option mlexpr_of_intro_pattern ids in *)
+(*       <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ $ids$>> *)
+      <:expr< Tacexpr.TacNewInduction $mlexpr_of_list mlexpr_of_induction_arg cl$ $cbo$ $ids$>>
   | 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 []) >>
+      let ids = mlexpr_of_intro_pattern ids in
+      <:expr< Tacexpr.TacNewDestruct $mlexpr_of_list mlexpr_of_induction_arg c$ $cbo$ $ids$ >>
 
   (* Context management *)
-  | Tacexpr.TacClear l ->
+  | Tacexpr.TacClear (b,l) ->
       let l = mlexpr_of_list (mlexpr_of_hyp) l in
-      <:expr< Tacexpr.TacClear $l$ >>
+      <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >>
   | Tacexpr.TacClearBody l ->
       let l = mlexpr_of_list (mlexpr_of_hyp) l in
       <:expr< Tacexpr.TacClearBody $l$ >>
@@ -453,15 +373,15 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_constr c$ >>
 
   (* Automation tactics *)
-  | Tacexpr.TacAuto (n,l) ->
+  | Tacexpr.TacAuto (n,lems,l) ->
       let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in
+      let lems = mlexpr_of_list mlexpr_of_constr lems in
       let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      <:expr< Tacexpr.TacAuto $n$ $l$ >>
-(*
-  | Tacexpr.TacTrivial l ->
+      <:expr< Tacexpr.TacAuto $n$ $lems$ $l$ >>
+  | Tacexpr.TacTrivial (lems,l) ->
       let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      <:expr< Tacexpr.TacTrivial $l$ >>
-*)
+      let lems = mlexpr_of_list mlexpr_of_constr lems in
+      <:expr< Tacexpr.TacTrivial $lems$ $l$ >>
 
 (*
   | Tacexpr.TacExtend (s,l) ->
@@ -492,8 +412,10 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <: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.TacId l -> 
+      <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >>
+  | Tacexpr.TacFail (n,l) ->
+      <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >>
 (*
   | Tacexpr.TacInfo t -> TacInfo (loc,f t)
 
@@ -507,12 +429,14 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
 	  (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) ->
+  | Tacexpr.TacMatch (lz,t,l) ->
       <:expr< Tacexpr.TacMatch
+        $mlexpr_of_bool lz$
         $mlexpr_of_tactic t$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
-  | Tacexpr.TacMatchContext (lr,l) ->
+  | Tacexpr.TacMatchContext (lz,lr,l) ->
       <:expr< Tacexpr.TacMatchContext 
+        $mlexpr_of_bool lz$
         $mlexpr_of_bool lr$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
 (*
@@ -539,14 +463,6 @@ and mlexpr_of_tactic_arg = function
       <: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
@@ -566,6 +482,4 @@ let ftac e =
 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
index b3f5393c..07b23972 100644
--- a/parsing/q_util.ml4
+++ b/parsing/q_util.ml4
@@ -6,7 +6,7 @@
 (*         *       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 $ *)
+(* $Id: q_util.ml4 7732 2005-12-26 13:51:24Z herbelin $ *)
 
 (* This file defines standard combinators to build ml expressions *)
 
@@ -66,3 +66,39 @@ let mlexpr_of_string s = <:expr< $str:s$ >>
 let mlexpr_of_option f = function
   | None -> <:expr< None >>
   | Some e -> <:expr< Some $f e$ >>
+
+open Vernacexpr
+open Pcoq
+open Genarg
+
+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 s = if s = "hyp" then "var" else s in
+    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$) >>
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
index a2c22bc3..d31b217c 100644
--- a/parsing/q_util.mli
+++ b/parsing/q_util.mli
@@ -6,7 +6,7 @@
 (*         *       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*)
+(*i $Id: q_util.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
 
 val patt_of_expr : MLast.expr -> MLast.patt
 
@@ -28,3 +28,4 @@ val mlexpr_of_string : string -> MLast.expr
 
 val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
 
+val interp_entry_name : Util.loc -> string -> Pcoq.entry_type * MLast.expr
diff --git a/parsing/search.ml b/parsing/search.ml
index a3d6e000..995aa953 100644
--- a/parsing/search.ml
+++ b/parsing/search.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: search.ml,v 1.30.2.1 2004/07/16 19:30:41 herbelin Exp $ *)
+(* $Id: search.ml 7837 2006-01-11 09:47:32Z herbelin $ *)
 
 open Pp
 open Util
@@ -17,7 +17,6 @@ open Rawterm
 open Declarations
 open Libobject
 open Declare
-open Coqast
 open Environ
 open Pattern
 open Matching
@@ -34,27 +33,26 @@ open Nametab
 
 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))
+    fn (ConstructRef (indsp,i)) env (Inductiveops.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
+  | 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)
+	     || head_const typ = constr_of_global (out_some refopt)
 	   then
 	     fn (VarRef idc) env typ
 	 with Not_found -> (* we are in a section *) ())
@@ -62,7 +60,7 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
 	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)
+	  || head_const typ = constr_of_global (out_some refopt)
 	then
 	  fn (ConstRef kn) env typ
     | "INDUCTIVE" -> 
@@ -80,7 +78,7 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
     | _ -> ()
   in 
   try 
-    Declaremods.iter_all_segments false crible_rec
+    Declaremods.iter_all_segments crible_rec
   with Not_found -> 
     ()
 
@@ -104,7 +102,7 @@ let constr_to_section_path c = match kind_of_term c with
 let xor a b = (a or b) & (not (a & b))
 
 let plain_display ref a c =
-  let pc = prterm_env a c in
+  let pc = pr_lconstr_env a c in
   let pr = pr_global ref in
   msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ())
 
@@ -210,7 +208,7 @@ type glob_search_about_item =
   | GlobSearchString of string
 
 let search_about_item (itemref,typ) = function
-  | GlobSearchRef ref -> Termops.occur_term (constr_of_reference ref) typ
+  | GlobSearchRef ref -> Termops.occur_term (constr_of_global ref) typ
   | GlobSearchString s -> string_string_contains (name_of_reference itemref) s
 
 let raw_search_about filter_modules display_function l =
diff --git a/parsing/search.mli b/parsing/search.mli
index 62ba865d..8ee708bc 100644
--- a/parsing/search.mli
+++ b/parsing/search.mli
@@ -6,7 +6,7 @@
 (*         *       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*)
+(*i $Id: search.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 open Pp
 open Names
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
index bbacd013..48a124a7 100644
--- a/parsing/tacextend.ml4
+++ b/parsing/tacextend.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacextend.ml4,v 1.10.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+(* $Id: tacextend.ml4 7732 2005-12-26 13:51:24Z herbelin $ *)
 
 open Genarg
 open Q_util
@@ -36,6 +36,8 @@ let rec make_when loc = function
       <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
   | _::l -> make_when loc l
 
+let is_tactic_arg = function TacticArgType _ -> true | _ -> false
+
 let rec make_let e = function
   | [] -> e
   | TacNonTerm(loc,t,_,Some p)::l ->
@@ -45,13 +47,13 @@ let rec make_let e = function
       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
+        if is_tactic_arg t 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 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
@@ -62,7 +64,7 @@ let rec extract_signature = function
   | _::l -> extract_signature l
 
 let check_unicity s l =
-  let l' = List.map (fun (_,l,_) -> extract_signature l) l in
+  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"^
@@ -82,7 +84,7 @@ let rec make_args = function
 
 let rec make_eval_tactic e = function
   | [] -> e
-  | TacNonTerm(loc,TacticArgType,_,Some p)::l ->
+  | 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
@@ -106,11 +108,8 @@ 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))
+  mlexpr_of_list (fun (a,b) -> mlexpr_of_list mlexpr_of_grammar_production a)
 
 let rec make_tags loc = function
   | [] -> <:expr< [] >>
@@ -121,44 +120,13 @@ let rec make_tags loc = function
       <:expr< [ $t$ :: $l$ ] >>
   | _::l -> make_tags loc l
 
-let make_one_printing_rule (s,pt,e) =
+let make_one_printing_rule se (pt,e) =
+  let level = mlexpr_of_int 0 in (* only level 0 supported here *)
   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$)) >>
+  <:expr< ($se$, $make_tags loc pt$, ($level$, $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 make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
 
 let rec contains_epsilon = function
   | List0ArgType _ -> true
@@ -167,89 +135,50 @@ let rec contains_epsilon = function
   | 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 is_atomic = function
+  | TacTerm s :: l when 
+      List.for_all (function
+          TacTerm _ -> false
+	| TacNonTerm(_,t,_,_) -> contains_epsilon t) l
+	-> [s]
+  | _ -> []
 
 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 se = mlexpr_of_string s in
+  let pp = make_printing_rule se cl in
   let gl = mlexpr_of_clause cl in
-  let hide_tac (_,p,e) =
+  let hide_tac (p,e) =
     (* reste a definir les fonctions cachees avec des noms frais *)
-    let stac = "h_"^s' in
+    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$
+          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 hidden = if List.length cl = 1 then List.map hide_tac cl else [] in
   let atomic_tactics =
-    mlexpr_of_list (fun (s,_,_) -> mlexpr_of_string s)
-      (List.filter (fun (_,al,_) -> is_atomic al) cl') in
+    mlexpr_of_list mlexpr_of_string
+      (List.flatten (List.map (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
+        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$;
+      Egrammar.extend_tactic_grammar $se$ $gl$;
+      List.iter Pptactic.declare_extra_tactic_pprule $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
@@ -258,24 +187,23 @@ EXTEND
     [ [ "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 ] ]
+         declare_tactic 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)
+    [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]"
+        -> 
+	  if match List.hd l with TacNonTerm _ -> true | _ -> false then
+	    (* En attendant la syntaxe de tacticielles *)
+	    failwith "Tactic syntax must start with an identifier";
+	  (l,e)
     ] ]
   ;
   tacargs:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name loc e in
+        let t, g = Q_util.interp_entry_name loc e in
         TacNonTerm (loc, t, g, Some s)
       | s = STRING ->
+	if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal");
         TacTerm s
     ] ]
   ;
diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml
new file mode 100644
index 00000000..3584e375
--- /dev/null
+++ b/parsing/tactic_printer.ml
@@ -0,0 +1,141 @@
+(************************************************************************)
+(*  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: tactic_printer.ml 7837 2006-01-11 09:47:32Z herbelin $ *)
+
+open Pp
+open Util
+open Sign
+open Evd
+open Tacexpr
+open Proof_type
+open Proof_trees
+open Logic
+open Printer
+
+let pr_tactic = function
+  | TacArg (Tacexp t) ->
+      (*top tactic from tacinterp*)
+      Pptactic.pr_glob_tactic (Global.env()) t
+  | t -> 
+      Pptactic.pr_tactic (Global.env()) t
+
+let pr_rule = function
+  | Prim r -> hov 0 (pr_prim_rule r)
+  | Tactic (texp,_) -> hov 0 (pr_tactic texp)
+  | Change_evars ->
+      (* This is internal tactic and cannot be replayed at user-level.
+         Function pr_rule_dot below is used when we want to hide
+         Change_evars *)
+      str "Evar change"
+
+(* Does not print change of evars *)
+let pr_rule_dot = function 
+  | Change_evars -> mt ()
+  | r -> pr_rule r ++ str"."
+
+exception Different
+
+(* We remove from the var context of env what is already in osign *)
+let thin_sign osign sign =
+  Sign.fold_named_context
+    (fun (id,c,ty as d) sign ->
+       try 
+	 if Sign.lookup_named id osign = (id,c,ty) then sign
+	 else raise Different
+       with Not_found | Different -> Environ.push_named_context_val d sign)
+    sign ~init:Environ.empty_named_context_val
+
+let rec print_proof sigma osign pf =
+  let {evar_hyps=hyps; evar_concl=cl; 
+       evar_body=body} = pf.goal in
+  let hyps = Environ.named_context_of_val hyps in
+  let hyps' = thin_sign osign hyps in
+  match pf.ref with
+    | None -> 
+	hov 0 (pr_goal {evar_hyps=hyps'; evar_concl=cl; evar_body=body})
+    | Some(r,spfl) ->
+    	hov 0 
+	  (hov 0 (pr_goal {evar_hyps=hyps'; evar_concl=cl; evar_body=body}) ++
+	   spc () ++ str" BY " ++
+	   hov 0 (pr_rule r) ++ fnl () ++
+	   str"  " ++
+	   hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl)
+)
+	  
+let pr_change gl = 
+  str"Change " ++
+  pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"."
+
+let rec print_script nochange sigma osign pf =
+  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
+  let sign = Environ.named_context_of_val sign in
+  match pf.ref with
+    | None ->
+        (if nochange then 
+	  (str"<Your Tactic Text here>") 
+	else 
+	  pr_change pf.goal)
+	++ fnl ()
+    | Some(r,spfl) ->
+        ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
+           pr_rule_dot r ++ fnl () ++
+           prlist_with_sep pr_fnl
+             (print_script nochange sigma sign) spfl)
+
+(* printed by Show Script command *)
+let print_treescript nochange sigma _osign pf =
+  let rec aux top pf =
+    match pf.ref with
+    | None ->
+        if nochange then 
+	  (str"<Your Tactic Text here>") 
+	else 
+	  (pr_change pf.goal)
+    | Some(r,spfl) ->
+        (if nochange then mt () else (pr_change pf.goal ++ fnl ())) ++
+	pr_rule_dot r ++
+	match spfl with
+	| [] -> mt ()
+	| [spf] -> fnl () ++ (if top then mt () else str "  ") ++ aux top spf
+	| _ -> fnl () ++ str " " ++
+	    hov 0 (prlist_with_sep fnl (aux false) spfl)
+  in hov 0 (aux true pf)
+
+let rec print_info_script sigma osign pf =
+  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
+  match pf.ref with
+    | None -> (mt ())
+    | Some(Change_evars,[spf]) ->
+        print_info_script sigma osign spf
+    | Some(r,spfl) ->
+        (pr_rule r ++ 
+           match spfl with
+             | [pf1] ->
+                 if pf1.ref = None then 
+		   (str "." ++ fnl ())
+                 else 
+		   (str";" ++ brk(1,3) ++
+		      print_info_script sigma 
+		      (Environ.named_context_of_val sign) pf1)
+             | _ -> (str"." ++ fnl () ++
+                       prlist_with_sep pr_fnl
+                         (print_info_script sigma 
+			    (Environ.named_context_of_val sign)) spfl))
+
+let format_print_info_script sigma osign pf = 
+  hov 0 (print_info_script sigma osign pf)
+    
+let print_subscript sigma sign pf = 
+  if is_tactic_proof pf then 
+    format_print_info_script sigma sign (subproof_of_proof pf)
+  else 
+    format_print_info_script sigma sign pf
+
+let _ = Refiner.set_info_printer print_subscript
+
diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli
new file mode 100644
index 00000000..db5dd794
--- /dev/null
+++ b/parsing/tactic_printer.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tactic_printer.mli 6113 2004-09-17 20:28:19Z barras $ i*)
+
+(*i*)
+open Pp
+open Sign
+open Evd
+open Tacexpr
+open Proof_type
+(*i*)
+
+(* These are the entry points for tactics, proof trees, ... *)
+
+val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds
+val pr_rule     : rule -> std_ppcmds
+val pr_tactic   : tactic_expr -> std_ppcmds
+val print_script :
+  bool -> evar_map -> named_context -> proof_tree -> std_ppcmds
+val print_treescript :
+  bool -> evar_map -> named_context -> proof_tree -> std_ppcmds
diff --git a/parsing/termast.ml b/parsing/termast.ml
deleted file mode 100644
index 47e45d42..00000000
--- a/parsing/termast.ml
+++ /dev/null
@@ -1,503 +0,0 @@
-(************************************************************************)
-(*  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
deleted file mode 100644
index c66e8f0f..00000000
--- a/parsing/termast.mli
+++ /dev/null
@@ -1,55 +0,0 @@
-(************************************************************************)
-(*  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
index bdc1ea66..af0d6781 100644
--- a/parsing/vernacextend.ml4
+++ b/parsing/vernacextend.ml4
@@ -6,12 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernacextend.ml4,v 1.5.2.2 2004/07/16 19:30:42 herbelin Exp $ *)
+(* $Id: vernacextend.ml4 7732 2005-12-26 13:51:24Z herbelin $ *)
 
 open Genarg
 open Q_util
 open Q_coqast
-open Ast
 open Argextend
 
 let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
@@ -81,11 +80,8 @@ let mlexpr_of_grammar_production = function
 
 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)))
+    (fun (a,b,c) -> 
+      mlexpr_of_list mlexpr_of_grammar_production (VernacTerm a::b))
 
 let declare_command loc s cl =
   let gl = mlexpr_of_clause cl in
@@ -99,40 +95,6 @@ let declare_command loc s cl =
     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
@@ -152,7 +114,7 @@ EXTEND
   ;
   args:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name loc e in
+        let t, g = Q_util.interp_entry_name loc e in
         VernacNonTerm (loc, t, g, Some s)
       | s = STRING ->
         VernacTerm s