Require Export compcert.lib.Axioms.
Require Export compcert.lib.Integers.
Require Export compcert.lib.Floats.
Require Export compcert.lib.Maps.
Require Export compcert.common.AST.
Require Export compcert.common.Values.
Require Export compcert.cfrontend.Ctypes.
Require Export compcert.cfrontend.Clight.
Require Export VST.sepcomp.Address.
Require Export VST.msl.eq_dec.
Require Export VST.msl.shares.
Require Export VST.msl.predicates_rec.
Require Export VST.msl.contractive.
Require Export VST.msl.seplog.
Require Export VST.msl.ghost_seplog.
Require Export VST.msl.alg_seplog.
Require Export VST.msl.log_normalize.
Require Export VST.msl.wand_frame.
Require Export VST.msl.wandQ_frame.
Require Export VST.msl.ramification_lemmas.
Require Export VST.veric.tycontext.
Require Export VST.veric.change_compspecs.
Require Export VST.veric.mpred.
Require Export VST.veric.expr.
Require Export VST.veric.Clight_lemmas.
Require Export VST.veric.composite_compute.
Require Export VST.veric.align_mem.
Require Export VST.veric.shares.
Require Export VST.veric.seplog.
Require VST.veric.Clight_seplog.
Require VST.veric.Clight_assert_lemmas.
Require VST.veric.semax_prog.
Require VST.veric.semax_ext.
Instance Nveric: NatDed mpred := algNatDed compcert_rmaps.RML.R.rmap.
Instance Sveric: SepLog mpred := algSepLog compcert_rmaps.RML.R.rmap.
Instance Cveric: ClassicalSep mpred := algClassicalSep compcert_rmaps.RML.R.rmap.
Instance Iveric: Indir mpred := algIndir compcert_rmaps.RML.R.rmap.
Instance Rveric: RecIndir mpred := algRecIndir compcert_rmaps.RML.R.rmap.
Instance SIveric: SepIndir mpred := algSepIndir compcert_rmaps.RML.R.rmap.
Instance CSLveric: CorableSepLog mpred := algCorableSepLog compcert_rmaps.RML.R.rmap.
Instance CIveric: CorableIndir mpred := algCorableIndir compcert_rmaps.RML.R.rmap.
Instance SRveric: SepRec mpred := algSepRec compcert_rmaps.RML.R.rmap.
Instance Bveric: BupdSepLog mpred gname compcert_rmaps.RML.R.preds :=
mkBSL _ _ _ _ _ bupd (@own) bupd_intro bupd_mono bupd_trans bupd_frame_r
(@ghost_alloc) (@ghost_op) (@ghost_valid_2) (@ghost_update_ND) (@ghost_dealloc).
Instance LiftNatDed' T {ND: NatDed T}: NatDed (LiftEnviron T) := LiftNatDed _ _.
Instance LiftSepLog' T {ND: NatDed T}{SL: SepLog T}: SepLog (LiftEnviron T) := LiftSepLog _ _.
Instance LiftClassicalSep' T {ND: NatDed T}{SL: SepLog T}{CS: ClassicalSep T} :
ClassicalSep (LiftEnviron T) := LiftClassicalSep _ _.
Instance LiftIndir' T {ND: NatDed T}{SL: SepLog T}{IT: Indir T} :
Indir (LiftEnviron T) := LiftIndir _ _.
Instance LiftSepIndir' T {ND: NatDed T}{SL: SepLog T}{IT: Indir T}{SI: SepIndir T} :
SepIndir (LiftEnviron T) := LiftSepIndir _ _.
Instance LiftCorableSepLog' T {ND: NatDed T}{SL: SepLog T}{CSL: CorableSepLog T} :
CorableSepLog (LiftEnviron T) := LiftCorableSepLog _ _.
Instance LiftCorableIndir' T {ND: NatDed T}{SL: SepLog T}{IT: Indir T}{SI: SepIndir T}{CSL: CorableSepLog T}{CI: CorableIndir T} :
CorableIndir (LiftEnviron T) := LiftCorableIndir _ _.
Definition local:  (environ -> Prop) -> environ->mpred :=  lift1 prop.
Global Opaque mpred Nveric Sveric Cveric Iveric Rveric Sveric SIveric CSLveric CIveric SRveric Bveric.
Hint Resolve any_environ : typeclass_instances.
Local Open Scope logic.
Transparent mpred Nveric Sveric Cveric Iveric Rveric Sveric SIveric CSLveric CIveric SRveric Bveric.
(* BEGIN from expr2.v *)
Definition denote_tc_iszero v : mpred :=
match v with
| Vint i => prop (is_true (Int.eq i Int.zero))
| Vlong i => prop (is_true (Int64.eq i Int64.zero))
| _ => FF
end.
Definition denote_tc_nonzero v : mpred :=
match v with
| Vint i => prop (i <> Int.zero)
| Vlong i =>prop (i <> Int64.zero)
| _ => FF end.
Definition denote_tc_igt i v : mpred :=
match v with
| Vint i1 => prop (Int.unsigned i1 < Int.unsigned i)
| _ => FF
end.
Definition denote_tc_lgt l v : mpred :=
match v with
| Vlong l1 => prop (Int64.unsigned l1 < Int64.unsigned l)
| _ => FF
end.
Definition Zoffloat (f:float): option Z := (**r conversion to Z *)
match f with
| IEEE754.Binary.B754_finite s m (Zpos e) _ =>
Some (Zaux.cond_Zopp s (Zpos m) * Zpower_pos 2 e)%Z
| IEEE754.Binary.B754_finite s m 0 _ => Some (Zaux.cond_Zopp s (Zpos m))
| IEEE754.Binary.B754_finite s m (Zneg e) _ => Some (Zaux.cond_Zopp s (Zpos m / Zpower_pos 2 e))
| IEEE754.Binary.B754_zero _ => Some 0
| _ => None
end.  (* copied from CompCert 2.3, because it's missing in CompCert 2.4,
then adapted after CompCert 3.5 when Flocq was rearranged *)
Definition Zofsingle (f: float32): option Z := (**r conversion to Z *)
match f with
| IEEE754.Binary.B754_finite s m (Zpos e) _ =>
Some (Zaux.cond_Zopp s (Zpos m) * Zpower_pos 2 e)%Z
| IEEE754.Binary.B754_finite s m 0 _ => Some (Zaux.cond_Zopp s (Zpos m))
| IEEE754.Binary.B754_finite s m (Zneg e) _ => Some (Zaux.cond_Zopp s (Zpos m / Zpower_pos 2 e))
| IEEE754.Binary.B754_zero _ => Some 0
| _ => None
end.
Definition denote_tc_Zge z v : mpred :=
match v with
| Vfloat f => match Zoffloat f with
| Some n => prop (z >= n)
| None => FF
end
| Vsingle f => match Zofsingle f with
| Some n => prop (z >= n)
| None => FF
end
| _ => FF
end.
Definition denote_tc_Zle z v : mpred :=
match v with
| Vfloat f => match Zoffloat f with
| Some n => prop (z <= n)
| None => FF
end
| Vsingle f => match Zofsingle f with
| Some n => prop (z <= n)
| None => FF
end
| _ => FF
end.
Definition sameblock v1 v2 : bool :=
match v1, v2 with
| Vptr b1 _, Vptr b2 _ => peq b1 b2
| _, _ => false
end.
Definition denote_tc_samebase v1 v2 : mpred :=
prop (is_true (sameblock v1 v2)).
(** Case for division of int min by -1, which would cause overflow **)
Definition denote_tc_nodivover v1 v2 : mpred :=
match v1, v2 with
| Vint n1, Vint n2 => prop (~(n1 = Int.repr Int.min_signed /\ n2 = Int.mone))
| Vlong n1, Vlong n2 => prop (~(n1 = Int64.repr Int64.min_signed /\ n2 = Int64.mone))
| Vint n1, Vlong n2 => TT
| Vlong n1, Vint n2 => prop (~ (n1 = Int64.repr Int64.min_signed  /\ n2 = Int.mone))
| _ , _ => FF
end.
Definition denote_tc_nosignedover (op: Z->Z->Z) v1 v2 : mpred :=
match v1,v2 with
| Vint n1, Vint n2 =>
prop (Int.min_signed <= op (Int.signed n1) (Int.signed n2) <= Int.max_signed)
| Vlong n1, Vlong n2 =>
prop (Int64.min_signed <= op (Int64.signed n1) (Int64.signed n2) <= Int64.max_signed)
| Vint n1, Vlong n2 =>
prop (Int64.min_signed <= op (Int.signed n1) (Int64.signed n2) <= Int64.max_signed)
| Vlong n1, Vint n2 =>
prop (Int64.min_signed <= op (Int64.signed n1) (Int.signed n2) <= Int64.max_signed)
| _, _ => FF
end.
Definition denote_tc_initialized id ty rho : mpred :=
prop (exists v, Map.get (te_of rho) id = Some v
/\ tc_val ty v).
Definition denote_tc_isptr v : mpred :=
prop (isptr v).
Definition denote_tc_isint v : mpred :=
prop (is_int I32 Signed v).
Definition denote_tc_islong v : mpred :=
prop (is_long v).
Definition test_eq_ptrs v1 v2 : mpred :=
if sameblock v1 v2
then (andp (weak_valid_pointer v1) (weak_valid_pointer v2))
else (andp (valid_pointer v1) (valid_pointer v2)).
Definition test_order_ptrs v1 v2 : mpred :=
if sameblock v1 v2
then (andp (weak_valid_pointer v1) (weak_valid_pointer v2))
else FF.
Definition denote_tc_test_eq v1 v2 : mpred :=
match v1, v2 with
| Vint i, Vint j =>
if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (prop (j = Int.zero))
| Vlong i, Vlong j =>
if Archi.ptr64 then andp (prop (i = Int64.zero)) (prop (j = Int64.zero)) else FF
| Vint i, Vptr _ _ =>
if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (weak_valid_pointer v2)
| Vlong i, Vptr _ _ =>
if Archi.ptr64 then andp (prop (i = Int64.zero)) (weak_valid_pointer v2) else FF
| Vptr _ _, Vint i =>
if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (weak_valid_pointer v1)
| Vptr _ _, Vlong i =>
if Archi.ptr64 then andp (prop (i = Int64.zero)) (weak_valid_pointer v1) else FF
| Vptr _ _, Vptr _ _ =>
test_eq_ptrs v1 v2
| _, _ => FF
end.
Definition denote_tc_test_order v1 v2 : mpred :=
match v1, v2 with
| Vint i, Vint j => if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (prop (j = Int.zero))
| Vlong i, Vlong j => if Archi.ptr64 then andp (prop (i = Int64.zero)) (prop (j = Int64.zero)) else FF
| Vptr _ _, Vptr _ _ =>
test_order_ptrs v1 v2
| _, _ => FF
end.
Definition typecheck_error (e: tc_error) : Prop := False.
Global Opaque typecheck_error.
(* Somehow, this fixes a universe collapse issue that will occur if fool is not defined. *)
Definition fool := @map _ Type (fun it : ident * type => mpred).
Fixpoint denote_tc_assert {CS: compspecs} (a: tc_assert) : environ -> mpred :=
match a with
| tc_FF msg => `(prop (typecheck_error msg))
| tc_TT => TT
| tc_andp' b c => fun rho => andp (denote_tc_assert b rho) (denote_tc_assert c rho)
| tc_orp' b c => `orp (denote_tc_assert b) (denote_tc_assert c)
| tc_nonzero' e => `denote_tc_nonzero (eval_expr e)
| tc_isptr e => `denote_tc_isptr (eval_expr e)
| tc_isint e => `denote_tc_isint (eval_expr e)
| tc_islong e => `denote_tc_islong (eval_expr e)
| tc_test_eq' e1 e2 => `denote_tc_test_eq (eval_expr e1) (eval_expr e2)
| tc_test_order' e1 e2 => `denote_tc_test_order (eval_expr e1) (eval_expr e2)
| tc_ilt' e i => `(denote_tc_igt i) (eval_expr e)
| tc_llt' e i => `(denote_tc_lgt i) (eval_expr e)
| tc_Zle e z => `(denote_tc_Zge z) (eval_expr e)
| tc_Zge e z => `(denote_tc_Zle z) (eval_expr e)
| tc_samebase e1 e2 => `denote_tc_samebase (eval_expr e1) (eval_expr e2)
| tc_nodivover' v1 v2 => `denote_tc_nodivover (eval_expr v1) (eval_expr v2)
| tc_initialized id ty => denote_tc_initialized id ty
| tc_iszero' e => `denote_tc_iszero (eval_expr e)
| tc_nosignedover op e1 e2 => `(denote_tc_nosignedover op) (eval_expr e1) (eval_expr e2)
end.
Definition fool' := @map _ Type (fun it : ident * type => mpred).
Opaque mpred Nveric Sveric Cveric Iveric Rveric Sveric SIveric CSLveric CIveric SRveric Bveric.
(* END from expr2.v *)
Definition cast_pointer_to_bool t1 t2 :=
match t1 with (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
match t2 with Tint IBool _ _ => true | _ => false end
| _ => false
end.
Fixpoint ext_link_prog' (dl: list (ident * globdef fundef type)) (s: String.string) : option ident :=
match dl with
| (id, Gfun (External EF_malloc _ _ _)) :: dl' =>
if String.string_dec s "_malloc" then Some id else ext_link_prog' dl' s
| (id, Gfun (External EF_free _ _ _)) :: dl' =>
if String.string_dec s "_free" then Some id else ext_link_prog' dl' s
| (id, Gfun (External (EF_external s' _) _ _ _)) :: dl' =>
if String.string_dec s s' then Some id else ext_link_prog' dl' s
| (id, Gfun (External (EF_builtin s' _) _ _ _)) :: dl' =>
if String.string_dec s s' then Some id else ext_link_prog' dl' s
| _ :: dl' =>
ext_link_prog' dl' s
| nil => None
end.
Definition ext_link_prog (p: program) (s: String.string) : ident :=
match ext_link_prog' (prog_defs p) s with Some id => id | None => 1%positive end.
Definition closed_wrt_vars {B} (S: ident -> Prop) (F: environ -> B) : Prop :=
forall rho te',
(forall i, S i \/ Map.get (te_of rho) i = Map.get te' i) ->
F rho = F (mkEnviron (ge_of rho) (ve_of rho) te').
Definition closed_wrt_lvars {B} (S: ident -> Prop) (F: environ -> B) : Prop :=
forall rho ve',
(forall i, S i \/ Map.get (ve_of rho) i = Map.get ve' i) ->
F rho = F (mkEnviron (ge_of rho) ve' (te_of rho)).
Definition not_a_param (params: list (ident * type)) (i : ident) : Prop :=
~ In i (map (@fst _ _) params).
Definition precondition_closed (fs: list (ident*type)) {A: rmaps.TypeTree}
(P: forall ts, functors.MixVariantFunctor._functor (rmaps.dependent_type_functor_rec ts (AssertTT A)) mpred) : Prop :=
forall ts x,
closed_wrt_vars (not_a_param fs) (P ts x) /\
closed_wrt_lvars (fun _ => True) (P ts x).
Definition typed_true (t: type) (v: val)  : Prop :=  strict_bool_val v t
= Some true.
Definition typed_false (t: type)(v: val) : Prop :=  strict_bool_val v t =
Some false.
Definition subst {A} (x: ident) (v: environ -> val) (P: environ -> A) : environ -> A :=
fun s => P (env_set s x (v s)).
Definition substopt {A} (ret: option ident) (v: environ -> val) (P: environ -> A)  : environ -> A :=
match ret with
| Some id => subst id v P
| None => P
end.
Definition cast_expropt {CS: compspecs} (e: option expr) t : environ -> option val :=
match e with Some e' => `Some (eval_expr (Ecast e' t))  | None => `None end.
Definition typecheck_tid_ptr_compare
Delta id :=
match (temp_types Delta) ! id with
| Some t => is_int_type t
| None => false
end.
Definition mapsto (sh: Share.t) (t: type) (v1 v2 : val): mpred :=
match access_mode t with
| By_value ch =>
match type_is_volatile t with
| false =>
match v1 with
| Vptr b ofs =>
if readable_share_dec sh
then @orp mpred _
(@andp mpred _ (!!tc_val t v2)
(res_predicates.address_mapsto ch v2 sh (b, Ptrofs.unsigned ofs)))
(@andp mpred _ (!! (v2 = Vundef))
(@exp mpred _ val (fun v2' =>res_predicates.address_mapsto ch v2' sh (b, Ptrofs.unsigned ofs))))
else @andp mpred _
(!! (tc_val' t v2 /\ (Memdata.align_chunk ch | Ptrofs.unsigned ofs)))
(res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned ofs) (Memdata.size_chunk ch))
| _ => FF
end
| _ => FF
end
| _ => FF
end.
Definition mapsto_ sh t v1 := mapsto sh t v1 Vundef.
Definition mapsto_zeros (n: Z) (sh: share) (a: val) : mpred :=
match a with
| Vptr b z =>
!! (0 <= Ptrofs.unsigned z  /\ n + Ptrofs.unsigned z < Ptrofs.modulus)%Z &&
mapsto_memory_block.address_mapsto_zeros sh (Z.to_nat n) (b, Ptrofs.unsigned z)
| _ => FF
end.
Definition init_data2pred (d: init_data)  (sh: share) (a: val) (rho: environ) : mpred :=
match d with
| Init_int8 i => mapsto sh (Tint I8 Unsigned noattr) a (Vint (Int.zero_ext 8 i))
| Init_int16 i => mapsto sh (Tint I16 Unsigned noattr) a (Vint (Int.zero_ext 16 i))
| Init_int32 i => mapsto sh (Tint I32 Unsigned noattr) a (Vint i)
| Init_int64 i => mapsto sh (Tlong Unsigned noattr) a (Vlong i)
| Init_float32 r =>  mapsto sh (Tfloat F32 noattr) a (Vsingle r)
| Init_float64 r =>  mapsto sh (Tfloat F64 noattr) a (Vfloat r)
| Init_space n => mapsto_zeros n sh a
| Init_addrof symb ofs =>
match Map.get (ge_of rho) symb with
| Some b => mapsto sh (Tpointer Tvoid noattr) a (Vptr b ofs)
| _ => mapsto_ sh (Tpointer Tvoid noattr) a
end
end.
(*Definition extern_retainer : share := fst (Share.split Share.Lsh). *)
Definition init_data_size (i: init_data) : Z :=
match i with
| Init_int8 _ => 1
| Init_int16 _ => 2
| Init_int32 _ => 4
| Init_int64 _ => 8
| Init_float32 _ => 4
| Init_float64 _ => 8
| Init_addrof _ _ => if Archi.ptr64 then 8 else 4
| Init_space n => Z.max n 0
end.
Fixpoint init_data_list_size (il: list init_data) {struct il} : Z :=
match il with
| nil => 0
| i :: il' => init_data_size i + init_data_list_size il'
end.
Fixpoint init_data_list2pred  (dl: list init_data)
(sh: share) (v: val)  : environ -> mpred :=
match dl with
| d::dl' =>
sepcon (init_data2pred d sh v)
(init_data_list2pred dl' sh (offset_val (init_data_size d) v))
| nil => emp
end.
Definition readonly2share (rdonly: bool) : share :=
if rdonly then Ers else Ews.
Definition globals := ident -> val.
Definition globvar2pred (gv: globals) (idv: ident * globvar type) : environ->mpred :=
if (gvar_volatile (snd idv))
then  lift0 TT
else    init_data_list2pred (gvar_init (snd idv))
(readonly2share (gvar_readonly (snd idv))) (gv (fst idv)).
Definition globals_of_env (rho: environ) (i: ident) : val :=
match Map.get (ge_of rho) i with Some b => Vptr b Ptrofs.zero | None => Vundef end.
Definition globvars2pred  (gv: globals)  (vl: list (ident * globvar type)) : environ->mpred :=
(lift2 andp) (fun rho => prop (gv = globals_of_env rho))
(fold_right sepcon emp (map (globvar2pred gv) vl)).
Definition initializer_aligned (z: Z) (d: init_data) : bool :=
match d with
| Init_int16 n => Zeq_bool (z mod 2) 0
| Init_int32 n => Zeq_bool (z mod 4) 0
| Init_int64 n => Zeq_bool (z mod 8) 0
| Init_float32 n =>  Zeq_bool (z mod 4) 0
| Init_float64 n =>  Zeq_bool (z mod 8) 0
| Init_addrof symb ofs =>  Zeq_bool (z mod (size_chunk Mptr)) 0
| _ => true
end.
Fixpoint initializers_aligned (z: Z) (dl: list init_data) : bool :=
match dl with
| nil => true
| d::dl' => andb (initializer_aligned z d) (initializers_aligned (z + init_data_size d) dl')
end.
Definition funsig := (list (ident*type) * type)%type. (* argument and result signature *)
Definition memory_block (sh: share) (n: Z) (v: val) : mpred :=
match v with
| Vptr b ofs => (!! (Ptrofs.unsigned ofs + n < Ptrofs.modulus)) && mapsto_memory_block.memory_block' sh (Z.to_nat n) b (Ptrofs.unsigned ofs)
| _ => FF
end.
(* TODO: merge size_compatible and align_compatible *)
Definition align_compatible {C: compspecs} t p :=
match p with
| Vptr b i_ofs => align_compatible_rec cenv_cs t (Ptrofs.unsigned i_ofs)
| _ => True
end.
Definition size_compatible {C: compspecs} t p :=
match p with
| Vptr b i_ofs => Ptrofs.unsigned i_ofs + sizeof t < Ptrofs.modulus
| _ => True
end.
(*We're exporting the step-indexed version so that semax_fun_id does syntatically not change*)
Definition func_ptr (f: funspec) (v: val): mpred := seplog.func_ptr_si f v.
Definition NDmk_funspec (f: funsig) (cc: calling_convention)
(A: Type) (Pre Post: A -> environ -> mpred): funspec :=
mk_funspec f cc (rmaps.ConstType A) (fun _ => Pre) (fun _ => Post)
(const_super_non_expansive _ _) (const_super_non_expansive _ _).
Definition type_of_funsig (fsig: funsig) :=
Tfunction (type_of_params (fst fsig)) (snd fsig) cc_default.
Definition fn_funsig (f: function) : funsig := (fn_params f, fn_return f).
Definition tc_fn_return (Delta: tycontext) (ret: option ident) (t: type) :=
match ret with
| None => True
| Some i => match (temp_types Delta) ! i with Some t' => t=t' | _ => False end
end.
Definition globals_only (rho: environ) : environ :=
mkEnviron (ge_of rho) (Map.empty _) (Map.empty _).
Fixpoint make_args (il: list ident) (vl: list val) (rho: environ)  :=
match il, vl with
| nil, nil => globals_only rho
| i::il', v::vl' => env_set (make_args il' vl' rho) i v
| _ , _ => rho
end.
Definition make_args' (fsig: funsig) args rho :=
make_args (map (@fst _ _) (fst fsig)) (args rho) rho.
Definition ret_temp : ident := 1%positive.
Definition get_result1 (ret: ident) (rho: environ) : environ :=
make_args (ret_temp::nil) (eval_id ret rho :: nil) rho.
Definition get_result (ret: option ident) : environ -> environ :=
match ret with
| None => make_args nil nil
| Some x => get_result1 x
end.
Definition maybe_retval (Q: environ -> mpred) retty ret :=
match ret with
| Some id => fun rho => Q (get_result1 id rho)
| None =>
match retty with
| Tvoid => (fun rho => Q (globals_only rho))
| _ => fun rho => EX v: val, Q (make_args (ret_temp::nil) (v::nil) rho)
end
end.
Definition bind_ret (vl: option val) (t: type) (Q: environ -> mpred) : environ -> mpred :=
match vl, t with
| None, Tvoid =>`Q (make_args nil nil)
| Some v, _ => @andp (environ->mpred) _ (!! tc_val t v)
(`Q (make_args (ret_temp::nil) (v::nil)))
| _, _ => FF
end.
Definition overridePost  (Q: environ->mpred)  (R: ret_assert) :=
match R with
{| RA_normal := _; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := Q; RA_break := b; RA_continue := c; RA_return := r |}
end.
Definition existential_ret_assert {A: Type} (R: A -> ret_assert) :=
{| RA_normal := fun rho => EX x:A, (R x).(RA_normal) rho;
RA_break := fun rho => EX x:A, (R x).(RA_break) rho;
RA_continue := fun rho => EX x:A, (R x).(RA_continue) rho;
RA_return := fun vl rho => EX x:A, (R x).(RA_return) vl rho
|}.
Definition normal_ret_assert (Q: environ->mpred) : ret_assert :=
{| RA_normal := Q; RA_break := seplog.FF; RA_continue := seplog.FF; RA_return := fun _ => seplog.FF |}.
Definition frame_ret_assert (R: ret_assert) (F: environ->mpred) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := n * F;
RA_break := b * F;
RA_continue := c * F;
RA_return := fun vl => r vl * F |}
end.
Definition switch_ret_assert (R: ret_assert) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := FF;
RA_break := n;
RA_continue := c;
RA_return := r |}
end.
Definition with_ge (ge: genviron) (G: environ->mpred) : mpred :=
G (mkEnviron ge (Map.empty _) (Map.empty _)).
Fixpoint prog_funct' {F V} (l: list (ident * globdef F V)) : list (ident * F) :=
match l with nil => nil | (i,Gfun f)::r => (i,f):: prog_funct' r | _::r => prog_funct' r
end.
Definition prog_funct (p: program) := prog_funct' (prog_defs p).
Fixpoint prog_vars' {F V} (l: list (ident * globdef F V)) : list (ident * globvar V) :=
match l with nil => nil | (i,Gvar v)::r => (i,v):: prog_vars' r | _::r => prog_vars' r
end.
Definition prog_vars (p: program) := prog_vars' (prog_defs p).
Definition all_initializers_aligned (prog: program) :=
forallb (fun idv => andb (initializers_aligned 0 (gvar_init (snd idv)))
(Zlt_bool (init_data_list_size (gvar_init (snd idv))) Ptrofs.modulus))
(prog_vars prog) = true.
Definition loop1_ret_assert (Inv: environ->mpred) (R: ret_assert) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := Inv;
RA_break := n;
RA_continue := Inv;
RA_return := r |}
end.
Definition loop2_ret_assert (Inv: environ->mpred) (R: ret_assert) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := Inv;
RA_break := n;
RA_continue := seplog.FF;
RA_return := r |}
end.
Definition function_body_ret_assert (ret: type) (Q: environ->mpred) : ret_assert :=
{| RA_normal := bind_ret None ret Q;
RA_break := seplog.FF;
RA_continue := seplog.FF;
RA_return := fun vl => bind_ret vl ret Q |}.
Definition loop_nocontinue_ret_assert (Inv: environ->mpred) (R: ret_assert) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := Inv;
RA_break := n;
RA_continue := seplog.FF;
RA_return := r |}
end.
Definition tc_environ (Delta: tycontext) : environ -> Prop :=
fun rho => typecheck_environ Delta rho.
Definition tc_temp_id  (id: ident)  (ty: type) {CS: compspecs} (Delta: tycontext)
(e:expr): environ -> mpred :=
denote_tc_assert (typecheck_temp_id id ty Delta e).
(* TODO: remove this kind of definitions. *)
Definition typeof_temp (Delta: tycontext) (id: ident) : option type :=
match (temp_types Delta) ! id with
| Some t => Some t
| None => None
end.
Definition tc_expr {CS: compspecs} (Delta: tycontext) (e: expr) : environ -> mpred :=
denote_tc_assert (typecheck_expr Delta e).
Definition tc_exprlist {CS: compspecs} (Delta: tycontext) (t: list type) (e: list expr)  : environ -> mpred :=
denote_tc_assert (typecheck_exprlist Delta t e).
Definition tc_lvalue {CS: compspecs} (Delta: tycontext) (e: expr) : environ -> mpred :=
denote_tc_assert (typecheck_lvalue Delta e).
Definition tc_expropt {CS: compspecs} Delta (e: option expr) (t: type) : environ -> mpred :=
match e with None => `!!(t=Tvoid)
| Some e' => tc_expr Delta (Ecast e' t)
end.
Definition is_comparison op :=
match op with
| Cop.Oeq | Cop.One | Cop.Olt | Cop.Ogt | Cop.Ole | Cop.Oge => true
| _ => false
end.
Definition blocks_match op v1 v2  :=
match op with Cop.Olt | Cop.Ogt | Cop.Ole | Cop.Oge =>
match v1, v2 with
Vptr b _, Vptr b2 _ => b=b2
| _, _ => False
end
| _ => True
end.
Definition cmp_ptr_no_mem c v1 v2  :=
match v1, v2 with
Vptr b o, Vptr b1 o1 =>
if peq b b1 then
Val.of_bool (Ptrofs.cmpu c o o1)
else
match Val.cmp_different_blocks c with
| Some b => Val.of_bool b
| None => Vundef
end
| _, _ => Vundef
end.
Definition op_to_cmp cop :=
match cop with
| Cop.Oeq => Ceq | Cop.One =>  Cne
| Cop.Olt => Clt | Cop.Ogt =>  Cgt
| Cop.Ole => Cle | Cop.Oge =>  Cge
| _ => Ceq (*doesn't matter*)
end.
Fixpoint arglist (n: positive) (tl: typelist) : list (ident*type) :=
match tl with
| Tnil => nil
| Tcons t tl' => (n,t):: arglist (n+1)%positive tl'
end.
Definition closed_wrt_modvars c (F: environ->mpred) : Prop :=
closed_wrt_vars (modifiedvars c) F.
Definition initblocksize (V: Type)  (a: ident * globvar V)  : (ident * Z) :=
match a with (id,l) => (id , init_data_list_size (gvar_init l)) end.
Definition main_pre {Z: Type} (prog: program) (ora: Z) : list Type -> globals -> environ -> mpred :=
(fun nil gv rho => globvars2pred gv (prog_vars prog) rho * has_ext ora).
Definition main_post (prog: program) : list Type -> (ident->val) -> environ->mpred :=
(fun nil _ _ => TT).
Definition main_spec_ext' {Espec: OracleKind} (prog: program) (ora: OK_ty)
(post: list Type -> globals -> environ -> mpred): funspec :=
mk_funspec (nil, tint) cc_default
(rmaps.ConstType globals) (main_pre prog ora) post
(const_super_non_expansive _ _) (const_super_non_expansive _ _).
Definition main_spec_ext {Espec: OracleKind} (prog: program) (ora: OK_ty) : funspec :=
mk_funspec (nil, tint) cc_default
(rmaps.ConstType globals) (main_pre prog ora) (main_post prog)
(const_super_non_expansive _ _) (const_super_non_expansive _ _).
Fixpoint match_globvars (gvs: list (ident * globvar type)) (V: varspecs) : bool :=
match V with
| nil => true
| (id,t)::V' => match gvs with
| nil => false
| (j,g)::gvs' => if eqb_ident id j
then andb (eqb_type t (gvar_info g)) (match_globvars gvs' V')
else match_globvars gvs' V
end
end.
Definition int_range (sz: intsize) (sgn: signedness) (i: int) :=
match sz, sgn with
| I8, Signed => -128 <= Int.signed i < 128
| I8, Unsigned => 0 <= Int.unsigned i < 256
| I16, Signed => -32768 <= Int.signed i < 32768
| I16, Unsigned => 0 <= Int.unsigned i < 65536
| I32, Signed => -2147483648 <= Int.signed i < 2147483648
| I32, Unsigned => 0 <= Int.unsigned i < 4294967296
| IBool, _ => 0 <= Int.unsigned i < 256
end.

Lemma typecheck_expr_sound {CS: compspecs} :
forall Delta rho e,
typecheck_environ Delta rho ->
tc_expr Delta e rho |-- !! tc_val (typeof e) (eval_expr e rho).