Remplacement du tableau du nombre d'args utiles pour la réduction des Cases par le nombre d'args inutiles + vérification dans le noyau

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

10 files changed, 41 insertions, 34 deletions

diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 0000b26a18..c34ac21c0a 100644
--- a/contrib/extraction/extraction.ml
+++ b/contrib/extraction/extraction.ml
@@ -534,8 +534,8 @@ and extract_term_info_with_type env ctx c t =
       	 extract_app env ctx f a 
      | IsMutConstruct (cp,_) ->
 	 abstract_constructor cp
-     | IsMutCase ((ni,(ip,_,_,_,_)),_,c,br) ->
-	 extract_case env ctx ni ip c br
+     | IsMutCase ((_,(ip,_,_,_,_)),_,c,br) ->
+	 extract_case env ctx ip c br
      | IsFix ((_,i),recd) -> 
 	 extract_fix env ctx i recd
      | IsCoFix (i,recd) -> 
@@ -584,7 +584,9 @@ and abstract_constructor cp  =
 
 (* Extraction of a case *)
 
-and extract_case env ctx ni ip c br = 
+and extract_case env ctx ip c br = 
+  let mis = Global.lookup_mind_specif (ip,[||]) in
+  let ni = Array.map List.length (mis_recarg mis) in
   (* [ni]: number of arguments without parameters in each branch *)
   (* [br]: bodies of each branch (in functional form) *)
   let extract_branch j b = 	  
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 81c1b7bcca..3d21e86ae2 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -967,8 +967,8 @@ let rec knr info m stk =
         | None -> (set_norm m; (m,stk)))
   | FConstruct((sp,c),args) when can_red info stk fIOTA ->
       (match strip_update_shift_app m stk with
-          (depth, args, Zcase((cn,_),_,br)::s) ->
-            let npar = stack_args_size args - cn.(c-1) in
+          (depth, args, Zcase(((*cn*) npar,_),_,br)::s) ->
+(*            let npar = stack_args_size args - cn.(c-1) in*)
             assert (npar>=0);
             let rargs = drop_parameters depth npar args in
             kni info br.(c-1) (rargs@s)
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 0a023fb9c1..7a06a78968 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -37,6 +37,11 @@ type recipe = {
   d_abstract : identifier list;
   d_modlist : work_list }
 
+let rec modif_length = function
+  | ABSTRACT :: l -> 1 + modif_length l
+  | ERASE :: l -> modif_length l
+  | [] -> 0
+
 let interp_modif absfun mkfun (sp,modif) cl = 
   let rec interprec = function
     | ([], cl) -> mkfun (sp, Array.of_list cl)
@@ -64,8 +69,9 @@ let modify_opers replfun absfun (constl,indl,cstrl) =
       | OpMutCase (n,(spi,a,b,c,d) as oper) ->
 	  (try
 	     match List.assoc spi indl with
-	       | DO_ABSTRACT (spi',_) ->
-		   gather_constr (OpMutCase (n,(spi',a,b,c,d)),cl')
+	       | DO_ABSTRACT (spi',modif) ->
+		   let n' = modif_length modif + n in
+		   gather_constr (OpMutCase (n',(spi',a,b,c,d)),cl')
 	       | _ -> raise Not_found
 	   with
 	     | Not_found -> gather_constr (op,cl'))
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 9a8ed21d80..b528225145 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -187,11 +187,11 @@ let mis_is_recursive mis =
 
 (* Annotation for cases *)
 let make_case_info mis style pats_source =
-  let constr_lengths = Array.map List.length (mis_recarg mis) in
+(*  let constr_lengths = Array.map List.length (mis_recarg mis) in*)
   let indsp = (mis.mis_sp,mis.mis_tyi) in
   let print_info =
     (indsp,mis_consnames mis,mis.mis_mip.mind_nrealargs,style,pats_source) in
-  (constr_lengths,print_info)
+  ((*constr_lengths*) mis_nparams mis,print_info)
 
 let make_default_case_info mis =
   make_case_info mis None (Array.init (mis_nconstr mis) (fun _ -> RegularPat))
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 3447a5741f..4832cdd8a4 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -202,8 +202,8 @@ let contract_cofix (bodynum,(types,names,bodies as typedbodies)) =
 let reduce_mind_case mia =
   match kind_of_term mia.mconstr with
     | IsMutConstruct (ind_sp,i as cstr_sp, args) ->
-	let ncargs = (fst mia.mci).(i-1) in
-	let real_cargs = list_lastn ncargs mia.mcargs in
+(*	let ncargs = (fst mia.mci).(i-1) in*)
+	let real_cargs = snd (list_chop (fst mia.mci) mia.mcargs) in
         applist (mia.mlf.(i-1),real_cargs)
     | IsCoFix cofix ->
 	let cofix_def = contract_cofix cofix in
diff --git a/kernel/term.ml b/kernel/term.ml
index 075b3dbad5..c6022b999c 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -26,7 +26,7 @@ type case_style = PrintLet | PrintIf | PrintCases
 type case_printing =
     inductive_path * identifier array * int
     * case_style option * pattern_source array
-type case_info = int array * case_printing
+type case_info = int * case_printing
 
 (* Sorts. *)
 
diff --git a/kernel/term.mli b/kernel/term.mli
index 2d65491c44..e81791426f 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -36,7 +36,7 @@ type case_printing =
     inductive_path * identifier array * int
     * case_style option * pattern_source array
 (* the integer is the number of real args, needed for reduction *)
-type case_info = int array * case_printing
+type case_info = int * case_printing
 
 (* Concrete type for making pattern-matching. *)
 module Polymorph :
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 3eef05bf0a..10d0bb611a 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -369,13 +369,16 @@ let check_branches_message env sigma cj (explft,lft) =
   done;
   !univ)
 
-let judge_of_case env sigma ci pj cj lfj =
+let nparams_of (IndType (IndFamily (mis,_),_)) = mis_nparams mis 
+
+let judge_of_case env sigma (np,_ as ci) pj cj lfj =
   let lft = Array.map (fun j -> body_of_type j.uj_type) lfj in
   let indspec =
     try find_rectype env sigma (body_of_type cj.uj_type)
     with Induc -> error_case_not_inductive CCI env cj in
-  let (bty,rslty,univ) =
-    type_case_branches env sigma indspec pj cj.uj_val in
+  if np <> nparams_of indspec then 
+    anomaly "judge_of_case: wrong parameters number";
+  let (bty,rslty,univ) = type_case_branches env sigma indspec pj cj.uj_val in
   let kind = mysort_of_arity env sigma (body_of_type pj.uj_type) in
   let univ' = check_branches_message env sigma cj (bty,lft) in
   ({ uj_val  = mkMutCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, Array.map j_val lfj);
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index e29fab4e26..6f91ac5b8d 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -317,8 +317,11 @@ and cbv_stack_term info stack env t =
        (use red_under because we know there is a Case) *)
     | (CONSTR(n,sp,_,_), APP(args,CASE(_,br,(arity,_),env,stk)))
             when red_under (info_flags info) fIOTA ->
+(*
 	let ncargs = arity.(n-1) in
 	let real_args = list_lastn ncargs args in
+*)
+	let real_args = snd (list_chop arity args) in
         cbv_stack_term info (stack_app real_args stk) env br.(n-1)
          
     (* constructor of arity 0 in a Case -> IOTA ( "   " )*)
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 9ce397dd44..f2ffbbaf3b 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -112,16 +112,15 @@ let encode_inductive id =
   let constr_lengths = Array.map List.length (mis_recarg mis) in
   (indsp,constr_lengths)
 
+let constr_nargs indsp =
+  let mis = Global.lookup_mind_specif (indsp,[||] (* ?? *)) in
+  Array.map List.length (mis_recarg mis)
+
 let sp_of_spi (refsp,tyi) =
   let mip = Declarations.mind_nth_type_packet (Global.lookup_mind refsp) tyi in
   let (pa,_,k) = repr_path refsp in 
   make_path pa mip.Declarations.mind_typename k
 
-(*
-  let (_,mip) = mind_specif_of_mind_light spi in
-  let (pa,_,k) = repr_path sp in 
-  make_path pa (mip.mind_typename) k
-*)
 (* Parameterization of the translation from constr to ast      *)
 
 (* Tables for Cases printing under a "if" form, a "let" form,  *)
@@ -129,20 +128,11 @@ let sp_of_spi (refsp,tyi) =
 let isomorphic_to_bool lc =
   Array.length lc = 2 & lc.(0) = 0 & lc.(1) = 0
 
-(*
-let isomorphic_to_bool lc =
-  let lcparams = Array.map get_params lc in
-  Array.length lcparams = 2 & lcparams.(0) = [] & lcparams.(1) = []
-*)
-
-let isomorphic_to_tuple lc = (Array.length lc = 1)
-(*
 let isomorphic_to_tuple lc = (Array.length lc = 1)
-*)
+
 module PrintingCasesMake =
   functor (Test : sig 
      val test : int array -> bool
-(*     val test : constr array -> bool*)
      val error_message : string
      val member_message : identifier -> bool -> string
      val field : string
@@ -195,8 +185,10 @@ module PrintingCasesLet =
 module PrintingIf  = Goptions.MakeIdentTable(PrintingCasesIf)
 module PrintingLet = Goptions.MakeIdentTable(PrintingCasesLet)
 
-let force_let (lc,(indsp,_,_,_,_)) = PrintingLet.active (indsp,lc)
-let force_if (lc,(indsp,_,_,_,_)) = PrintingIf.active (indsp,lc)
+let force_let (_,(indsp,_,_,_,_)) = 
+  let lc = constr_nargs indsp in PrintingLet.active (indsp,lc)
+let force_if (_,(indsp,_,_,_,_)) =
+  let lc = constr_nargs indsp in PrintingIf.active (indsp,lc)
 
 (* Options for printing or not wildcard and synthetisable types *)
 
@@ -311,7 +303,8 @@ let rec detype avoid env t =
     | IsMutCase (annot,p,c,bl) ->
 	let synth_type = synthetize_type () in
 	let tomatch = detype avoid env c in
-	let (consnargsl,(indsp,considl,k,style,tags)) = annot in
+	let (_,(indsp,considl,k,style,tags)) = annot in
+	let consnargsl = constr_nargs indsp in
 	let pred = 
 	  if synth_type & computable p k & considl <> [||] then
 	    None