Suite 11187 et 11298 : ne retarder le dépliage d'une projection

canonique que si elle contribue vraiment à une équation canonique,
c'est-à-dire si son argument principal est une evar; sinon on
répercute le comportement historique qui est de préférer le dépliage
du côté droit d'une équation constante/constante.



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

4 files changed, 23 insertions, 11 deletions

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index cd09691d0..4d5710860 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -104,10 +104,10 @@ let check_conv_record (t1,l1) (t2,l2) =
       with Not_found -> 
 	lookup_canonical_conversion (proji,Default_cs),[]
     in
-    let { o_DEF = c; o_INJ=n; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } 
-	= canon_s in
+    let { o_DEF = c; o_INJ=n; o_TABS = bs; 
+          o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in
     let params1, c1, extra_args1 =
-      match list_chop (List.length params) l1 with 
+      match list_chop nparams l1 with 
 	| params1, c1::extra_args1 -> params1, c1, extra_args1
 	| _ -> raise Not_found in
     let us2,extra_args2 = list_chop (List.length us) l2_effective in
@@ -288,7 +288,8 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
              if the first argument is a beta-redex (expand a constant
              only if necessary) or the second argument is potentially
              usable as a canonical projection *)
-	  if isLambda flex1 or is_canonical_projection flex2 then
+	  if isLambda flex1 or is_open_canonical_projection (evars_of i) appr2
+	  then
 	    match eval_flexible_term env flex1 with
 	    | Some v1 ->
 		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 110e4fe59..a9fcaa4c4 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -109,6 +109,7 @@ that maps the pair (Li,ci) to the following data
     o_DEF = c
     o_TABS = B1...Bk
     o_PARAMS = a1...am
+    o_NARAMS = m
     o_TCOMP = ui1...uir
 
 *)
@@ -118,6 +119,7 @@ type obj_typ = {
   o_INJ : int;      (* position of trivial argument (negative= none) *)
   o_TABS : constr list;    (* ordered *)
   o_TPARAMS : constr list; (* ordered *)
+  o_NPARAMS : int;
   o_TCOMPS : constr list } (* ordered *)
 
 type cs_pattern =
@@ -178,7 +180,9 @@ let compute_canonical_projections (con,ind) =
 	   | _ -> l)
       [] lps in
   List.map (fun (refi,c,inj,argj) ->
-    (refi,c),{o_DEF=v; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_TCOMPS=argj})
+    (refi,c),
+    {o_DEF=v; o_INJ=inj; o_TABS=lt; 
+     o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj})
     comp
 
 let open_canonical_structure i (_,o) =
@@ -246,8 +250,11 @@ let outCanonicalStructure x = fst (outCanonStruct x)
 let lookup_canonical_conversion (proj,pat) =
   List.assoc pat (Refmap.find proj !object_table)
 
-let is_canonical_projection c =
-  try Refmap.mem (global_of_constr c) !object_table
+let is_open_canonical_projection sigma (c,args) =
+  try 
+    let l = Refmap.find (global_of_constr c) !object_table in
+    let n = (snd (List.hd l)).o_NPARAMS in
+    try isEvar (whd_evar sigma (List.nth args n)) with Failure _ -> false
   with Not_found -> false
 
 let freeze () =
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index d41ede8bb..020687009 100755
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -47,12 +47,14 @@ type obj_typ = {
   o_INJ : int;      (* position of trivial argument *)
   o_TABS : constr list;    (* ordered *)
   o_TPARAMS : constr list; (* ordered *)
+  o_NPARAMS : int;
   o_TCOMPS : constr list } (* ordered *)
 
 val cs_pattern_of_constr : constr -> cs_pattern * int * constr list
  
 val lookup_canonical_conversion : (global_reference * cs_pattern) -> obj_typ
 val declare_canonical_structure : global_reference -> unit
-val is_canonical_projection : constr -> bool
+val is_open_canonical_projection :
+  Evd.evar_map -> (constr * constr list) -> bool
 val canonical_projections : unit -> 
   ((global_reference * cs_pattern) * obj_typ) list
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 12594dd6d..99c57d084 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -518,9 +518,11 @@ let whd_eta c = app_stack (local_whd_state_gen eta (c,empty_stack))
 (* Replacing defined evars for error messages *)
 let rec whd_evar sigma c =
   match kind_of_term c with
-    | Evar (ev,args)
-        when Evd.mem sigma ev & Evd.is_defined sigma ev ->
-	whd_evar sigma (Evd.existential_value sigma (ev,args))
+    | Evar ev ->
+	let d = 
+	  try Some (Evd.existential_value sigma ev)
+	  with NotInstantiatedEvar | Not_found -> None in
+	(match d with Some c -> whd_evar sigma c | None -> c)
     | Sort s when is_sort_variable sigma s -> whd_sort_variable sigma c
     | _ -> collapse_appl c