Module ConseqFacts :=
SeparationLogicFacts.GenConseqFacts
(SeparationLogicAsLogicSoundness.MainTheorem.CSHL_PracticalLogic.CSHL_MinimumLogic.CSHL_Def)
(Conseq).
(* OLD VERSION: Lemma semax_post': forall R' Espec {cs: compspecs} Delta R P c, R' |-- R -> @semax cs Espec Delta P c (normal_ret_assert R') -> @semax cs Espec Delta P c (normal_ret_assert R). *)
intros.
destruct Q as [?Q ?Q ?Q ?Q].
eapply semax_post; eauto; intros; apply andp_left2; simpl; auto; normalize.
Qed.
Ltac frame_SEP' L :=  (* this should be generalized to permit framing on LOCAL part too *)
grab_indexes_SEP L;
match goal with
| |- @semax _ _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
rewrite <- (firstn_skipn (length L) R);
simpl length; unfold firstn, skipn;
eapply (semax_frame_PQR nil);
[ unfold closed_wrt_modvars;  auto 50 with closed
| ]
| |- ENTAIL _ , (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
rewrite <- (firstn_skipn (length L) R);
simpl length; unfold firstn, skipn;
apply derives_frame_PQR
end.
Tactic Notation "frame_SEP" constr(a) :=
frame_SEP' (a::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) :=
frame_SEP' (a::b::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) :=
frame_SEP' (a::b::c::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) :=
frame_SEP' (a::b::c::d::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) :=
frame_SEP' (a::b::c::d::e::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) :=
frame_SEP' (a::b::c::d::e::f::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) :=
frame_SEP' (a::b::c::d::e::f::g::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) :=
frame_SEP' (a::b::c::d::e::f::g::h::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) :=
frame_SEP' (a::b::c::d::e::f::g::h::i::nil).
Tactic Notation "frame_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) :=
frame_SEP' (a::b::c::d::e::f::g::h::i::j::nil).
Ltac gather_SEP' L :=
grab_indexes_SEP L;
match goal with |- context [SEPx ?R] =>
let r := fresh "R" in
set (r := (SEPx R));
revert r;
rewrite <- (firstn_skipn (length L) R);
unfold length at 1 2;
unfold firstn at 1; unfold skipn at 1;
rewrite gather_SEP;
unfold fold_right at 1; try  rewrite sepcon_emp;
try (intro r; unfold r; clear r)
end.
(* replaced by the new gather_SEP in freezer.v ... Tactic Notation "gather_SEP" constr(a) := gather_SEP' (a::nil). Tactic Notation "gather_SEP" constr(a) constr(b) := gather_SEP' (a::b::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) := gather_SEP' (a::b::c::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) := gather_SEP' (a::b::c::d::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) := gather_SEP' (a::b::c::d::e::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) := gather_SEP' (a::b::c::d::e::f::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) := gather_SEP' (a::b::c::d::e::f::g::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) := gather_SEP' (a::b::c::d::e::f::g::h::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) := gather_SEP' (a::b::c::d::e::f::g::h::i::nil). Tactic Notation "gather_SEP" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) := gather_SEP' (a::b::c::d::e::f::g::h::i::j::nil). *)
Fixpoint replace_nth {A} (n: nat) (al: list A) (x: A) {struct n}: list A :=
match n, al with
| O , a::al => x::al
| S n', a::al' => a :: replace_nth n' al' x
| _, nil => nil
end.
Fixpoint my_nth{A} (n: nat) (al: list A) (default: A) {struct n} : A :=
(* just like nth; make a new copy, for better control of unfolding *)
match n, al with
| O, a::al' => a
| S n', a::al' => my_nth n' al' default
| _, nil => default
end.
Tactic Notation "replace_SEP" constr(n) constr(R) :=
first [apply (replace_SEP' (Z.to_nat n) R) | apply (replace_SEP'' (Z.to_nat n) R)];
unfold my_nth,replace_nth; simpl Z.to_nat;
repeat simpl_nat_of_P; cbv beta iota; cbv beta iota.
Tactic Notation "replace_SEP" constr(n) constr(R) "by" tactic1(t):=
first [apply (replace_SEP' (Z.to_nat n) R) | apply (replace_SEP'' (Z.to_nat n) R)];
unfold my_nth,replace_nth; simpl Z.to_nat;
repeat simpl_nat_of_P; cbv beta iota; cbv beta iota; [ now t | ].
Tactic Notation "viewshift_SEP" constr(n) constr(R) :=
first [apply (replace_SEP'_bupd (Z.to_nat n) R) | apply (replace_SEP''_bupd (Z.to_nat n) R)];
unfold my_nth,replace_nth; simpl Z.to_nat;
repeat simpl_nat_of_P; cbv beta iota; cbv beta iota.
Tactic Notation "viewshift_SEP" constr(n) constr(R) "by" tactic1(t):=
first [apply (replace_SEP'_bupd (Z.to_nat n) R) | apply (replace_SEP''_bupd (Z.to_nat n) R)];
unfold my_nth,replace_nth; simpl Z.to_nat;
repeat simpl_nat_of_P; cbv beta iota; cbv beta iota; [ now t | ].
Ltac replace_in_pre S S' :=
match goal with |- @semax _ _ _ ?P _ _ =>
match P with context C[S] =>
let P' := context C[S'] in
apply semax_pre with P'; [ | ]
end
end.
Hint Resolve PROP_later_derives LOCAL_later_derives SEP_later_derives : derives.
Hint Rewrite @local_lift0: norm2.
Ltac repeat_extract_exists_pre :=
first [(apply extract_exists_pre;
let x := fresh "x" in intro x; normalize;
repeat_extract_exists_pre;
revert x)
| autorewrite with canon
].
Ltac extract_exists_in_SEP :=
match goal with |- @semax _ _ _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
match R with context [ exp ?z :: _] =>
let n := find_in_list (exp z) R
in rewrite (grab_nth_SEP n); unfold nth, delete_nth; rewrite extract_exists_in_SEP;
repeat_extract_exists_pre
end
end.
Ltac flatten_in_SEP PQR :=
match PQR with
| PROPx ?P (LOCALx ?Q (SEPx (?R))) =>
match R with context [(?R1 * ?R2) :: ?R'] =>
let n := constr:((length R - Datatypes.S (length R'))%nat) in
let n' := eval lazy beta zeta iota delta in n in
erewrite(@flatten_sepcon_in_SEP'' n' P Q R1 R2 R _ (eq_refl _));
[ |
let RR := fresh "RR" in set (RR := R);
let RR1 := fresh "RR1" in set (RR1 := R1);
let RR2 := fresh "RR2" in set (RR2 := R2);
unfold firstn, app, skipn; subst RR RR1 RR2; cbv beta iota;
apply eq_refl
]
end
end.
Ltac flatten_sepcon_in_SEP :=
match goal with
| |- semax _ ?PQR _ _ => flatten_in_SEP PQR
| |-  ENTAIL _, ?PQR |-- _ => flatten_in_SEP PQR
end.
Ltac delete_emp_in_SEP :=
repeat
match goal with |- context [SEPx ?R] =>
match R with context [emp:: ?R'] =>
rewrite (delete_emp_in_SEP (length R - S (length R')) R) by reflexivity;
simpl length; simpl minus; unfold firstn, app, list_drop; fold app
end
end.
Ltac move_from_SEP :=
(* combines extract_exists_in_SEP, move_prop_from_SEP, (*move_local_from_SEP, *)
flatten_sepcon_in_SEP *)
match goal with |- context [PROPx _ (LOCALx _ (SEPx ?R))] =>
match R with
| context [(prop ?P1 && ?Rn) :: ?R'] =>
let n := length_of R in let n' := length_of R' in
rewrite (extract_prop_in_SEP (n-S n')%nat P1 Rn) by reflexivity;
simpl minus; unfold replace_nth (*;
try (apply semax_extract_PROP; intro)*)
| context [ exp ?z :: _] =>
let n := find_in_list (exp z) R
in rewrite (grab_nth_SEP n); unfold nth, delete_nth; rewrite extract_exists_in_SEP;
repeat_extract_exists_pre
| context [ (sepcon ?x  ?y) :: ?R'] =>
let n := length_of R in let n' := length_of R' in
rewrite (grab_nth_SEP (n-S n')); simpl minus; unfold nth, delete_nth;
rewrite flatten_sepcon_in_SEP
end
end.
(* Hint Rewrite move_prop_from_SEP move_local_from_SEP : norm. *)
Tactic Notation "assert_PROP" constr(A) :=
first [apply (assert_later_PROP A) | apply (assert_PROP A) | apply (assert_PROP' A)]; [ | intro ].
Tactic Notation "assert_PROP" constr(A) "by" tactic1(t) :=
first [apply (assert_later_PROP A) | apply (assert_PROP A) | apply (assert_PROP' A) ]; [ now t | intro ].
Tactic Notation "assert_PROP" constr(A) "as" simple_intropattern(H)  :=
first [apply (assert_later_PROP A) | apply (assert_PROP A) | apply (assert_PROP' A)]; [ | intro H ].
Tactic Notation "assert_PROP" constr(A) "as" simple_intropattern(H) "by" tactic1(t) :=
first [apply (assert_later_PROP A) | apply (assert_PROP A) | apply (assert_PROP' A)]; [ now t | intro H ].
Tactic Notation "assert_LOCAL" constr(A) :=
apply (assert_LOCAL A).
Tactic Notation "assert_LOCAL" constr(A) "by" tactic1(t) :=
apply (assert_LOCAL A); [ now t | ].
Ltac drop_LOCAL n :=
first [apply (drop_LOCAL n) | apply (drop_LOCAL' n) | apply (drop_LOCAL'' n)];
unfold delete_nth.
Fixpoint find_LOCAL_index (name: ident) (current: nat) (l : list localdef) : option nat :=
match l with
| h :: t => match h with
| temp  i _   => if (i =? name)%positive then Some current else find_LOCAL_index name (S current) t
| lvar  i _ _ => if (i =? name)%positive then Some current else find_LOCAL_index name (S current) t
| gvars _ => find_LOCAL_index name (S current) t
end
| nil => None
end.
Ltac drop_LOCAL_by_name name := match goal with
| |- semax _ (PROPx ?P (LOCALx ?Q (SEPx ?R))) _ _ =>
let r := eval hnf in (find_LOCAL_index name O Q) in match r with
| Some ?i => drop_LOCAL i
| None => fail 1 "No variable named" name "found"
end
end.
Ltac drop_LOCALs l := match l with
| ?h :: ?t => drop_LOCAL_by_name h; drop_LOCALs t
| nil => idtac
end.
Ltac clean_up_app_carefully := (* useful after rewriting by SEP_PROP *)
repeat
match goal with
| |- context [@app Prop (?a :: ?b) ?c] =>
change (app (a::b) c) with (a :: app b c)
| |- context [@app (environ->Prop) (?a :: ?b) ?c] =>
change (app (a::b) c) with (a :: app b c)
| |- context [@app (lifted (LiftEnviron Prop)) (?a :: ?b) ?c] =>
change (app (a::b) c) with (a :: app b c)
| |- context [@app (environ->mpred) (?a :: ?b) ?c] =>
change (app (a::b) c) with (a :: app b c)
| |- context [@app (lifted (LiftEnviron mpred)) (?a :: ?b) ?c] =>
change (app (a::b) c) with (a :: app b c)
| |- context [@app Prop nil ?c] =>
change (app nil c) with c
| |- context [@app (environ->Prop) nil ?c] =>
change (app nil c) with c
| |- context [@app (lifted (LiftEnviron Prop)) nil ?c] =>
change (app nil c) with c
| |- context [@app (lifted (environ->mpred)) nil ?c] =>
change (app nil c) with c
| |- context [@app (lifted (LiftEnviron mpred)) nil ?c] =>
change (app nil c) with c
end.
Definition not_conj_notation (P: Prop) := True.
Ltac not_conj_notation :=
match goal with
| |- not_conj_notation (_ <= _ <= _)%Z => fail 1
| |- not_conj_notation (_ <= _ < _)%Z => fail 1
| |- not_conj_notation (_ < _ <= _)%Z => fail 1
| |- not_conj_notation (_ <= _ <= _)%nat => fail 1
| |- not_conj_notation (_ <= _ < _)%nat => fail 1
| |- not_conj_notation (_ < _ <= _)%nat => fail 1
| |- _ => apply Coq.Init.Logic.I
end.
Hint Rewrite split_first_PROP using not_conj_notation : norm1.
Tactic Notation "semax_frame" constr(Qframe) constr(Rframe) :=
first
[ simple eapply (semax_frame_perm Qframe Rframe);
[auto 50 with closed | solve_perm | solve_perm | unfold app; fold @app ]
| eapply semax_post_flipped';
[simple eapply (semax_frame_perm Qframe Rframe);
[auto 50 with closed | solve_perm | solve_perm | unfold app; fold @app ]
| try solve [apply perm_derives; solve_perm]]
].
Tactic Notation "semax_frame" "[" "]" constr(Rframe) :=
first
[ simple eapply (semax_frame_perm nil Rframe);
[auto 50 with closed | solve_perm | solve_perm | unfold app; fold @app ]
| eapply semax_post_flipped';
[simple eapply (semax_frame_perm nil Rframe);
[auto 50 with closed | solve_perm | solve_perm | unfold app; fold @app ]
| try solve [apply perm_derives; solve_perm]]
].
Definition is_void_type (ty: type) : bool :=
match ty with Tvoid => true | _ => false end.
Definition ret_tycon (Delta: tycontext): tycontext :=
mk_tycontext
(if is_void_type (ret_type Delta)
then (PTree.empty _)
else (PTree.set ret_temp (ret_type Delta) (PTree.empty _)))
(PTree.empty _)
(ret_type Delta)
(glob_types Delta)
(glob_specs Delta)
(annotations Delta).
Definition ret0_tycon (Delta: tycontext): tycontext :=
mk_tycontext (PTree.empty _) (PTree.empty _) (ret_type Delta) (glob_types Delta) (glob_specs Delta) (annotations Delta).
Definition ret1_tycon (Delta: tycontext): tycontext :=
mk_tycontext (PTree.set ret_temp (ret_type Delta) (PTree.empty _))
(PTree.empty _) (ret_type Delta) (glob_types Delta) (glob_specs Delta) (annotations Delta).
Inductive return_outer_gen: ret_assert -> ret_assert -> Prop :=
| return_outer_gen_refl: forall P t sf,
return_outer_gen
(frame_ret_assert (function_body_ret_assert t P) sf)
(frame_ret_assert (function_body_ret_assert t P) sf)
| return_outer_gen_switch: forall P Q,
return_outer_gen P Q ->
return_outer_gen (switch_ret_assert P) Q
| return_outer_gen_post: forall post P Q,
return_outer_gen P Q ->
return_outer_gen (overridePost post P) Q
| return_outer_gen_for: forall P' P Q,
return_outer_gen P Q ->
return_outer_gen (for_ret_assert P' P) Q
| return_outer_gen_loop1: forall inv P Q,
return_outer_gen P Q ->
return_outer_gen (loop1_ret_assert inv P) Q
| return_outer_gen_loop1x: forall inv P Q,
return_outer_gen P Q ->
return_outer_gen (loop1x_ret_assert inv P) Q
| return_outer_gen_loop2: forall inv P Q,
return_outer_gen P Q ->
return_outer_gen (loop2_ret_assert inv P) Q.
Inductive return_inner_gen (S: list mpred): option val -> (environ -> mpred) -> (environ -> mpred) -> Prop :=
| return_inner_gen_main: forall ov_gen P ts u,
return_inner_gen S ov_gen (main_post P ts u) (PROPx nil (LOCALx nil (SEPx (TT :: S))))
| return_inner_gen_canon_nil':
forall ov_gen P R,
return_inner_gen S ov_gen
(PROPx P (LOCALx nil (SEPx R)))
(PROPx P (LOCALx nil (SEPx (R ++ S))))
| return_inner_gen_canon_Some':
forall P v R v_gen,
return_inner_gen S (Some v_gen)
(PROPx P (LOCALx (temp ret_temp v :: nil) (SEPx R)))
(PROPx (P ++ (v_gen = v) :: nil) (LOCALx nil (SEPx (R ++ S))))
| return_inner_gen_EX':
forall ov_gen (A: Type) (post1 post2: A -> environ -> mpred),
(forall a: A, return_inner_gen S ov_gen (post1 a) (post2 a)) ->
return_inner_gen S ov_gen (exp post1) (exp post2).

Lemma return_inner_gen_Some_spec: forall S v_gen post1 post2,
v_gen <> Vundef ->
return_inner_gen S (Some v_gen) post1 post2 ->
post2 |-- (fun rho => post1 (make_args (ret_temp :: nil) (v_gen :: nil) rho)) * SEPx S.