More informative error when a global reference is used in a context of

local variables which is a different from the one of its definition. E.g.:

Section A.
Variable n:nat.
Definition c:=n.
Goal True.
clear n.
Check c.

[I'm however unsure that "n" should not continue to be accessible via
some global (qualified) name, even after the "clear n".]

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

6 files changed, 29 insertions, 38 deletions

diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 4c2799df8c..42b93dd375 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -41,7 +41,7 @@ type type_error =
   | UnboundVar of variable
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
-  | ReferenceVariables of constr
+  | ReferenceVariables of identifier * constr
   | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
       * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
@@ -74,8 +74,8 @@ let error_not_type env j =
 let error_assumption env j =
   raise (TypeError (env, BadAssumption j))
 
-let error_reference_variables env id =
-  raise (TypeError (env, ReferenceVariables id))
+let error_reference_variables env id c =
+  raise (TypeError (env, ReferenceVariables (id,c)))
 
 let error_elim_arity env ind aritylst c pj okinds =
   raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 531ad0b9ee..b9d8efbcde 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -42,7 +42,7 @@ type type_error =
   | UnboundVar of variable
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
-  | ReferenceVariables of constr
+  | ReferenceVariables of identifier * constr
   | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
       * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
@@ -68,7 +68,7 @@ val error_not_type : env -> unsafe_judgment -> 'a
 
 val error_assumption : env -> unsafe_judgment -> 'a
 
-val error_reference_variables : env -> constr -> 'a
+val error_reference_variables : env -> identifier -> constr -> 'a
 
 val error_elim_arity :
   env -> inductive -> sorts_family list -> constr -> unsafe_judgment ->
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index efc7a4ee8b..18e6fec791 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -91,33 +91,20 @@ let judge_of_variable env id =
 
 (* Management of context of variables. *)
 
-(* Checks if a context of variable can be instantiated by the
+(* Checks if a context of variables can be instantiated by the
    variables of the current env *)
 (* TODO: check order? *)
-let check_hyps_inclusion env sign =
+let check_hyps_inclusion env c sign =
   Sign.fold_named_context
     (fun (id,_,ty1) () ->
-      let ty2 = named_type id env in
-      if not (eq_constr ty2 ty1) then
-        error "types do not match")
+      try
+        let ty2 = named_type id env in
+        if not (eq_constr ty2 ty1) then raise Exit
+      with Not_found | Exit ->
+        error_reference_variables env id c)
     sign
     ~init:()
 
-
-let check_args env c hyps =
-  try check_hyps_inclusion env hyps
-  with UserError _ | Not_found ->
-    error_reference_variables env c
-
-
-(* Checks if the given context of variables [hyps] is included in the
-   current context of [env]. *)
-(*
-let check_hyps id env hyps =
-  let hyps' = named_context env in
-  if not (hyps_inclusion env hyps hyps') then
-    error_reference_variables env id
-*)
 (* Instantiation of terms on real arguments. *)
 
 (* Make a type polymorphic if an arity *)
@@ -162,7 +149,7 @@ let type_of_constant env cst =
 let judge_of_constant_knowing_parameters env cst jl =
   let c = mkConst cst in
   let cb = lookup_constant cst env in
-  let _ = check_args env c cb.const_hyps in
+  let _ = check_hyps_inclusion env c cb.const_hyps in
   let paramstyp = Array.map (fun j -> j.uj_type) jl in
   let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in
   make_judge c t
@@ -308,7 +295,7 @@ let judge_of_cast env cj k tj =
 let judge_of_inductive_knowing_parameters env ind jl =
   let c = mkInd ind in
   let (mib,mip) = lookup_mind_specif env ind in
-  check_args env c mib.mind_hyps;
+  check_hyps_inclusion env c mib.mind_hyps;
   let paramstyp = Array.map (fun j -> j.uj_type) jl in
   let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in
   make_judge c t
@@ -323,7 +310,7 @@ let judge_of_constructor env c =
   let _ =
     let ((kn,_),_) = c in
     let mib = lookup_mind kn env in
-    check_args env constr mib.mind_hyps in
+    check_hyps_inclusion env constr mib.mind_hyps in
   let specif = lookup_mind_specif env (inductive_of_constructor c) in
   make_judge constr (type_of_constructor c specif)
 
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 0ecbfdbb4c..6af9ff3233 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -167,8 +167,9 @@ let rec nf_val env v typ =
       let lvl = nb_rel env in
       let name,dom,codom = 
 	try decompose_prod env typ
-	with _ -> (* TODO: is this the right exception to raise? *)
-	  raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ))
+	with Invalid_argument _ ->
+          Errors.anomaly
+            (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
       in
       let env = push_rel (name,None,dom) env in
       let body = nf_val env (f (mk_rel_accu lvl)) codom in
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 82eccab96d..b18719cc27 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -249,8 +249,10 @@ and nf_fun env f typ =
   let vb = body_of_vfun k f in
   let name,dom,codom =
     try decompose_prod env typ
-    with _ ->
-      raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ))
+    with Invalid_argument _ ->
+      (* 27/2/13: Turned this into an anomaly *)
+      Errors.anomaly
+        (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
   in
   let body = nf_val (push_rel (name,None,dom) env) vb codom in
   mkLambda(name,dom,body)
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index cc05f371e6..61830603ba 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -60,10 +60,11 @@ let explain_bad_assumption env j =
   brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++
   str "because this term is not a type."
 
-let explain_reference_variables c =
-  let pc = pr_lconstr c in
-  str "The constant" ++ spc () ++ pc ++ spc () ++
-  str "refers to variables which are not in the context."
+let explain_reference_variables id c =
+  (* c is intended to be a global reference *)
+  let pc = pr_global (Globnames.global_of_constr c) in
+  pc ++ strbrk " depends on the variable " ++ pr_id id ++
+  strbrk " which is not declared in the context."
 
 let rec pr_disjunction pr = function
   | [a] -> pr  a
@@ -528,8 +529,8 @@ let explain_type_error env sigma err =
       explain_not_type env sigma j
   | BadAssumption c ->
       explain_bad_assumption env c
-  | ReferenceVariables id ->
-      explain_reference_variables id
+  | ReferenceVariables (id,c) ->
+      explain_reference_variables id c
   | ElimArity (ind, aritylst, c, pj, okinds) ->
       explain_elim_arity env ind aritylst c pj okinds
   | CaseNotInductive cj ->