Require Export VST.veric.base.
Require Export VST.veric.shares.
Require Export VST.veric.seplog.
Require Export VST.veric.mapsto_memory_block.
Local Open Scope pred.
Require Export VST.veric.Clight_mapsto_memory_block.
Local Open Scope pred.
(*Definition expr_true (e: Clight.expr) (rho: environ): Prop := bool_val (eval_expr e rho) (Clight.typeof e) = Some true.*)
Definition expr_true {CS: compspecs} e := lift1 (typed_true (typeof e)) (eval_expr e).
Definition expr_false {CS: compspecs} e := lift1 (typed_false (typeof e)) (eval_expr e).
(* Definition fun_assert: forall (fml: funsig) cc (A: TypeTree) (P Q: forall ts, dependent_type_functor_rec ts (AssertTT A) (pred rmap)) (v: val) , pred rmap := res_predicates.fun_assert. *)
Definition eval_lvar (id: ident) (ty: type) (rho: environ) :=
match Map.get (ve_of rho) id with
| Some (b, ty') => if eqb_type ty ty' then Vptr b Ptrofs.zero else Vundef
| None => Vundef
end.
Definition var_block (sh: Share.t) {cs: compspecs} (idt: ident * type) (rho: environ): mpred :=
!! (sizeof (snd idt) <= Ptrofs.max_unsigned) &&
(memory_block sh (sizeof (snd idt))) (eval_lvar (fst idt) (snd idt) rho).
Definition stackframe_of {cs: compspecs} (f: Clight.function) : assert :=
fold_right (fun P Q rho => P rho * Q rho) (fun rho => emp) (map (fun idt => var_block Share.top idt) (Clight.fn_vars f)).
(* Definition stackframe_of (f: Clight.function) : assert := fun rho => sepcon_list (map (fun idt => var_block Share.top idt rho) (Clight.fn_vars f)). *)
Definition tc_formals (formals: list (ident * type)) : environ -> Prop :=
fun rho => tc_vals (map (@snd _ _) formals) (map (fun xt => (eval_id (fst xt) rho)) formals).
(*This definition, and lemma close_precondition_i below, could be moved to general_seplog*)
Program Definition close_precondition (specparams bodyparams: list ident) (P: environ -> pred rmap) (rho: environ) : pred rmap :=
fun phi =>
exists ve', exists te',
(forall n i j, nth_error specparams n = Some i ->
nth_error bodyparams n = Some j ->
Map.get te' i = Map.get (te_of rho) j) /\
app_pred (P (mkEnviron (ge_of rho) ve' te')) phi.
Next Obligation.
intros.
intro; intros.
destruct H0 as [ve' [te' [? ?]]]; exists ve',te'; split; auto.
eapply pred_hereditary; eauto.
Qed.
Definition precondition_closed (fs: list (ident*type)) {A: TypeTree}
(P: forall ts, 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 bind_args (specparams bodyparams: list (ident * type)) (P: environ -> pred rmap) : assert :=
fun rho => !! tc_formals bodyparams rho
&& close_precondition (map fst specparams) (map fst bodyparams) P 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 bind_ret (vl: option val) (t: type) (Q: assert) : assert :=
match vl, t with
| None, Tvoid => fun rho => Q (make_args nil nil rho)
| Some v, _ => fun rho => !! (tc_val t v) &&
Q (make_args (ret_temp::nil) (v::nil) rho)
| _, _ => fun rho => FF
end.
Definition funassert (Delta: tycontext): assert := funspecs_assert (glob_specs Delta).
(* Unfortunately, we need core_load in the interface as well as address_mapsto, because the converse of 'mapsto_core_load' lemma is not true.  The reason is that core_load could imply partial ownership of the four bytes of the word using different shares that don't have a common core, whereas address_mapsto requires the same share on all four bytes. *)
(* Record ret_assert : Type := { RA_normal: assert; RA_break: assert; RA_continue: assert; RA_return: option val -> assert }. *)
Definition proj_ret_assert (Q: ret_assert) (ek: exitkind) (vl: option val) : assert :=
match ek with
| EK_normal => fun rho => !! (vl=None) && RA_normal Q rho
| EK_break => fun rho => !! (vl=None) && RA_break Q rho
| EK_continue => fun rho => !! (vl=None) && RA_continue Q rho
| EK_return => RA_return Q vl
end.
(* Definition ret_assert := exitkind -> option val -> assert. *)
Definition overridePost  (Q: assert)  (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: assert) : 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: assert) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := fun rho => n rho * F rho;
RA_break := fun rho => b rho * F rho;
RA_continue := fun rho => c rho * F rho;
RA_return := fun vl rho => r vl rho * F rho |}
end.
Definition conj_ret_assert (R: ret_assert) (F: assert) : ret_assert :=
match R with
{| RA_normal := n; RA_break := b; RA_continue := c; RA_return := r |} =>
{| RA_normal := fun rho => n rho && F rho;
RA_break := fun rho => b rho && F rho;
RA_continue := fun rho => c rho && F rho;
RA_return := fun vl rho => r vl rho && F rho |}
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 := seplog.FF;
RA_break := n;
RA_continue := c;
RA_return := r |}
end.

Lemma normal_ret_assert_derives:
forall P Q rho,
P rho |-- Q rho ->
forall ek vl, proj_ret_assert (normal_ret_assert P) ek vl rho
|-- proj_ret_assert (normal_ret_assert Q) ek vl rho.