Require Export VST.floyd.canon.
Local Open Scope logic.
Ltac refold_right_sepcon R :=
match R with
| @sepcon mpred _ _ ?R1 ?R' => let S := refold_right_sepcon R' in constr: (R1 :: S )
| _ => constr:(R :: nil)
end.
Arguments sem_cmp c !t1 !t2 / v1 v2.
(* The following line should not be needed, and was not needed in Coq 8.3, but in Coq 8.4 it seems to be necessary. *)
Hint Resolve (@LiftClassicalSep environ) : typeclass_instances.
Definition func_ptr' f v := func_ptr f v && emp.
Hint Resolve func_ptr_isptr: saturate_local.
Hint Resolve func_ptr'_isptr: saturate_local.
Hint Rewrite @subst_lift0' : subst.
Hint Rewrite @subst_lift0 (*@subst_lift0'*) @subst_lift0C : subst.
Hint Rewrite @subst_lift1 (*@subst_lift1'*) @subst_lift1C  : subst.
Hint Rewrite @subst_lift2 (*@subst_lift2'*) @subst_lift2C : subst.
Hint Rewrite @subst_lift3 (*@subst_lift3'*) @subst_lift3C : subst.
Hint Rewrite @subst_lift4 (*@subst_lift4'*) @subst_lift4C : subst.
Definition retval : environ -> val := eval_id ret_temp.
Hint Rewrite eval_id_same : norm.
Hint Rewrite eval_id_other using solve [clear; intro Hx; inversion Hx] : norm.
Hint Rewrite simpl_get_result1: norm.
Hint Rewrite retval_get_result1 : norm.
Hint Rewrite retval_ext_rval : norm.
Hint Rewrite retval_lemma1 : norm.
Hint Rewrite retval_make_args: norm2.
Fixpoint fold_right_and P0 (l: list Prop) : Prop :=
match l with
| nil => P0
| b::r => b  /\ fold_right_and P0 r
end.
Fixpoint fold_right_and_True (l: list Prop) : Prop :=
match l with
| nil => True
| b :: nil => b
| b::r => b /\ fold_right_and_True r
end.
Definition fold_right_PROP_SEP (l1: list Prop) (l2: list mpred) : mpred :=
match l1 with
| nil => fold_right_sepcon l2
| l => !! (fold_right_and_True l) && fold_right_sepcon l2
end.
Hint Rewrite typed_true_isptr using apply Coq.Init.Logic.I : norm.
Ltac super_unfold_lift_in H :=
cbv delta [liftx LiftEnviron Tarrow Tend lift_S lift_T
lift_prod lift_last lifted lift_uncurry_open lift_curry lift lift0
lift1 lift2 lift3] beta iota in H.
Ltac super_unfold_lift' :=
cbv delta [liftx LiftEnviron Tarrow Tend lift_S lift_T
lift_prod lift_last lifted lift_uncurry_open lift_curry lift lift0
lift1 lift2 lift3] beta iota.
Definition name (id: ident) := True.
Tactic Notation "name" ident(s) constr(id) :=
assert (s: name id) by apply Coq.Init.Logic.I.
Definition reflect_temps_f (rho: environ) (b: Prop) (i: ident) (t: type) : Prop :=
tc_val' t (eval_id i rho) /\ b.
Definition reflect_temps (Delta: tycontext) (rho: environ) : Prop :=
PTree.fold (reflect_temps_f rho) (temp_types Delta) True.
Definition abbreviate {A:Type} (x:A) := x.
Arguments abbreviate {A} {x}.
Ltac clear_Delta :=
match goal with
| Delta := @abbreviate tycontext ?G |- _ =>
try match goal with |- context [ret_type Delta] =>
let x := constr:(ret_type G) in let x := eval simpl in x
in change (ret_type Delta) with x
end;
repeat match goal with H: context [ret_type Delta] |- _ =>
let x := constr:(ret_type G) in let x := eval simpl in x
in change (ret_type Delta) with x in H
end;
try clear Delta
| _ => idtac
end;
match goal with
|  DS := @abbreviate (PTree.t funspec) _  |- _ =>
first [clear DS | clearbody DS]
| |- _ => idtac
end.
Ltac clear_Delta_specs :=
lazymatch goal with
|  DS := @abbreviate (PTree.t funspec) _  |- _ => clearbody DS
| |- _ => idtac
end.
Ltac findvars :=
match goal with DD: tc_environ ?Delta ?rho |- _ =>
let H := fresh in
assert (H := reflect_temps_valid _ _ DD);
try (unfold Delta in H);
cbv beta iota zeta delta [abbreviate PTree.fold PTree.prev PTree.prev_append PTree.xfold temp_types fst snd
reflect_temps reflect_temps_f] in H;
simpl in H;
repeat match goal with
(*  this clause causes some problems when interacting with make_args' | |- context [eval_var ?J ?T rho] => try fold J in H; let Name := fresh "_id" in forget (eval_var J T rho) as Name *)
| Name: name ?J |- context [eval_id ?J rho] =>
fold J in H;
clear Name;
forget (eval_id J rho) as Name
| |- context [eval_id ?J rho] =>
try fold J in H;
let Name := fresh "_id" in forget (eval_id J rho) as Name
| Name: name _ |- _ =>
clear Name
end;
repeat match type of H with
| _ (eval_id _ _) /\ _ =>  destruct H as [_ H]
| is_int _ _ ?i /\ _ => let TC := fresh "TC" in destruct H as [TC H];
let i' := fresh "id" in rename i into i';
apply is_int_e in TC; destruct TC as [i [? TC]]; subst i';
simpl in TC;
match type of TC with True => clear TC | _ => idtac end
| _ /\ _ => destruct H as [?TC H]
end;
clear H
end.
Hint Rewrite sem_cast_pointer2' using (try apply Coq.Init.Logic.I; try assumption; reflexivity) : norm.
(*            | Vint _ => Some (eval_var i t rho) *)
Hint Rewrite is_pointer_or_null_force_int_ptr using assumption : norm1.
Hint Rewrite is_pointer_force_int_ptr using assumption : norm1.
Hint Rewrite is_pointer_or_null_match using assumption : norm1.
Hint Rewrite is_pointer_force_int_ptr2 using assumption : norm1.
Hint Rewrite is_pointer_or_null_force_int_ptr2 using assumption : norm1.
intros.
unfold is_pointer_or_null.
destruct Archi.ptr64 eqn:Hp;
destruct w0; auto.
Qed.
Hint Rewrite isptr_match : norm1.
Hint Rewrite eval_cast_neutral_tc_val using solve [eauto] : norm.
Hint Rewrite eval_cast_neutral_is_pointer_or_null using assumption : norm.
Hint Rewrite eval_cast_neutral_isptr using assumption : norm.
Arguments ret_type !Delta /.
Arguments Datatypes.id {A} x / .
Hint Rewrite lift_lift_retval: norm2.
Hint Rewrite @lift0_exp : norm2.
Hint Rewrite @lift0C_exp : norm2.
(* Lemma ENTAIL_normal_ret_assert: forall Delta P Q ek vl, (ek = EK_normal -> vl = None -> ENTAIL Delta, P |-- Q) -> ENTAIL Delta, normal_ret_assert P ek vl |-- normal_ret_assert Q ek vl. *)
Hint Rewrite local_sepcon_assoc1 local_sepcon_assoc2 : norm2.
Definition do_canon (x y : environ->mpred) := (sepcon x y).
Ltac strip1_later P :=
match P with
| do_canon ?L ?R => let L' := strip1_later L in let R' := strip1_later R in constr:(do_canon L' R')
| PROPx ?P ?QR => let QR' := strip1_later QR in constr:(PROPx P QR')
| LOCALx ?Q ?R => let R' := strip1_later R in constr:(LOCALx Q R')
| SEPx ?R => let R' := strip1_later R in constr:(SEPx R')
| ?L::?R => let L' := strip1_later L in let R' := strip1_later R in constr:(L'::R')
| nil => constr:(nil)
| ?L && ?R => let L' := strip1_later L in let R' := strip1_later R in constr:(L' && R')
| ?L * ?R => let L' := strip1_later L in let R' := strip1_later R in constr:(L'*R')
| |> ?L => constr:(L)
| ?L => constr:(L)
end.

Lemma andp_later_derives {A} {NA: NatDed A}{IA: Indir A}:
forall P Q P' Q': A, P |-- |> P' -> Q |-- |> Q' -> P && Q |-- |> (P' && Q').