extraction naive de fix et case

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@1471 85f007b7-540e-0410-9357-904b9bb8a0f7

7 files changed, 195 insertions, 62 deletions

diff --git a/.depend b/.depend
index 0eab892b30..cb111efa70 100644
--- a/.depend
+++ b/.depend
@@ -29,6 +29,8 @@ kernel/typeops.cmi: kernel/environ.cmi kernel/evd.cmi kernel/inductive.cmi \
     kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi 
 kernel/univ.cmi: kernel/names.cmi lib/pp.cmi 
 lib/pp.cmi: lib/pp_control.cmi 
+lib/system.cmi: lib/pp.cmi 
+lib/util.cmi: lib/pp.cmi 
 library/declare.cmi: kernel/cooking.cmi kernel/declarations.cmi \
     kernel/environ.cmi kernel/evd.cmi kernel/inductive.cmi \
     library/libobject.cmi kernel/names.cmi library/nametab.cmi \
@@ -49,8 +51,6 @@ library/library.cmi: library/lib.cmi library/libobject.cmi kernel/names.cmi \
 library/nametab.cmi: library/libobject.cmi kernel/names.cmi lib/pp.cmi \
     kernel/term.cmi lib/util.cmi 
 library/summary.cmi: kernel/names.cmi 
-lib/system.cmi: lib/pp.cmi 
-lib/util.cmi: lib/pp.cmi 
 parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \
     parsing/pcoq.cmi lib/pp.cmi 
 parsing/astterm.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \
@@ -199,20 +199,21 @@ toplevel/recordobj.cmi: kernel/term.cmi
 toplevel/searchisos.cmi: library/libobject.cmi kernel/names.cmi \
     kernel/term.cmi 
 toplevel/toplevel.cmi: parsing/pcoq.cmi lib/pp.cmi 
+toplevel/vernac.cmi: parsing/coqast.cmi parsing/pcoq.cmi 
 toplevel/vernacentries.cmi: parsing/coqast.cmi kernel/environ.cmi \
     kernel/names.cmi library/nametab.cmi proofs/proof_type.cmi \
     kernel/term.cmi toplevel/vernacinterp.cmi 
 toplevel/vernacinterp.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \
     library/nametab.cmi proofs/proof_type.cmi 
-toplevel/vernac.cmi: parsing/coqast.cmi parsing/pcoq.cmi 
 contrib/extraction/close_env.cmi: kernel/names.cmi kernel/term.cmi 
-contrib/extraction/extraction.cmi: contrib/extraction/miniml.cmi \
-    kernel/names.cmi kernel/term.cmi 
+contrib/extraction/extraction.cmi: kernel/environ.cmi \
+    contrib/extraction/miniml.cmi kernel/names.cmi kernel/term.cmi 
 contrib/extraction/genpp.cmi: contrib/extraction/extraction.cmi \
     contrib/extraction/miniml.cmi kernel/names.cmi lib/pp.cmi \
     toplevel/vernacinterp.cmi 
 contrib/extraction/miniml.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi 
 contrib/extraction/mlimport.cmi: kernel/names.cmi kernel/term.cmi 
+contrib/extraction/mlutil.cmi: contrib/extraction/miniml.cmi 
 contrib/extraction/ocaml.cmi: contrib/extraction/miniml.cmi 
 contrib/xml/xmlcommand.cmi: kernel/names.cmi library/nametab.cmi 
 config/coq_config.cmo: config/coq_config.cmi 
@@ -335,22 +336,30 @@ lib/edit.cmo: lib/bstack.cmi lib/pp.cmi lib/util.cmi lib/edit.cmi
 lib/edit.cmx: lib/bstack.cmx lib/pp.cmx lib/util.cmx lib/edit.cmi 
 lib/explore.cmo: lib/explore.cmi 
 lib/explore.cmx: lib/explore.cmi 
