Fix second-order matching to properly check that the predicate found by

abstraction has the right type. Fixes bug# 3306.
Add test-suite files for bugs 3305 and 3306.

4 files changed, 37 insertions, 5 deletions

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index a926985664..6bf621b055 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -889,10 +889,14 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
       in
       force_instantiation evd !evsref
   | [] ->
-      Evd.define evk rhs evd in
-
+    let evd = 
+      try Evarsolve.check_evar_instance evd evk rhs (evar_conv_x ts)
+      with IllTypedInstance _ -> raise (TypingFailed evd)
+    in
+      Evd.define evk rhs evd 
+  in
   abstract_free_holes evd subst, true
-  with TypingFailed evd -> Evd.define evk rhs evd, false
+  with TypingFailed evd -> evd, false
 
 let second_order_matching_with_args ts env evd ev l t =
 (*
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 7eca9f2cec..7b6fb262a8 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -92,8 +92,11 @@ let abstract_list_all_with_dependencies env evd typ c l =
   let evd,b =
     Evarconv.second_order_matching empty_transparent_state
       env evd ev' argoccs c in
-  let p = nf_evar evd (existential_value evd (destEvar ev)) in
-  if b then evd, p else error_cannot_find_well_typed_abstraction env evd p l None
+  if b then
+    let p = nf_evar evd (existential_value evd (destEvar ev)) in
+      evd, p
+  else error_cannot_find_well_typed_abstraction env evd 
+    (nf_evar evd c) l None
 
 (**)
 
diff --git a/test-suite/bugs/closed/3305.v b/test-suite/bugs/closed/3305.v
new file mode 100644
index 0000000000..f3f2195228
--- /dev/null
+++ b/test-suite/bugs/closed/3305.v
@@ -0,0 +1,13 @@
+Require Export Coq.Classes.RelationClasses.
+
+Section defs.
+  Variable A : Type.
+  Variable lt : A -> A -> Prop.
+  Context {ltso : StrictOrder lt}.
+
+  Goal forall (a : A), lt a a -> False.
+  Proof.
+    intros a H.
+    contradict (irreflexivity H).
+  Qed.
+End defs.
diff --git a/test-suite/bugs/closed/3306.v b/test-suite/bugs/closed/3306.v
new file mode 100644
index 0000000000..599e8391ac
--- /dev/null
+++ b/test-suite/bugs/closed/3306.v
@@ -0,0 +1,12 @@
+
+Inductive Foo(A : Type) : Prop :=
+  foo: A -> Foo A.
+
+Arguments foo [A] _.
+
+Scheme Foo_elim := Induction for Foo Sort Prop.
+
+Goal forall (fn : Foo nat), { x: nat | foo x = fn }.
+intro fn.
+Fail induction fn as [n] using Foo_elim. (* should fail in a non-Prop context *)
+Admitted.