Commit 939de4c3 authored by charguer's avatar charguer

simplification

parent e80bd62d
Set Implicit Arguments.
Require Export LibInt CFSpec CFPrint.
(********************************************************************)
(* ** Lemmas for tactics *)
(** Lemma used by [xframe] *)
Lemma xframe_lemma : forall H1 H2 B Q1 (F:~~B) H Q,
is_local F ->
H ==> H1 \* H2 ->
F H1 Q1 ->
Q1 \*+ H2 ===> Q ->
F H Q.
Proof using. intros. apply* local_wframe. Qed.
(** Lemma used by [xchange] *)
Lemma xchange_lemma : forall H1 H1' H2 B H Q (F:~~B),
is_local F ->
(H1 ==> H1') ->
(H ==> H1 \* H2) ->
F (H1' \* H2) Q ->
F H Q.
Proof using.
introv W1 L W2 M. applys local_wframe __ \[]; eauto.
hsimpl. hchange~ W2. hsimpl~. rew_heap~.
Qed.
(** Lemma used by [xgc_all],
to remove everything from the pre-condition *)
Lemma local_gc_pre_all : forall B Q (F:~~B) H,
is_local F ->
F \[] Q ->
F H Q.
Proof using. intros. apply* (@local_gc_pre H). hsimpl. Qed.
(** Lemma used by [xret] and [xret_no_gc]
for when post-condition unifies trivially *)
Lemma xret_lemma_unify : forall B (v:B) H,
local (fun H' Q' => H' ==> Q' v) H (fun x => \[x = v] \* H).
Proof using.
intros. apply~ local_erase. hsimpl. auto.
Qed.
(** Lemma used by [xret] *)
Lemma xret_lemma : forall HG B (v:B) H (Q:B->hprop),
H ==> Q v \* HG ->
local (fun H' Q' => H' ==> Q' v) H Q.
Proof using.
introv W. eapply (@local_gc_pre HG).
auto. rewrite star_comm. apply W.
apply~ local_erase.
Qed.
(** Lemma used by [xret_no_gc] *)
Lemma xret_no_gc_lemma : forall B (v:B) H (Q:B->hprop),
H ==> Q v ->
local (fun H' Q' => H' ==> Q' v) H Q.
Proof using.
introv W. apply~ local_erase.
Qed.
(** Lemma used by [xpost],
for introducing an evar for the post-condition *)
Lemma xpost_lemma : forall B Q' Q (F:~~B) H,
is_local F ->
F H Q' ->
Q' ===> Q ->
F H Q.
Proof using. intros. applys* local_weaken. Qed.
(********************************************************************)
(* ** Local parameterized formulae *)
(** [is_local_pred S] asserts that [is_local (S x)] holds for any [x].
It is useful for describing loop invariants. *)
Definition is_local_pred A1 B (S:A1->~~B) :=
forall x, is_local (S x).
(********************************************************************)
(* ** While-loops *)
Lemma while_loop_cf_inv_measure :
forall (I:bool->int->hprop),
forall (F1:~~bool) (F2:~~unit) H (Q:unit->hprop),
(exists b m, H ==> I b m \* (Hexists G, G)) ->
(forall b m, F1 (I b m) (fun b' => I b' m)) ->
(forall m, F2 (I true m) (# Hexists b m', \[0 <= m' < m] \* I b m')) ->
(Q = fun _ => Hexists m, I false m) ->
(_While F1 _Do F2 _Done) H Q.
Proof using.
introv (bi&mi&Hi) Hc Hs He. applys~ local_weaken_gc_pre (I bi mi). xlocal.
xextract as HG. clear Hi. apply local_erase. introv LR HR.
gen bi. induction_wf IH: (int_downto_wf 0) mi. intros.
applys (rm HR). xlet. applys Hc. simpl. xif.
xseq. applys Hs. xextract as b m' E. xapplys IH. applys E. hsimpl. hsimpl.
xret_no_gc. subst Q. hsimpl.
Qed.
(********************************************************************)
(* ** For-loops *)
Lemma for_loop_cf_to_inv :
forall I H',
forall (a:int) (b:int) (F:int->~~unit) H (Q:unit->hprop),
(a > (b)%Z -> H ==> (Q tt)) ->
(a <= (b)%Z ->
(H ==> I a \* H')
/\ (forall i, a <= i /\ i <= (b)%Z -> F i (I i) (# I(i+1)))
/\ (I ((b)%Z+1) \* H' ==> Q tt)) ->
(For i = a To b Do F i _Done) H Q.
Proof.
introv M1 M2. apply local_erase. intros S LS HS.
tests C: (a > b).
apply (rm HS). split; intros C'. math. xret_no_gc~.
forwards (Ma&Mb&Mc): (rm M2). math.
cuts P: (forall i, a <= i <= b+1 -> S i (I i) (# I (b+1))).
xapply P. math. hchanges Ma. hchanges Mc.
intros i. induction_wf IH: (int_upto_wf (b+1)) i. intros Bnd.
applys (rm HS). split; intros C'.
xseq. eapply Mb. math. xapply IH; auto with maths; hsimpl.
xret_no_gc. math_rewrite~ (i = b +1).
Qed.
Lemma for_loop_cf_to_inv_gen' :
forall I H',
forall (a:int) (b:int) (F:int->~~unit) H,
(a <= (b)%Z ->
(H ==> I a \* H')
/\ (forall i, a <= i /\ i <= (b)%Z -> F i (I i) (# I(i+1)))) ->
(a > (b)%Z -> H ==> I ((b)%Z+1) \* H') ->
(For i = a To b Do F i _Done) H (# I ((b)%Z+1) \* H').
Proof. intros. applys* for_loop_cf_to_inv. Qed.
Lemma for_loop_cf_to_inv_gen :
forall I H',
forall (a:int) (b:int) (F:int->~~unit) H Q,
(a <= (b)%Z -> H ==> I a \* H') ->
(forall i, a <= i <= (b)%Z -> F i (I i) (# I(i+1))) ->
(a > (b)%Z -> H ==> I ((b)%Z+1) \* H') ->
(# (I ((b)%Z+1) \* H')) ===> Q ->
(For i = a To b Do F i _Done) H Q.
Proof. intros. applys* for_loop_cf_to_inv. intros C. hchange (H2 C). hchange (H3 tt). hsimpl. Qed.
Lemma for_loop_cf_to_inv_up :
forall I H',
forall (a:int) (b:int) (F:int->~~unit) H (Q:unit->hprop),
(a <= (b)%Z) ->
(H ==> I a \* H') ->
(forall i, a <= i /\ i <= (b)%Z -> F i (I i) (# I(i+1))) ->
((# I ((b)%Z+1) \* H') ===> Q) ->
(For i = a To b Do F i _Done) H Q.
Proof. intros. applys* for_loop_cf_to_inv. intros. math. Qed.
Require Export LibInt CFApp CFPrint.
(********************************************************************)
......
(************************************************************)
(* ** [xgo] *)
Inductive Xhint_cmd :=
| Xstop : Xhint_cmd
| XstopNoclear : Xhint_cmd
| XstopAfter : Xhint_cmd
| XstopInside : Xhint_cmd
| Xtactic : Xhint_cmd
| XtacticNostop : Xhint_cmd
| XtacticNoclear : Xhint_cmd
| XsubstAlias : Xhint_cmd
| XspecArgs : list Boxer -> list Boxer -> Xhint_cmd
| Xargs : forall A, A -> Xhint_cmd
| Xlet : forall A, A -> Xhint_cmd
| Xlets : forall A, A -> Xhint_cmd
| Xsimple : Xhint_cmd.
Inductive Xhint (a : tag_name) (h : Xhint_cmd) :=
| Xhint_intro : Xhint a h.
Ltac add_hint a h :=
let H := fresh "Hint" in
lets H: (Xhint_intro a h).
Ltac clear_hint a :=
match goal with H: Xhint a _ |- _ => clear H end.
Ltac clears_hint tt :=
repeat match goal with H: Xhint _ _ |- _ => clear H end.
Ltac find_hint a :=
match goal with H: Xhint a ?h |- _ => constr:(h) end.
Ltac xgo_default solver cont :=
match ltac_get_tag tt with
| tag_ret => xret; cont tt
| tag_fail => xfail; cont tt
| tag_done => xdone; cont tt
| tag_apply => xapp
| tag_seq => xseq; cont tt
| tag_let_val => xval; cont tt
| tag_let_trm => xlet; cont tt
| tag_let_fun => fail
| tag_body => fail
| tag_letrec => fail
| tag_case => xcases_real; cont tt
| tag_casewhen => fail
| tag_if => xif; cont tt
| tag_alias => xalias; cont tt
| tag_match ?n => xmatch; cont tt
| tag_top_val => fail
| tag_top_trm => fail
| tag_top_fun => fail
| tag_for => fail
| tag_while => fail
end.
Ltac xtactic tag := idtac.
Ltac run_hint h cont :=
let tag := ltac_get_tag tt in
match h with
| Xstop => clears_hint tt; idtac
| XstopNoclear => idtac
| XstopAfter =>
match tag with
| tag_let_trm => fail (* todo: xlet_with cont ltac:(fun _ => idtac)*)
| _ => xgo_default ltac:(fun _ => idtac) ltac:(fun _ => idtac)
end
| XstopInside =>
match tag with
| tag_let_trm => fail (*todo: xlet_with ltac:(fun _ => idtac) cont *)
end
| Xtactic => clears_hint tt; xtactic tag
| XtacticNostop => xtactic tag; cont tt
| XtacticNoclear => xtactic tag
| XsubstAlias => xmatch_subst_alias; cont tt
| Xargs ?E =>
match tag with
| tag_let_trm => fail (* todo!!*)
| tag_apply => xapp E (*todo: not needed?*)
end
| XspecArgs (>> ?S) ?E =>
match tag with
| tag_let_trm => fail (* todo!!*)
| tag_apply => xapp_spec S E (*todo: not needed?*)
end
| Xlet ?S =>
match tag with
| tag_let_trm => xlet S; cont tt
| tag_let_fun => xfun_noxbody S
end
| Xsimple => xmatch_simple; cont tt
(* todo : generalize
| tag_case => xcases_real
| tag_if => xif
| tag_match ?n => xmatch
*)
end.
Ltac find_and_run_hint cont :=
let a := ltac_get_label tt in
let h := find_hint a in
clear_hint a;
first [ run_hint h cont | fail 1 ].
Tactic Notation "xhint" :=
find_and_run_hint ltac:(fun _ => idtac).
Ltac xgo_core solver cont :=
first [ find_and_run_hint cont
| xgo_default solver cont ].
Ltac xgo_core_once solver :=
xgo_core solver ltac:(fun _ => idtac).
Ltac xgo_core_repeat solver :=
xgo_core solver ltac:(fun _ => instantiate; try solve [ solver tt ];
instantiate; try xgo_core_repeat solver).
Ltac xgo_pre tt :=
first [ xcf; repeat progress(intros)
| repeat progress(intros)
| idtac ].
Ltac xgo_base solver :=
xgo_pre tt; xgo_core_repeat solver.
Tactic Notation "xgo1" :=
xgo_core_once ltac:(fun _ => idtac).
Tactic Notation "xgo" :=
xgo_base ltac:(fun tt => idtac).
Tactic Notation "xgo" "~" :=
xgo_base ltac:(fun tt => xauto~ ); instantiate; xauto~.
Tactic Notation "xgo" "*" :=
xgo_base ltac:(fun tt => xauto* ); instantiate; xauto*.
Tactic Notation "xgo" constr(a1) constr(h1) :=
add_hint a1 h1; xgo.
Tactic Notation "xgo" constr(a1) constr(h1) "," constr(a2) constr(h2) :=
add_hint a1 h1; add_hint a2 h2; xgo.
Tactic Notation "xgo" constr(a1) constr(h1) "," constr(a2) constr(h2) ","
constr(a3) constr(h3) :=
add_hint a1 h1; add_hint a2 h2; add_hint a3 h3; xgo.
Tactic Notation "xgo" constr(a1) constr(h1) "," constr(a2) constr(h2) ","
constr(a3) constr(h3) "," constr(a4) constr(h4) :=
add_hint a1 h1; add_hint a2 h2; add_hint a3 h3; add_hint a4 h4; xgo.
Tactic Notation "xgo" "~" constr(a1) constr(h1) :=
add_hint a1 h1; xgo~.
Tactic Notation "xgo" "~" constr(a1) constr(h1) "," constr(a2) constr(h2) :=
add_hint a1 h1; add_hint a2 h2; xgo~.
Tactic Notation "xgo" "~" constr(a1) constr(h1) "," constr(a2) constr(h2) ","
constr(a3) constr(h3) :=
add_hint a1 h1; add_hint a2 h2; add_hint a3 h3; xgo~.
Tactic Notation "xgo" "~" constr(a1) constr(h1) "," constr(a2) constr(h2) ","
constr(a3) constr(h3) "," constr(a4) constr(h4) :=
add_hint a1 h1; add_hint a2 h2; add_hint a3 h3; add_hint a4 h4; xgo~.
Tactic Notation "xgos" :=
xgo; hsimpl.
Tactic Notation "xgos" "~" :=
xgos; auto_tilde.
Tactic Notation "xgos" "*" :=
xgos; auto_star.
let f x = x
\ No newline at end of file
open NullPointers
let g x = Aux.f x
let g x = Auxi.f x
Require Export CFLib Main_ml.
Require Import Aux_ml Aux_proof Extra.
Require Import Auxi_ml Auxi_proof Extra.
Lemma g_spec :
Spec g (x:int) |R>> R \[] (fun y => \[same x y]).
......
This diff is collapsed.
......@@ -2357,6 +2357,12 @@ Definition local B (F:~~B) : ~~B :=
Definition is_local B (F:~~B) :=
F = local F.
(** [is_local_pred S] asserts that [is_local (S x)] holds for any [x].
It is useful for describing loop invariants. *)
Definition is_local_pred A B (S:A->~~B) :=
forall x, is_local (S x).
(** The weakening property is implied by locality *)
Definition weakenable B (F:~~B) :=
......@@ -2712,4 +2718,3 @@ Ltac hclean_main tt :=
Tactic Notation "hclean" := hclean_main tt.
Tactic Notation "hclean" "~" := hclean; auto_tilde.
Tactic Notation "hclean" "*" := hclean; auto_star.
This diff is collapsed.
This diff is collapsed.
......@@ -17,7 +17,6 @@ SRC :=\
CFHeaps \
CFApp \
CFPrint \
CFLemmasForTactics \
CFTactics \
CFHeader \
CFRep \
......
Set Implicit Arguments.
(********************************************************************)
(* TODO: move to libtactics *)
Ltac is_not_evar E :=
first [ is_evar E; fail 1
| idtac ].
(********************************************************************)
(** Notation for functions expecting tuples as arguments *)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment