Fixed bug #2981 (anomaly NotASort in Retyping due to collision between

variable names).

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

3 files changed, 33 insertions, 10 deletions

diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index b01e30bac..1a175465a 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -25,18 +25,16 @@ let rec subst_type env sigma typ = function
         | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
         | _ -> anomaly (str "Non-functional construction")
 
-(* Si ft est le type d'un terme f, lequel est appliqué à args, *)
-(* [sort_of_atomic_ty] calcule ft[args] qui doit être une sorte *)
-(* On suit une méthode paresseuse, en espèrant que ft est une arité *)
-(* et sinon on substitue *)
+(* If ft is the type of f which itself is applied to args, *)
+(* [sort_of_atomic_type] computes ft[args] which has to be a sort *)
 
 let sort_of_atomic_type env sigma ft args =
-  let rec concl_of_arity env ar =
-    match kind_of_term (whd_betadeltaiota env sigma ar) with
-    | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
-    | Sort s -> s
-    | _ -> decomp_sort env sigma (subst_type env sigma ft (Array.to_list args))
-  in concl_of_arity env ft
+  let rec concl_of_arity env ar args =
+    match kind_of_term (whd_betadeltaiota env sigma ar), args with
+    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some h,t) env) b l
+    | Sort s, [] -> s
+    | _ -> anomaly (str "Not a sort")
+  in concl_of_arity env ft (Array.to_list args)
 
 let type_of_var env id =
   try let (_,_,ty) = lookup_named id env in ty
diff --git a/test-suite/bugs/closed/2839.v b/test-suite/bugs/closed/2839.v
new file mode 100644
index 000000000..e396fe06e
--- /dev/null
+++ b/test-suite/bugs/closed/2839.v
@@ -0,0 +1,10 @@
+(* Check a case where ltac typing error should result in error, not anomaly *)
+
+Goal forall (H : forall x : nat, x = x), False.
+intro.
+Fail
+  let H :=
+    match goal with
+    | [ H : appcontext G [@eq _ _] |- _ ] => let H' := context G[@plus 2] in H'
+    end
+  in pose H.
diff --git a/test-suite/bugs/closed/2981.v b/test-suite/bugs/closed/2981.v
new file mode 100644
index 000000000..1facd9b7e
--- /dev/null
+++ b/test-suite/bugs/closed/2981.v
@@ -0,0 +1,15 @@
+Check let TTT := Type in (fun (a b : @sigT TTT (fun A : TTT => A))
+             (f : @projT1 TTT (fun A : TTT => A) a ->
+                  @projT1 TTT (fun A : TTT => A) b) =>
+           @eq_refl
+             (@projT1 TTT (fun A : TTT => A) a ->
+              @projT1 TTT (fun A : TTT => A) b)
+             (fun x : @projT1 TTT (fun A : TTT => A) a => f x)) :
+           forall (a b : @sigT TTT (fun A : TTT => A))
+             (f : @projT1 TTT (fun A : TTT => A) a ->
+                  @projT1 TTT (fun A : TTT => A) b),
+           @eq
+             (@projT1 TTT (fun A : TTT => A) a ->
+              @projT1 TTT (fun A : TTT => A) b)
+             (fun x : @projT1 TTT (fun A : TTT => A) a => f x) f.
+