-lib/gmapl.cmo: lib/gmap.cmi lib/util.cmi lib/gmapl.cmi 
-lib/gmapl.cmx: lib/gmap.cmx lib/util.cmx lib/gmapl.cmi 
 lib/gmap.cmo: lib/gmap.cmi 
 lib/gmap.cmx: lib/gmap.cmi 
+lib/gmapl.cmo: lib/gmap.cmi lib/util.cmi lib/gmapl.cmi 
+lib/gmapl.cmx: lib/gmap.cmx lib/util.cmx lib/gmapl.cmi 
 lib/gset.cmo: lib/gset.cmi 
 lib/gset.cmx: lib/gset.cmi 
 lib/hashcons.cmo: lib/hashcons.cmi 
 lib/hashcons.cmx: lib/hashcons.cmi 
 lib/options.cmo: lib/util.cmi lib/options.cmi 
 lib/options.cmx: lib/util.cmx lib/options.cmi 
-lib/pp_control.cmo: lib/pp_control.cmi 
-lib/pp_control.cmx: lib/pp_control.cmi 
 lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi 
 lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi 
+lib/pp_control.cmo: lib/pp_control.cmi 
+lib/pp_control.cmx: lib/pp_control.cmi 
 lib/profile.cmo: lib/profile.cmi 
 lib/profile.cmx: lib/profile.cmi 
+lib/stamps.cmo: lib/stamps.cmi 
+lib/stamps.cmx: lib/stamps.cmi 
+lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi 
+lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi 
+lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi 
+lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi 
+lib/util.cmo: lib/pp.cmi lib/util.cmi 
+lib/util.cmx: lib/pp.cmx lib/util.cmi 
 library/declare.cmo: kernel/cooking.cmi kernel/declarations.cmi \
     kernel/environ.cmi kernel/evd.cmi library/global.cmi library/impargs.cmi \
     library/indrec.cmi kernel/inductive.cmi library/lib.cmi \
@@ -425,14 +434,6 @@ library/summary.cmo: lib/dyn.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \
     library/summary.cmi 
 library/summary.cmx: lib/dyn.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \
     library/summary.cmi 
-lib/stamps.cmo: lib/stamps.cmi 
-lib/stamps.cmx: lib/stamps.cmi 
-lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi 
-lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi 
-lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi 
-lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi 
-lib/util.cmo: lib/pp.cmi lib/util.cmi 
-lib/util.cmx: lib/pp.cmx lib/util.cmi 
 parsing/ast.cmo: parsing/coqast.cmi lib/dyn.cmi lib/hashcons.cmi \
     kernel/names.cmi parsing/pcoq.cmi lib/pp.cmi lib/util.cmi parsing/ast.cmi 
 parsing/ast.cmx: parsing/coqast.cmx lib/dyn.cmx lib/hashcons.cmx \
@@ -526,9 +527,9 @@ parsing/g_zsyntax.cmx: parsing/ast.cmx parsing/astterm.cmx parsing/coqast.cmx \
 parsing/lexer.cmo: parsing/lexer.cmi 
 parsing/lexer.cmx: parsing/lexer.cmi 
 parsing/pcoq.cmo: parsing/coqast.cmi parsing/lexer.cmi lib/pp.cmi \
-    lib/util.cmi parsing/pcoq.cmi 
+    lib/util.cmi toplevel/vernac.cmi parsing/pcoq.cmi 
 parsing/pcoq.cmx: parsing/coqast.cmx parsing/lexer.cmx lib/pp.cmx \
-    lib/util.cmx parsing/pcoq.cmi 
+    lib/util.cmx toplevel/vernac.cmx parsing/pcoq.cmi 
 parsing/pretty.cmo: pretyping/classops.cmi kernel/declarations.cmi \
     library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \
     library/impargs.cmi kernel/inductive.cmi kernel/instantiate.cmi \
@@ -894,15 +895,15 @@ tactics/dn.cmx: lib/tlm.cmx tactics/dn.cmi
 tactics/eauto.cmo: tactics/auto.cmi proofs/clenv.cmi kernel/evd.cmi \
     lib/explore.cmi kernel/instantiate.cmi proofs/logic.cmi kernel/names.cmi \
     pretyping/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \
