kernel conversion and reduction do not raise assert failure on ill-typed terms, but an anomaly instead. It is caught in pretyping

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

2 files changed, 18 insertions, 9 deletions

diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index b92f97aa6..904a2a009 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -260,7 +260,8 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     | (FAtom a1, FAtom a2) ->
 	(match kind_of_term a1, kind_of_term a2 with
 	   | (Sort s1, Sort s2) ->
-	       assert (is_empty_stack v1 && is_empty_stack v2);
+	       if not (is_empty_stack v1 && is_empty_stack v2) then
+		 anomaly "conversion was given ill-typed terms (Sort)";
 	       sort_cmp cv_pb s1 s2 cuniv
 	   | (Meta n, Meta m) ->
                if n=m
@@ -320,14 +321,16 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
 
     (* other constructors *)
     | (FLambda _, FLambda _) ->
-        assert (is_empty_stack v1 && is_empty_stack v2);
+        if not (is_empty_stack v1 && is_empty_stack v2) then
+	  anomaly "conversion was given ill-typed terms (FLambda)";
         let (_,ty1,bd1) = destFLambda mk_clos hd1 in
         let (_,ty2,bd2) = destFLambda mk_clos hd2 in
         let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in
         ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1
 
     | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
-        assert (is_empty_stack v1 && is_empty_stack v2);
+        if not (is_empty_stack v1 && is_empty_stack v2) then
+	  anomaly "conversion was given ill-typed terms (FProd)";
 	(* Luo's system *)
         let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in
         ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 082ea7080..78a5341b1 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -523,9 +523,11 @@ let nf_evar =
 (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add
    a [nf_evar] here *)
 let clos_norm_flags flgs env sigma t =
-  norm_val
-    (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
-    (inject t)
+  try
+    norm_val
+      (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
+      (inject t)
+  with Anomaly _ -> error "Tried to normalized ill-typed term" 
 
 let nf_beta = clos_norm_flags Closure.beta empty_env
 let nf_betaiota = clos_norm_flags Closure.betaiota empty_env
@@ -584,9 +586,11 @@ let nf_betaiota_preserving_vm_cast =
 
 (* lazy weak head reduction functions *)
 let whd_flags flgs env sigma t =
-  whd_val
-    (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
-    (inject t)
+  try
+    whd_val
+      (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
+      (inject t)
+  with Anomaly _ -> error "Tried to normalized ill-typed term" 
 
 (********************************************************************)
 (*                         Conversion                               *)
@@ -618,6 +622,7 @@ let test_conversion (f:?evars:'a->'b) env sigma x y =
   try let _ =
     f ~evars:(safe_evar_value sigma) env x y in true
   with NotConvertible -> false
+    | Anomaly _ -> error "Conversion test raised an anomaly"
 
 let is_conv env sigma = test_conversion Reduction.conv env sigma
 let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma
@@ -626,6 +631,7 @@ let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
 let test_trans_conversion f reds env sigma x y =
   try let _ = f reds env (nf_evar sigma x) (nf_evar sigma y) in true
   with NotConvertible -> false
+    | Anomaly _ -> error "Conversion test raised an anomaly"
 
 let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma
 let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma