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.
Hint Rewrite prop_true_andp1 using solve [auto 3 with typeclass_instances]: norm1.
Hint Rewrite prop_true_andp1 using assumption : norm.
Ltac splittablex_tac A :=
match A with
| _ <= _ < _ => fail 1
| _ < _ <= _ => fail 1
| _ <= _ <= _ => fail 1
| _ < _ < _ => fail 1
| _ <-> _ => fail 1
| _ /\ _ => apply Logic.I
end.
Definition splittablex (A: Prop) := True.
Hint Rewrite and_assoc_splittablex using
match goal with |- splittablex ?A => splittablex_tac A end : normalize.
Hint Rewrite and_assoc_splittablex using
match goal with |- splittablex ?A => splittablex_tac A end : gather_prop.
(* Hint Rewrite @and_assoc'' using solve [auto with typeclass_instances] : norm1. Hint Rewrite @and_assoc'' using solve [auto with typeclass_instances] : gather_prop. *)
Ltac hoist_later_left :=
match goal with
| |- (?P |-- _) =>
let P' := strip1_later P in
apply derives_trans with (|>P');
[ solve [ auto 50 with derives ] | ]
end.
Ltac hoist_later_in_pre :=
match goal with |- semax _ ?P _ _ =>
match P with
| context[@later] =>
let P' := strip1_later P in apply semax_pre0 with (|> P'); [solve [auto 50 with derives] | ]
| _ => apply semax_later_trivial
end
end.
Ltac type_of_field_tac :=
simpl;
repeat first [rewrite if_true by auto
| rewrite if_false by (let H:=fresh in intro H; inversion H)
| simpl; reflexivity].
Ltac simpl_tc_expr :=
match goal with |- context [tc_expr ?A ?B] =>
change (tc_expr A B) with (denote_tc_assert (typecheck_expr A B));
simpl typecheck_expr; simpl denote_tc_assert
end.
Hint Rewrite prop_and1 using solve [auto 3 with typeclass_instances] : norm2.
Hint Rewrite @subst_make_args' using (solve[reflexivity]) : subst.
Hint Rewrite @subst_stackframe_of : subst.
Fixpoint iota_formals (i: ident) (tl: typelist) :=
match tl with
| Tcons t tl' => (i,t) :: iota_formals (i+1)%positive tl'
| Tnil => nil
end.
Ltac make_sequential :=
match goal with
| |- @semax _ _ _ _ _ (normal_ret_assert _) => idtac
| |- _ => apply sequential
end.
Ltac intro_if_new :=
repeat match goal with
| |- ?A -> _ => ((assert A by auto; fail 1) || fail 1) || intros _
| |- (_ <-> _) -> _ =>
intro
| |- (?A /\ ?B) -> ?C =>
apply (@and_ind A B C)
| |- isptr (force_ptr ?P) -> ?Q =>
apply (isptr_force_ptr'' P Q)
| |- isptr (offset_val ?i ?P) -> ?Q =>
apply (isptr_offset_val'' i P Q)
| H: is_pointer_or_null ?P |- isptr ?P -> _ =>
clear H
| |- ?x = ?y -> _ =>
let H := fresh in intro H;
first [subst x | subst y
| is_var x; rewrite H
| is_var y; rewrite <- H
| solve [discriminate H]
| idtac]
| |- isptr ?x -> _ =>
let H := fresh "P" x in intro H
| |- is_pointer_or_null ?x =>
let H := fresh "PN" x in intro H
| |- typed_false _ (Val.of_bool _) -> _ =>
simple apply typed_false_of_bool'
| |- typed_true _ (Val.of_bool _) -> _ =>
simple apply typed_true_of_bool'
| |- ptr_eq _ _ -> _ =>
apply ptr_eq_e'
| |- _ -> _ =>
intro
end.
Ltac already_saturated :=
(match goal with |- ?P |-- ?Q =>
let H := fresh in
assert (H: P |-- Q) by auto with nocore saturate_local;
cbv beta in H;
match type of H with _ |-- !! ?Q' =>
assert (Q') by (repeat simple apply conj; auto);
fail 3
end
end || auto with nocore saturate_local)
|| simple apply prop_True_right.
Ltac check_mpreds2 R :=
lazymatch R with
| @sepcon mpred _ _ ?a ?b => check_mpreds2 a; check_mpreds2 b
| _ => match type of R with ?t =>
first [constr_eq t mpred
| fail 10 "The conjunct" R "has type" t "but should have type mpred; these two types may be convertible but they are not identical"]
end
| nil => idtac
end.
Ltac saturate_local :=
match goal with |- ?R |-- _ => check_mpreds2 R end;
simple eapply saturate_aux21x;
[repeat simple apply saturate_aux20;
(* use already_saturated if want to be fancy, otherwise the next lines *)
auto with nocore saturate_local;
simple apply prop_True_right
(* | cbv beta; reflexivity    this line only for use with saturate_aux21 *)
| simple apply derives_extract_prop;
match goal with |- _ -> ?A =>
let P := fresh "P" in set (P := A);
fancy_intros true;
subst P
end
].
(*********************************************************)
Ltac prop_right_cautious :=
try solve [simple apply prop_right; auto].
(**********************************************************)
(* testing Parameter f: nat -> Prop. Parameter g h : mpred.  Goal ( !! f 1 && ((h && !! f 2) && h ) && (!! f 3 && (g && (!!f 4 && !! f 5) && !! f 6)) |-- FF).  *)
(*****************************************************************)
Ltac subst_any :=
repeat match goal with
| H: ?x = ?y |- _ => first [ subst x | subst y ]
end.
Ltac solve_mod_eq :=
unfold Int.add, Int.mul;
repeat rewrite Int.unsigned_repr_eq;
repeat
(repeat rewrite Zmod_mod;
repeat rewrite Zmult_mod_idemp_l;
repeat rewrite Zmult_mod_idemp_r;
repeat rewrite Zplus_mod_idemp_l;
repeat rewrite Zplus_mod_idemp_r).
Hint Rewrite wand_sepcon wand_sepcon' : norm.
Ltac extract_exists_in_SEP' PQR :=
match PQR with
| PROPx ?P (LOCALx ?Q (SEPx (?R))) =>
match R with context [(@exp _ _ ?A ?S) :: ?R'] =>
let n := constr:((length R - Datatypes.S (length R'))%nat) in
let n' := eval lazy beta zeta iota delta in n in
rewrite (@extract_nth_exists_in_SEP n' P Q R A S (eq_refl _));
unfold replace_nth at 1;
rewrite ?exp_andp2
end
end.
Ltac extract_exists_from_SEP :=
match goal with
| |- semax _ ?Pre _ _ =>
extract_exists_in_SEP' Pre; apply extract_exists_pre
| |- _ && ?Pre |-- ?Post =>
let P := fresh "POST" in set (P := Post);
extract_exists_in_SEP' Pre; subst P; apply exp_left
| |- ?Pre |-- ?Post => (* this case is obsolete, should probably be deleted *)
let P := fresh "POST" in set (P := Post);
extract_exists_in_SEP' Pre; subst P; apply exp_left
end.
Ltac move_from_SEP' PQR :=
match PQR with
| PROPx ?P (LOCALx ?Q (SEPx (?R))) =>
match R with context [(prop ?P1 && ?S) :: ?R'] =>
let n := constr:((length R - Datatypes.S (length R'))%nat) in
let n' := eval lazy beta zeta iota delta in n in
rewrite(@extract_prop_in_SEP n' P1 S P Q R (eq_refl _));
unfold replace_nth at 1
end
end.

Lemma derives_extract_PROP' :
forall (P1: Prop) P QR S,
(P1 -> PROPx P QR |-- S) ->
PROPx (P1::P) QR |-- S.