-    proofs/proof_type.cmi kernel/reduction.cmi kernel/sign.cmi \
-    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
-    kernel/term.cmi lib/util.cmi 
+    proofs/proof_type.cmi kernel/reduction.cmi parsing/search.cmi \
+    kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi lib/util.cmi 
 tactics/eauto.cmx: tactics/auto.cmx proofs/clenv.cmx kernel/evd.cmx \
     lib/explore.cmx kernel/instantiate.cmx proofs/logic.cmx kernel/names.cmx \
     pretyping/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \
-    proofs/proof_type.cmx kernel/reduction.cmx kernel/sign.cmx \
-    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
-    kernel/term.cmx lib/util.cmx 
+    proofs/proof_type.cmx kernel/reduction.cmx parsing/search.cmx \
+    kernel/sign.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx lib/util.cmx 
 tactics/elim.cmo: proofs/clenv.cmi tactics/hiddentac.cmi \
     tactics/hipattern.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \
     proofs/proof_type.cmi kernel/reduction.cmi proofs/tacmach.cmi \
@@ -1061,10 +1062,10 @@ tactics/wcclausenv.cmx: proofs/clenv.cmx kernel/environ.cmx kernel/evd.cmx \
     library/global.cmx proofs/logic.cmx kernel/names.cmx lib/pp.cmx \
     proofs/proof_trees.cmx kernel/reduction.cmx kernel/sign.cmx \
     proofs/tacmach.cmx kernel/term.cmx lib/util.cmx tactics/wcclausenv.cmi 
-tools/coqdep_lexer.cmo: config/coq_config.cmi 
-tools/coqdep_lexer.cmx: config/coq_config.cmx 
 tools/coqdep.cmo: config/coq_config.cmi tools/coqdep_lexer.cmo 
 tools/coqdep.cmx: config/coq_config.cmx tools/coqdep_lexer.cmx 
+tools/coqdep_lexer.cmo: config/coq_config.cmi 
+tools/coqdep_lexer.cmx: config/coq_config.cmx 
 tools/gallina.cmo: tools/gallina_lexer.cmo 
 tools/gallina.cmx: tools/gallina_lexer.cmx 
 toplevel/class.cmo: pretyping/classops.cmi kernel/declarations.cmi \
@@ -1225,6 +1226,14 @@ toplevel/toplevel.cmx: parsing/ast.cmx toplevel/errors.cmx library/lib.cmx \
     toplevel/vernac.cmx toplevel/vernacinterp.cmx toplevel/toplevel.cmi 
 toplevel/usage.cmo: config/coq_config.cmi toplevel/usage.cmi 
 toplevel/usage.cmx: config/coq_config.cmx toplevel/usage.cmi 
+toplevel/vernac.cmo: parsing/ast.cmi parsing/coqast.cmi \
+    toplevel/discharge.cmi library/library.cmi lib/options.cmi \
+    parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi library/states.cmi \
+    lib/system.cmi lib/util.cmi toplevel/vernacinterp.cmi toplevel/vernac.cmi 
+toplevel/vernac.cmx: parsing/ast.cmx parsing/coqast.cmx \
+    toplevel/discharge.cmx library/library.cmx lib/options.cmx \
+    parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx library/states.cmx \
+    lib/system.cmx lib/util.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi 
 toplevel/vernacentries.cmo: parsing/ast.cmi parsing/astterm.cmi \
     toplevel/class.cmi pretyping/classops.cmi toplevel/command.cmi \
     parsing/coqast.cmi kernel/declarations.cmi library/declare.cmi \
@@ -1269,19 +1278,11 @@ toplevel/vernacinterp.cmx: parsing/ast.cmx parsing/astterm.cmx \
     kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \
     proofs/proof_type.cmx proofs/tacinterp.cmx lib/util.cmx \
     toplevel/vernacinterp.cmi 
