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

7 files changed, 22 insertions, 13 deletions

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);