From 3ffbaec15938bd2dc92753ac3c1e2cc097811f50 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 9 May 2014 12:40:32 +0200
Subject: 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.

---
 pretyping/evarconv.ml         | 10 +++++++---
 pretyping/unification.ml      |  7 +++++--
 test-suite/bugs/closed/3305.v | 13 +++++++++++++
 test-suite/bugs/closed/3306.v | 12 ++++++++++++
 4 files changed, 37 insertions(+), 5 deletions(-)
 create mode 100644 test-suite/bugs/closed/3305.v
 create mode 100644 test-suite/bugs/closed/3306.v

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. 
-- 
cgit v1.2.3