-toplevel/vernac.cmo: parsing/ast.cmi parsing/coqast.cmi \
-    toplevel/discharge.cmi library/library.cmi lib/options.cmi \
-    parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi library/states.cmi \
-    lib/system.cmi lib/util.cmi toplevel/vernacinterp.cmi toplevel/vernac.cmi 
-toplevel/vernac.cmx: parsing/ast.cmx parsing/coqast.cmx \
-    toplevel/discharge.cmx library/library.cmx lib/options.cmx \
-    parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx library/states.cmx \
-    lib/system.cmx lib/util.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi 
 contrib/extraction/close_env.cmo: kernel/names.cmi kernel/term.cmi \
     contrib/extraction/close_env.cmi 
 contrib/extraction/close_env.cmx: kernel/names.cmx kernel/term.cmx \
     contrib/extraction/close_env.cmi 
-contrib/extraction/extraction.cmo: parsing/astterm.cmi \
+contrib/extraction/extraction.cmo: parsing/astterm.cmi kernel/closure.cmi \
     kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \
     library/global.cmi lib/gmap.cmi kernel/inductive.cmi \
     kernel/instantiate.cmi contrib/extraction/miniml.cmi \
@@ -1289,7 +1290,7 @@ contrib/extraction/extraction.cmo: parsing/astterm.cmi \
     contrib/extraction/ocaml.cmi lib/pp.cmi parsing/printer.cmi \
     kernel/reduction.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \
     toplevel/vernacinterp.cmi contrib/extraction/extraction.cmi 
-contrib/extraction/extraction.cmx: parsing/astterm.cmx \
+contrib/extraction/extraction.cmx: parsing/astterm.cmx kernel/closure.cmx \
     kernel/declarations.cmx kernel/environ.cmx kernel/evd.cmx \
     library/global.cmx lib/gmap.cmx kernel/inductive.cmx \
     kernel/instantiate.cmx contrib/extraction/miniml.cmi \
@@ -1319,10 +1320,16 @@ contrib/extraction/mlimport.cmx: library/declare.cmx lib/gmap.cmx \
     library/lib.cmx library/libobject.cmx kernel/names.cmx \
     library/nametab.cmx lib/pp.cmx parsing/printer.cmx library/summary.cmx \
     kernel/term.cmx contrib/extraction/mlimport.cmi 
-contrib/extraction/ocaml.cmo: contrib/extraction/miniml.cmi kernel/names.cmi \
-    lib/pp.cmi kernel/term.cmi lib/util.cmi contrib/extraction/ocaml.cmi 
-contrib/extraction/ocaml.cmx: contrib/extraction/miniml.cmi kernel/names.cmx \
-    lib/pp.cmx kernel/term.cmx lib/util.cmx contrib/extraction/ocaml.cmi 
+contrib/extraction/mlutil.cmo: contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmi 
+contrib/extraction/mlutil.cmx: contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmi 
+contrib/extraction/ocaml.cmo: contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \
+    lib/util.cmi contrib/extraction/ocaml.cmi 
+contrib/extraction/ocaml.cmx: contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \
+    lib/util.cmx contrib/extraction/ocaml.cmi 
 contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \
     kernel/closure.cmi parsing/coqlib.cmi library/declare.cmi \
     kernel/environ.cmi tactics/equality.cmi kernel/evd.cmi library/global.cmi \
@@ -1371,6 +1378,8 @@ contrib/ring/ring.cmx: parsing/astterm.cmx kernel/closure.cmx \
     proofs/tacmach.cmx pretyping/tacred.cmx tactics/tactics.cmx \
     kernel/term.cmx pretyping/typing.cmx lib/util.cmx \
     toplevel/vernacinterp.cmx 
+contrib/xml/xml.cmo: contrib/xml/xml.cmi 
+contrib/xml/xml.cmx: contrib/xml/xml.cmi 
 contrib/xml/xmlcommand.cmo: kernel/declarations.cmi library/declare.cmi \
     kernel/environ.cmi kernel/evd.cmi library/global.cmi library/lib.cmi \
     library/libobject.cmi library/library.cmi kernel/names.cmi \
