extraction naive de fix et case

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

4 files changed, 137 insertions, 18 deletions

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.