Require Export VST.veric.expr.
(** Denotation functions for each of the assertions that can be produced by the typechecker **)
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)
| 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)
| 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 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.
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 => `andp (denote_tc_assert b) (denote_tc_assert c)
| 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 l => `(denote_tc_lgt l) (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.

Lemma tc_andp_sound : forall {CS: compspecs} a1 a2 rho m,
denote_tc_assert  (tc_andp a1 a2) rho m <->
denote_tc_assert  (tc_andp' a1 a2) rho m.