@@ -1389,8 +1398,6 @@ contrib/xml/xmlentries.cmo: lib/util.cmi toplevel/vernacinterp.cmi \
     contrib/xml/xmlcommand.cmi 
 contrib/xml/xmlentries.cmx: lib/util.cmx toplevel/vernacinterp.cmx \
     contrib/xml/xmlcommand.cmx 
-contrib/xml/xml.cmo: contrib/xml/xml.cmi 
-contrib/xml/xml.cmx: contrib/xml/xml.cmi 
 tactics/tauto.cmo: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_constr.cmo
 parsing/lexer.cmo: 
 parsing/q_coqast.cmo: 
diff --git a/PROBLEMES b/PROBLEMES
index f20e0ec07f..c61b3ba521 100644
--- a/PROBLEMES
+++ b/PROBLEMES
@@ -1,3 +1,10 @@
+- Problème affichage de Cases (alpha-conversion dans les patterns)
+======================================================================
+Inductive t  : Set :=  c : nat->nat->t.
+Definition foo' := [x:t]Cases x of (c y z) => (plus y z) end.  
+Print foo'.
+======================================================================
+
 Des CASTEDCOMMAND s'affiche dans les scripts de preuves.
 
 Probleme d'affichage des scripts de preuve (disparition des THEN)
diff --git a/TODO b/TODO
index d6210ffa8d..4fe357c926 100644
--- a/TODO
+++ b/TODO
@@ -10,7 +10,7 @@ Environnement:
 
 Tactiques:
 
-- Porter EqDecide Correctness (JCF)
+- Porter Correctness (JCF)
 
 Noyau:
 
diff --git a/contrib/extraction/Extraction.v b/contrib/extraction/Extraction.v
index 0f9668756c..5bf303fbb2 100644
--- a/contrib/extraction/Extraction.v
+++ b/contrib/extraction/Extraction.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-Declare ML Module "ocaml.cmo" "extraction.cmo".
+Declare ML Module "mlutil.cmo" "ocaml.cmo" "extraction.cmo".
 
 Grammar vernac vernac : ast :=
   extr_constr [ "Extraction" constrarg($c) "." ] -> [(Extraction $c)].
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 25d481d666..a1c88b7bdc 100644
--- a/contrib/extraction/extraction.ml
+++ b/contrib/extraction/extraction.ml
@@ -201,6 +201,17 @@ let renum_db ctx n =
   in
   renum (n, ctx)
 
+(*s Environment for the bodies of some mutual fixpoints. *)
+
+let rec push_many_rels env ctx = function
+  | (fi,ti) :: l -> 
+      push_many_rels (push_rel (fi,None,ti) env) ((v_of_arity env ti)::ctx) l
+  | [] ->
+      (env, ctx)
+
+let fix_environment env ctx fl tl =
+  push_many_rels env ctx (List.combine fl (Array.to_list tl))
+
 (*s Tables to keep the extraction of inductive types and constructors. *)
 
 type inductive_extraction_result = signature * identifier list
@@ -380,17 +391,50 @@ and extract_term_with_type env ctx c t =
 	    whd_betadeltaiota env Evd.empty tyf 
 	in
 	(match extract_type env tyf with
-	   | Tmltype (_,s,_) -> extract_app env ctx (f,tyf,s) (Array.to_list a) 
+	   | Tmltype (_,s,_) -> 
+	       extract_app env ctx (f,tyf,s) (Array.to_list a) 
 	   | Tarity -> assert false (* Cf. precondition *)
 	   | Tprop -> assert false)
     | IsConst (sp,_) ->
 	Rmlterm (MLglob (ConstRef sp))
     | IsMutConstruct (cp,_) ->
 	Rmlterm (MLglob (ConstructRef cp)) (* TODO eta-expansion *)
