From 4a8c1e387bb0b971e651458319e77603d87b2d08 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Wed, 6 Jul 2016 10:46:29 +0200
Subject: Univs: fix internalization of (x := T) and casts

They were allowing algebraic universes to slip in terms.
---
 interp/constrintern.ml | 19 ++++++++++++-------
 pretyping/pretyping.ml | 17 ++++++++++-------
 2 files changed, 22 insertions(+), 14 deletions(-)

diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index 1c50253d9c..28c7152096 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -481,9 +481,14 @@ let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = functio
       let bl' = List.map (fun a -> BDRawDef a) bl' in
       env, bl' @ bl
   | LocalRawDef((loc,na as locna),def) ->
-      let indef = intern env def in
+     let indef = intern env def in
+     let term, ty =
+       match indef with
+       | GCast (loc, b, Misctypes.CastConv t) -> b, t
+       | _ -> indef, GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)
+     in
       (push_name_env lvar (impls_term_list indef) env locna,
-       (BDRawDef ((loc,(na,Explicit,Some(indef),GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)))))::bl)
+       (BDRawDef ((loc,(na,Explicit,Some(term),ty))))::bl)
   | LocalPattern (loc,p,ty) ->
       let tyc =
         match ty with
@@ -2030,11 +2035,11 @@ let interp_rawcontext_evars env evdref k bl =
   let (env, par, _, impls) =
     List.fold_left
       (fun (env,params,n,impls) (na, k, b, t) ->
+	let t' = locate_if_hole (loc_of_glob_constr t) na t in
+	let t =
+          understand_tcc_evars env evdref ~expected_type:IsType t' in
 	match b with
 	    None ->
-	      let t' = locate_if_hole (loc_of_glob_constr t) na t in
-	      let t =
-                understand_tcc_evars env evdref ~expected_type:IsType t' in
 	      let d = LocalAssum (na,t) in
 	      let impls =
 		if k == Implicit then
@@ -2044,8 +2049,8 @@ let interp_rawcontext_evars env evdref k bl =
 	      in
 		(push_rel d env, d::params, succ n, impls)
 	  | Some b ->
-	      let c = understand_judgment_tcc env evdref b in
-	      let d = LocalDef (na, c.uj_val, c.uj_type) in
+	      let c = understand_tcc_evars env evdref ~expected_type:(OfType t) b in
+	      let d = LocalDef (na, c, t) in
 		(push_rel d env, d::params, n, impls))
       (env,[],k+1,[]) (List.rev bl)
   in (env, par), impls
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index c8f61c66b8..187eba16b6 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -953,14 +953,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
       | CastConv t | CastVM t | CastNative t ->
 	let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in
 	let tj = pretype_type empty_valcon env evdref lvar t in
-	let tval = nf_evar !evdref tj.utj_val in
-	let cj = match k with
+        let tval = evd_comb1 (Evarsolve.refresh_universes
+                             ~onlyalg:true ~status:Evd.univ_flexible (Some false) env)
+                          evdref tj.utj_val in
+	let tval = nf_evar !evdref tval in
+	let cj, tval = match k with
 	  | VMcast ->
  	    let cj = pretype empty_tycon env evdref lvar c in
-	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
 	      if not (occur_existential cty || occur_existential tval) then
 		let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in
-		if b then (evdref := evd; cj)
+		if b then (evdref := evd; cj, tval)
 		else
 		  error_actual_type_loc loc env !evdref cj tval 
                       (ConversionFailed (env,cty,tval))
@@ -968,16 +971,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
 		str "unresolved arguments remain.")
 	  | NATIVEcast ->
  	    let cj = pretype empty_tycon env evdref lvar c in
-	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
             begin
 	      let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in
-	      if b then (evdref := evd; cj)
+	      if b then (evdref := evd; cj, tval)
 	      else
                 error_actual_type_loc loc env !evdref cj tval 
                   (ConversionFailed (env,cty,tval))
             end
 	  | _ -> 
- 	    pretype (mk_tycon tval) env evdref lvar c
+ 	    pretype (mk_tycon tval) env evdref lvar c, tval
 	in
 	let v = mkCast (cj.uj_val, k, tval) in
 	  { uj_val = v; uj_type = tval }
-- 
cgit v1.2.3