-    | IsMutCase _ ->
-	failwith "todo"
-    | IsFix _ ->
-	failwith "todo"
+    | IsMutCase ((ni,(ip,cnames,_,_,_)),p,c,br) ->
+	let extract_branch j b =
+	  let (_,s) = extract_constructor (ip,succ j) in
+	  assert (List.length s = ni.(j));
+	  let (binders,e) = decompose_lam_n ni.(j) b in
+	  let binders = List.rev binders in
+	  let (env',ctx') = push_many_rels env ctx binders in
+	  let e' = match extract_constr env' ctx' e with
+	    | Eprop -> MLprop (* TODO: probably wrong *)
+	    | Emltype _ -> assert false
+	    | Emlterm a -> a
+	  in
+	  let ids = 
+	    List.fold_right 
+	      (fun ((v,_),(n,_)) acc ->
+		 if v = Vdefault then (id_of_name n :: acc) else acc)
+	      (List.combine s binders) []
+	  in
+	  (cnames.(j), ids, e')
+	in
+	let a = match extract_constr env ctx c with
+	  | Emlterm a -> a
+	  | Eprop -> MLprop
+	  | Emltype _ -> assert false
+	in
+	Rmlterm (MLcase (a, Array.mapi extract_branch br))
+    | IsFix ((_,i),(ti,fi,ci)) ->
+	let (env', ctx') = fix_environment env ctx fi ti in
+	let extract_fix_body c = 
+	  match extract_constr env' ctx' c with
+	    | Eprop -> MLprop (* TODO: probably wrong *)
+	    | Emltype _ -> assert false
+	    | Emlterm a -> a
+	in
+	let ei = array_map_to_list extract_fix_body ci in
+	Rmlterm (MLfix (i, true, List.map id_of_name fi, ei))
     | IsLetIn (n, c1, t1, c2) ->
 	let id = id_of_name n in
 	let env' = push_rel (n,Some c1,t1) env in
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
index 83e4b7727f..e990f5c0d6 100644
--- a/contrib/extraction/ocaml.ml
+++ b/contrib/extraction/ocaml.ml
@@ -35,6 +35,13 @@ let pp_tuple f = function
       	    prlist_with_sep (fun () -> [< 'sTR ","; 'sPC >]) f l;
 	    'sTR ")" >]
 
+let pp_boxed_tuple f = function
+  | [] -> [< >]
+  | [x] -> f x
+  | l -> [< 'sTR "(";
+      	    hOV 0 [< prlist_with_sep (fun () -> [< 'sTR ","; 'sPC >]) f l;
+		     'sTR ")" >] >]
+
 let space_if = function true -> [< 'sPC >] | false -> [<>]
 
 (* collect_lambda MLlam(id1,...MLlam(idn,t)...) = [id1;...;idn],t *)
@@ -54,10 +61,13 @@ let rec rename_bvars avoid = function
 
 let abst = function
   | [] -> [< >]
-  | l  -> [< 'sTR"fun " ;
-             prlist_with_sep (fun  ()-> [< 'sTR" " >])
-      	       	       	     (fun id -> [< 'sTR(string_of_id id) >]) l ;
-             'sTR" ->" ; 'sPC >]
+  | l  -> [< 'sTR "fun " ;
+             prlist_with_sep (fun  ()-> [< 'sTR " " >]) pr_id l;
+             'sTR " ->" ; 'sPC >]
+
+let pr_binding = function
+  | [] -> [< >]
+  | l  -> [< 'sTR " "; prlist_with_sep (fun () -> [< 'sTR " " >]) pr_id l >]
 
 (*s The pretty-printing functor. *)
 
@@ -152,10 +162,71 @@ let rec pp_expr par env args =
 	[< open_par true; 'sTR "Obj.magic"; 'sPC; 
 	   pp_expr false env args a; close_par true >]
 
-and pp_pat env pv = failwith "todo"
+and pp_pat env pv = 
+  let pp_one_pat (name,ids,t) =
+    let ids = rename_bvars env ids in
+    let par = match t with
+      | MLlam _  -> true
+      | MLcase _ -> true
+      | _        -> false 
+    in
+    hOV 2 [< 'sTR(string_of_id name) ;
+	     begin match ids with 
+		 [] -> [< >]
+	       | _  -> 
+      		   [< 'sTR " ";
+		      pp_boxed_tuple
+			(fun id -> [< 'sTR(string_of_id id) >]) 
+			(List.rev ids) >]
+	     end ;
+	     'sTR" ->" ; 'sPC ; pp_expr par (ids@env) [] t
+          >]
+  in 
+  [< prvect_with_sep (fun () -> [< 'fNL ; 'sTR"| " >]) pp_one_pat pv >]
 
-and pp_fix par env f args = failwith "todo"
+and pp_fix par env (j,in_p,fid,bl) args =
+  let env' = (List.rev fid) @ env in
+  [< open_par par; 
+     v 0 [< 'sTR"let rec " ;
+	    prlist_with_sep
+      	      (fun () -> [< 'fNL; 'sTR "and " >])
+	      (fun (fi,ti) -> pp_function env' fi ti)
+	      (List.combine fid bl) ;
+	    'fNL ;
+	    if in_p then 
+      	      hOV 2 [< 'sTR "in "; pr_id (List.nth fid j);
+                       if args <> [] then
+			 [< 'sTR " "; prlist_with_sep (fun () -> [<'sTR " ">])
+                              (fun s -> s) args >]
+                       else [< >]
+      		    >]
+	    else 
+	      [< >] >];
+     close_par par >]
 
+and pp_function env f t =
+  let bl,t' = collect_lambda t in
+  let bl = rename_bvars env bl in
+  let is_function pv =
+    let ktl = array_map_to_list (fun (_,l,t0) -> (List.length l,t0)) pv in
+    not (List.exists (fun (k,t0) -> Mlutil.occurs (k+1) t0) ktl)
+  in
+  match t' with 
+    | MLcase(MLrel 1,pv) ->
+	if is_function pv then
+	  [< 'sTR(string_of_id f) ; pr_binding (List.rev (List.tl bl)) ;
+       	     'sTR" = function" ; 'fNL ;
+	     v 0 [< 'sTR"  " ; pp_pat (bl@env) pv >] >]
+	else
+          [< 'sTR(string_of_id f) ; pr_binding (List.rev bl) ; 
+             'sTR" = match " ;
+	     'sTR(string_of_id (List.hd bl)) ; 'sTR" with" ; 'fNL ;
+	     v 0 [< 'sTR"  " ; pp_pat (bl@env) pv >] >]
+	  
+    | _ -> [< 'sTR(string_of_id f) ; pr_binding (List.rev bl) ;
+	      'sTR" =" ; 'fNL ; 'sTR"  " ;
+	      hOV 2 (pp_expr false (bl@env) [] t') >]
+	
 let pp_ast a = hOV 0 (pp_expr false [] [] a)
 
 (*s Pretty-printing of inductive types declaration. *)
diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v
index 95babfb707..5000c9e1e2 100644
--- a/contrib/extraction/test_extraction.v
+++ b/contrib/extraction/test_extraction.v
@@ -66,16 +66,20 @@ Extraction let n=O in let p=(S n) in (S p).
 
 Extraction (x:(X:Type)X->X)(x Type Type).
 
-Inductive tree : Set := node : nat -> forest -> tree
+Inductive tree : Set := 
+   Node : nat -> forest -> tree
 with forest : Set :=
-         |leaf : nat -> forest
-         |cons : tree -> forest -> forest .
+ | Leaf : nat -> forest
+ | Cons : tree -> forest -> forest .
 
 Extraction tree.
 
 Fixpoint tree_size [t:tree] : nat :=
-         Cases t of (node a f) => (S (forest_size f)) end
+         Cases t of (Node a f) => (S (forest_size f)) end
 with forest_size [f:forest] : nat :=
-         Cases f of (leaf b) => (S O)
-         | (cons t f') => (plus (tree_size t) (forest_size f'))
+         Cases f of 
+	 | (Leaf b) => (S O)
+         | (Cons t f') => (plus (tree_size t) (forest_size f'))
          end.
+
+Extraction tree_size.