Global Opaque denote_tc_test_eq.
Hint Rewrite @sem_add_pi_ptr_special' using (solve [try reflexivity; auto with norm]) : norm.
Hint Rewrite @sem_add_pl_ptr_special' using (solve [try reflexivity; auto with norm]) : norm.
Hint Extern 2 (isptr (force_val (sem_add_ptr_int _ _ _ _))) =>
apply isptr_force_sem_add_ptr_int; [reflexivity | auto with prove_it_now] : core.
(* Done in this tail-recursive style so that "hnf" fully reduces it *)
Fixpoint mk_varspecs' (dl: list (ident * globdef Clight.fundef type)) (el: list (ident * type)) :
list (ident * type) :=
match dl with
| (i,Gvar v)::dl' => mk_varspecs' dl' ((i, gvar_info v) :: el)
| (i, _) :: dl' => mk_varspecs' dl' el
| nil => rev_append el nil
end.
Ltac unfold_varspecs al :=
match al with
| context [gvar_info ?v] =>
let b := eval lazy beta zeta iota delta [gvar_info v] in al
in unfold_varspecs b
| _ => exact al
end.
Ltac mk_varspecs prog :=
let a := constr:(prog)
in let a := eval unfold prog in a
in let d :=  match a with
| Clightdefs.mkprogram _ ?d _ _ _ => constr:(d)
| {| prog_defs := ?d |} => constr:(d)
end
in let e := constr:(mk_varspecs' d nil)
in let e := eval hnf in e
in unfold_varspecs e.
Hint Resolve field_address_isptr : norm.
Hint Resolve field_address_eq_offset' : prove_it_now.
Hint Rewrite <- @prop_and using solve [auto with typeclass_instances]: norm1.
Local Open Scope logic.
Ltac process_stackframe_of :=
match goal with |- semax _ (_ * stackframe_of ?F) _ _ =>
let sf := fresh "sf" in set (sf:= stackframe_of F) at 1;
unfold stackframe_of in sf; simpl map in sf; subst sf
end;
repeat
match goal with |- semax _ (_ * fold_right sepcon emp (var_block _ (?i,_) :: _)) _ _ =>
match goal with
| n: name i |- _ => simple apply var_block_lvar2;
[ reflexivity | reflexivity | reflexivity | reflexivity | clear n; intro n ]
| |- _ =>    simple apply var_block_lvar2;
[ reflexivity | reflexivity | reflexivity | reflexivity | let n := fresh "v" i in intros n ]
end
end;
(* match goal with |- semax _ ?Pre _ _ => let p := fresh "p" in set (p := Pre); rewrite <- (@emp_sepcon (environ->mpred) _ _ _ (fold_right _ _ _)); subst p end; *)
repeat (simple apply postcondition_var_block;
[reflexivity | reflexivity | reflexivity | reflexivity | reflexivity |  ]);
change (fold_right sepcon emp (@nil (environ->mpred))) with
(@emp (environ->mpred) _ _);
rewrite ?sepcon_emp, ?emp_sepcon.
Definition tc_option_val' (t: type) : option val -> Prop :=
match t with Tvoid => fun v => match v with None => True | _ => False end | _ => fun v => tc_val t (force_val v) end.
Hint Rewrite tc_option_val'_eq : norm.
Definition tycontext_subVG Vprog1 Gprog1 Vprog2 Gprog2 :=
(forall id : positive,
sub_option (make_tycontext_g Vprog1 Gprog1) ! id
(make_tycontext_g Vprog2 Gprog2) ! id) /\
(forall id : positive,
subsumespec (make_tycontext_s Gprog1) ! id (make_tycontext_s Gprog2) ! id).
(* Ltac apply_semax_body L := eapply (@semax_body_subsumption' _ _ _ _ _ _ _ _ L); [red; red; apply @sub_option_get; repeat (apply Forall_cons; [reflexivity | ]);  apply Forall_nil | repeat (apply Forall_cons; [ reflexivity | ]); apply Forall_nil | simple apply tycontext_sub_refl || (apply tycontext_sub_i99; assumption)]. *)
Ltac apply_semax_body L :=
eapply (@semax_body_subsumption' _ _ _ _ _ _ _ _ L);
[ first [ apply cspecs_sub_refl
| split3; red; apply @sub_option_get;
repeat (apply Forall_cons; [reflexivity | ]);  apply Forall_nil ]
| repeat (apply Forall_cons; [ reflexivity | ]); apply Forall_nil
| simple apply tycontext_sub_refl ||
(apply tycontext_sub_i99; assumption)].
Ltac try_prove_tycontext_subVG L :=
match goal with |- semax_func ?V2 ?G2 _ _ _ =>
try match type of L with
| semax_body ?V1 ?G1 _ _ =>
lazymatch goal with
| H: tycontext_subVG V1 G1 V2 G2 |- _ => idtac
| _ =>
let H := fresh in
try assert (H: tycontext_subVG V1 G1 V2 G2) by
(split;
[ apply sub_option_get;  repeat (apply Forall_cons; [reflexivity | ]);  apply Forall_nil
| apply subsume_spec_get;
repeat (apply Forall_cons; [apply subsumespec_refl | ]); apply Forall_nil])
end end end.
Ltac semax_func_cons L :=
repeat (eapply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | LookupID | LookupB |]);
try_prove_tycontext_subVG L;
first [eapply semax_func_cons;
[ reflexivity
| repeat apply Forall_cons; try apply Forall_nil; try computable; reflexivity
| unfold var_sizes_ok; repeat constructor; try (simpl; rep_omega)
| reflexivity | LookupID | LookupB
| try solve [apply L]; apply_semax_body L
| ]
| eapply semax_func_cons_ext;
[reflexivity | reflexivity | reflexivity | reflexivity | reflexivity
| left; reflexivity
| semax_func_cons_ext_tc | LookupID | LookupB | apply L |
]
];
repeat (eapply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | LookupID | LookupB |]);
try apply semax_func_nil.
Ltac semax_func_cons_ext :=
repeat (eapply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | LookupID | LookupB | ]);
eapply semax_func_cons_ext;
[ reflexivity | reflexivity | reflexivity | reflexivity | reflexivity
| left; reflexivity
| semax_func_cons_ext_tc;
try solve [apply typecheck_return_value; auto]
| LookupID | LookupB
| solve[ first [eapply semax_ext;
[ (*repeat first [reflexivity | left; reflexivity | right]*) apply from_elements_In; reflexivity
| apply compute_funspecs_norepeat_e; reflexivity
| reflexivity
| reflexivity ]]]
|| fail "Try 'eapply semax_func_cons_ext.'"
"To solve [semax_external] judgments, do 'eapply semax_ext.'"
"Make sure that the Espec declared using 'Existing Instance'
is defined as 'add_funspecs NullExtension.Espec Gprog.'"
|
].
Tactic Notation "forward_seq" :=
first [eapply semax_seq'; [  | abbreviate_semax ]
| eapply semax_post_flipped' ].
Tactic Notation "forward_seq" constr(R) :=
match goal with P := @abbreviate ret_assert _ |- semax _ _ _ ?P' =>
constr_eq P P'; unfold abbreviate in P; subst P;
first [apply semax_seq with R; abbreviate_semax
| apply (semax_post_flipped' R); [abbreviate_semax | ]]
end.
(* old: Ltac forward_seq := first [eapply semax_seq'; [  | abbreviate_semax ] | eapply semax_post_flipped' ]. *)
(* end of "stuff to move elsewhere" *)
Ltac Forall_pTree_from_elements :=
cbv beta;
unfold PTree.elements; simpl PTree.xelements;
go_lower;
repeat (( simple apply derives_extract_prop
|| simple apply derives_extract_prop');
fancy_intros true);
autorewrite with gather_prop;
repeat (( simple apply derives_extract_prop
|| simple apply derives_extract_prop');
fancy_intros true);
repeat erewrite unfold_reptype_elim in * by reflexivity;
try autorewrite with entailer_rewrite in *;
repeat first
[ apply prop_Forall_cons1;
[unfold check_one_temp_spec, check_gvars_spec;
simpl; auto;
solve [normalize]
| ]
| apply prop_Forall_cons'
| apply prop_Forall_cons
| apply prop_Forall_nil'
| apply prop_Forall_nil
];
unfold check_one_temp_spec; simpl PTree.get.
Ltac  unify_postcondition_exps :=
first [ reflexivity
| rewrite exp_uncurry;
apply exp_congr; intros [? ?]; simpl; reflexivity
| rewrite exp_uncurry2;
apply exp_congr; intros [[? ?] ?]; simpl; reflexivity
| rewrite exp_uncurry3;
apply exp_congr; intros [[[? ?] ?] ?]; simpl; reflexivity
].
Ltac change_compspecs' cs cs' :=
match goal with
| |- context [@data_at cs' ?sh ?t ?v1] => erewrite (@data_at_change_composite cs' cs _ sh t); [| apply JMeq_refl | reflexivity]
| |- context [@field_at cs' ?sh ?t ?gfs ?v1] => erewrite (@field_at_change_composite cs' cs _ sh t gfs); [| apply JMeq_refl | reflexivity]
| |- context [@data_at_ cs' ?sh ?t] => erewrite (@data_at__change_composite cs' cs _ sh t); [| reflexivity]
| |- context [@field_at_ cs' ?sh ?t ?gfs] => erewrite (@field_at__change_composite cs' cs _ sh t gfs); [| reflexivity]
| |- context [?A cs'] => change (A cs') with (A cs)
| |- context [?A cs' ?B] => change (A cs' B) with (A cs B)
| |- context [?A cs' ?B ?C] => change (A cs' B C) with (A cs B C)
| |- context [?A cs' ?B ?C ?D] => change (A cs' B C D) with (A cs B C D)
| |- context [?A cs' ?B ?C ?D ?E] => change (A cs' B C D E) with (A cs B C D E)
| |- context [?A cs' ?B ?C ?D ?E ?F] => change (A cs' B C D E F) with (A cs B C D E F)
end.
(* TODO: use CCE as arguments to gain CS' *)
Ltac change_compspecs cs :=
match goal with |- context [?cs'] =>
match type of cs' with compspecs =>
try (constr_eq cs cs'; fail 1);
change_compspecs' cs cs';
repeat change_compspecs' cs cs'
end
end.
Definition Warning_perhaps_funspec_postcondition_needs_EX_outside_PROP_LOCAL_SEP (p: Prop) := p.
Ltac give_EX_warning :=
match goal with |- ?A => change
(Warning_perhaps_funspec_postcondition_needs_EX_outside_PROP_LOCAL_SEP A)
end.
Ltac check_parameter_types :=
first [reflexivity | elimtype  Parameter_types_in_funspec_different_from_call_statement].
Ltac check_result_type :=
first [reflexivity | elimtype  Result_type_in_funspec_different_from_call_statement].
Inductive Cannot_find_function_spec_in_Delta (id: ident) := .
Inductive Global_function_name_shadowed_by_local_variable := .
Ltac check_function_name :=
first [reflexivity | elimtype Global_function_name_shadowed_by_local_variable].
Inductive Actual_parameters_cannot_be_coerced_to_formal_parameter_types := .
Ltac check_cast_params :=
reflexivity +
(simpl explicit_cast_exprlist;
match goal with |- force_list (map ?F ?A) = _ =>
let el := constr:(A) in
let bl := constr:(map F A) in
let cl := eval simpl in bl in
fail 100 "Some of the argument expressions in your function call do not evaluate (sometimes this is caused by missing LOCALs in your precondition).  Your argument expressions are:"
el "They evaluate (or fail) as follows:" cl
end).
Inductive Witness_type_of_forward_call_does_not_match_witness_type_of_funspec:
Type -> Type -> Prop := .
Ltac find_spec_in_globals' :=
match goal with |- ?X = _ => let x := fresh "x" in set (x:=X); hnf in x; subst x end;
try reflexivity.
Inductive Cannot_analyze_LOCAL_definitions : Prop := .
Ltac check_prove_local2ptree :=
first [prove_local2ptree | elimtype Cannot_analyze_LOCAL_definitions].
Inductive Funspec_precondition_is_not_in_PROP_LOCAL_SEP_form := .
Ltac check_funspec_precondition :=
first [reflexivity | elimtype  Funspec_precondition_is_not_in_PROP_LOCAL_SEP_form].
Ltac lookup_spec id :=
tryif apply f_equal_Some
then
match goal with
| |- vacuous_funspec _ = _ => fail 100 "Your Gprog contains no funspec with the name" id
| |- ?fs = _ => check_canonical_funspec (id,fs);
first [reflexivity |
match goal with
| |- mk_funspec _ _ ?t1 _ _ = mk_funspec _ _ ?t2 _ _ =>
first [unify t1 t2
| elimtype False; elimtype (Witness_type_of_forward_call_does_not_match_witness_type_of_funspec
t2 t1)]
end]
end
else elimtype  (Cannot_find_function_spec_in_Delta id).
Inductive Function_arguments_include_a_memory_load_of_type (t:type) := .
Ltac goal_has_evars :=
match goal with |- ?A => has_evar A end.
Ltac delete_FRZR_from_SEP :=
match goal with
| |- ENTAIL _, PROPx _ (LOCALx _ (SEPx ?R)) |-- _ =>
match R with context [FRZR] =>
eapply drop_SEP_tc;
[ first [apply extend_tc.extend_tc_expr
| apply extend_tc.extend_tc_exprlist
| apply extend_tc.extend_tc_lvalue]
| apply split_FRZ_in_SEP_spec; prove_split_FRZ_in_SEP
| ]
end end.
Ltac check_typecheck :=
try delete_FRZR_from_SEP;
first [goal_has_evars; idtac |
try apply local_True_right;
entailer!;
match goal with
| |- typecheck_error (deref_byvalue ?T) =>
elimtype (Function_arguments_include_a_memory_load_of_type T)
| |- _ => idtac
end].
Ltac prove_delete_temp := match goal with |- ?A = _ =>
let Q := fresh "Q" in set (Q:=A); hnf in Q; subst Q; reflexivity
end.
Ltac cancel_for_forward_call := cancel_for_evar_frame.
Ltac default_cancel_for_forward_call := cancel_for_evar_frame.
Ltac unfold_post := match goal with |- ?Post = _ => let A := fresh "A" in let B := fresh "B" in first
[evar (A : Type); evar (B : A -> environ -> mpred); unify Post (@exp _ _ ?A ?B);
change Post with (@exp _ _ A B); subst A B |
evar (A : list Prop); evar (B : environ -> mpred); unify Post (PROPx ?A ?B);
change Post with (PROPx A B); subst A B | idtac] end.
Ltac match_postcondition :=
cbv beta iota zeta; unfold_post;  extensionality rho;
repeat rewrite exp_uncurry;
try rewrite no_post_exists; repeat rewrite exp_unfold;
tryif apply exp_congr
then (intros ?vret;
apply equal_f;
apply PROP_LOCAL_SEP_ext; [reflexivity | | reflexivity];
(reflexivity || fail "The funspec of the function has a POSTcondition
that is ill-formed.  The LOCALS part of the postcondition
should be (temp ret_temp ...), but it is not"))
else fail "The funspec of the function should have a POSTcondition that starts
with an existential, that is,  EX _:_, PROP...LOCAL...SEP".
(* Ltac match_postcondition := cbv beta iota zeta; unfold_post; extensionality rho; repeat rewrite exp_uncurry; try rewrite no_post_exists; repeat rewrite exp_unfold; first [apply exp_congr; intros ?vret; reflexivity | give_EX_warning ]. *)
Ltac  forward_call_id1_wow_nil :=
let H := fresh in intro H;
eapply (semax_call_id1_wow_nil _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[check_result_type
|apply Logic.I
| match_postcondition
| prove_delete_temp
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac  forward_call_id1_wow :=
let H := fresh in intro H;
eapply (semax_call_id1_wow _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[check_result_type
|apply Logic.I
| match_postcondition
| prove_delete_temp
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id1_x_wow_nil :=
let H := fresh in intro H;
eapply (semax_call_id1_x_wow_nil
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ check_result_type | check_result_type
| apply Coq.Init.Logic.I | apply Coq.Init.Logic.I | reflexivity
| (clear; let H := fresh in intro H; inversion H)
| match_postcondition
| prove_delete_temp
| prove_delete_temp
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id1_x_wow :=
let H := fresh in intro H;
eapply (semax_call_id1_x_wow
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ check_result_type | check_result_type
| apply Coq.Init.Logic.I | apply Coq.Init.Logic.I | reflexivity
| (clear; let H := fresh in intro H; inversion H)
| match_postcondition
| prove_delete_temp
| prove_delete_temp
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id1_y_wow_nil :=
let H := fresh in intro H;
eapply (semax_call_id1_y_wow_nil
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ check_result_type | check_result_type
| apply Coq.Init.Logic.I | apply Coq.Init.Logic.I | reflexivity
| (clear; let H := fresh in intro H; inversion H)
| match_postcondition
| prove_delete_temp
| prove_delete_temp
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id1_y_wow :=
let H := fresh in intro H;
eapply (semax_call_id1_y_wow
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ check_result_type | check_result_type
| apply Coq.Init.Logic.I | apply Coq.Init.Logic.I | reflexivity
| (clear; let H := fresh in intro H; inversion H)
| match_postcondition
| prove_delete_temp
| prove_delete_temp
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id01_wow_nil :=
let H := fresh in intro H;
eapply (semax_call_id01_wow_nil _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ apply Coq.Init.Logic.I
| match_postcondition
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id01_wow :=
let H := fresh in intro H;
eapply (semax_call_id01_wow
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ apply Coq.Init.Logic.I
| match_postcondition
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id00_wow_nil  :=
let H := fresh in intro H;
eapply (semax_call_id00_wow_nil _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ check_result_type
| cbv beta iota zeta; unfold_post; (* extensionality rho; *)
repeat rewrite exp_uncurry;
try rewrite no_post_exists0;
(* apply equal_f; *)
apply exp_congr; intros ?vret;
apply PROP_LOCAL_SEP_ext; [reflexivity | | reflexivity];
(reflexivity || fail "The funspec of the function has a POSTcondition
that is ill-formed.  The LOCALS part of the postcondition
should be empty, but it is not")
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac forward_call_id00_wow  :=
let H := fresh in intro H;
eapply (semax_call_id00_wow _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H);
clear H;
lazymatch goal with Frame := _ : list mpred |- _ => try clear Frame end;
[ check_result_type
| (*match_postcondition*)
cbv beta iota zeta; unfold_post; (* extensionality rho; *)
repeat rewrite exp_uncurry;
try rewrite no_post_exists0;
(* apply equal_f; *)
apply exp_congr; intros ?vret;
apply PROP_LOCAL_SEP_ext; [reflexivity | | reflexivity];
(reflexivity || fail "The funspec of the function has a POSTcondition
that is ill-formed.  The LOCALS part of the postcondition
should be empty, but it is not")
| unify_postcondition_exps
| unfold fold_right_and; repeat rewrite and_True; auto
].
Ltac simpl_strong_cast :=
try match goal with |- context [strong_cast ?t1 ?t2 ?v] =>
first [change (strong_cast t1 t2 v) with v
| change (strong_cast t1 t2 v) with
(force_val (sem_cast t1 t2 v))
]
end.
Ltac fwd_skip :=
match goal with |- semax _ _ Sskip _ =>
normalize_postcondition;
first [eapply semax_pre | eapply semax_pre_simple];
[ | apply semax_skip]
end.
Definition BINDER_NAME := tt.
Ltac find_postcond_binder_names :=
match goal with |- semax ?Delta _ ?c _ =>
match c with context [Scall _ (Evar ?id _) _] =>
let x := constr:((glob_specs Delta) ! id) in
let x' := eval hnf in x in
match x' with
| Some (mk_funspec _ _ _ _ (fun _ => exp (fun y1 => exp (fun y2 => exp (fun y3 => exp (fun y4 => _)))))) =>
let y4' := fresh y4 in  pose (y4' := BINDER_NAME);
let y3' := fresh y3 in  pose (y3' := BINDER_NAME);
let y2' := fresh y2 in  pose (y2' := BINDER_NAME);
let y1' := fresh y1 in  pose (y1' := BINDER_NAME)
| Some (mk_funspec _ _ _ _ (fun _ => exp (fun y1 => exp (fun y2 => exp (fun y3 => _))))) =>
let y3' := fresh y3 in  pose (y3' := BINDER_NAME);
let y2' := fresh y2 in  pose (y2' := BINDER_NAME);
let y1' := fresh y1 in  pose (y1' := BINDER_NAME)
| Some (mk_funspec _ _ _ _ (fun _ => exp (fun y1 => exp (fun y2 => _)))) =>
let y2' := fresh y2 in  pose (y2' := BINDER_NAME);
let y1' := fresh y1 in  pose (y1' := BINDER_NAME)
| Some (mk_funspec _ _ _ _ (fun _ => exp (fun y1 => _))) =>
let y1' := fresh y1 in  pose (y1' := BINDER_NAME)
| _ => idtac
end
end
end.
Ltac after_forward_call_binders :=
repeat match goal with
| r := BINDER_NAME |- _ =>
clear r; apply extract_exists_pre; intro r
| |- _ => apply extract_exists_pre; intros ?vret
end.
Ltac cleanup_no_post_exists :=
match goal with |-  context[eq_no_post] =>
let vret := fresh "vret" in let H := fresh in
apply extract_exists_pre; intro vret;
apply semax_extract_PROP; intro H;
change (eq_no_post vret) with (eq vret) in H;
subst vret
end
|| unfold eq_no_post.
Ltac factor_out_v L :=
match L with
| temp _ ?v :: ?L' => factor_out_v' v L'
| lvar _ _ ?v :: ?L' => factor_out_v' v L'
| _ => constr:(@nil val)
end
with factor_out_v' v L' := let x := fresh "v" in set (x:=v);
let y :=factor_out_v L'
in constr:(x::y).
Ltac factor_back L :=
match L with
| ?x :: ?y => subst x; factor_back y
| nil => idtac
end.
Ltac simplify_remove_localdef_temp :=
match goal with |- context [remove_localdef_temp ?i ?L]  =>
let L' := factor_out_v L in
simpl remove_localdef_temp;
factor_back L'
end.
Ltac after_forward_call :=
check_POSTCONDITION;
try match goal with |- context [remove_localdef_temp] =>
simplify_remove_localdef_temp
end;
unfold_app;
try (apply extract_exists_pre; intros _);
match goal with
| |- semax _ _ _ _ => idtac
| |- unit -> semax _ _ _ _ => intros _
end;
match goal with
| |- @semax ?CS _ _ _ _ _ => try change_compspecs CS
end;
repeat (apply semax_extract_PROP; intro);
cleanup_no_post_exists;
abbreviate_semax;
try fwd_skip.
Ltac clear_MORE_POST :=
try match goal with POSTCONDITION := @abbreviate ret_assert _ |- _ =>
clear POSTCONDITION
end;
try match goal with MORE_COMMANDS := @abbreviate statement _ |- _ =>
clear MORE_COMMANDS
end.
Inductive Ridiculous: Type := .
Ltac check_witness_type ts A witness :=
(unify A (rmaps.ConstType Ridiculous); (* because [is_evar A] doesn't seem to work *)
elimtype False)
||
let TA := constr:(functors.MixVariantFunctor._functor
(rmaps.dependent_type_functor_rec ts A) mpred) in
let TA' := eval cbv
[functors.MixVariantFunctor._functor
functors.MixVariantFunctorGenerator.fpair
functors.MixVariantFunctorGenerator.fconst
functors.MixVariantFunctorGenerator.fidentity
rmaps.dependent_type_functor_rec
functors.GeneralFunctorGenerator.CovariantBiFunctor_MixVariantFunctor_compose
functors.CovariantFunctorGenerator.fconst
functors.CovariantFunctorGenerator.fidentity
functors.CovariantBiFunctor._functor
functors.CovariantBiFunctorGenerator.Fpair
functors.GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor
functors.CovariantFunctor._functor
functors.MixVariantFunctor.fmap
] in TA
in let TA'' := eval simpl in TA'
in match type of witness with ?T =>
unify T TA''
+ (fail "Type of witness does not match type required by funspec WITH clause.
Witness value: " witness "
Witness type: " T "
Funspec type: " TA'')
end.
(*ready for deletion*)
Ltac check_witness_type_nil A witness :=
(unify A (rmaps.ConstType Ridiculous); (* because [is_evar A] doesn't seem to work *)
elimtype False)
||
let TA := constr:(functors.MixVariantFunctor._functor
(rmaps.dependent_type_functor_rec nil A) mpred) in
let TA' := eval cbv
[functors.MixVariantFunctor._functor
functors.MixVariantFunctorGenerator.fpair
functors.MixVariantFunctorGenerator.fconst
functors.MixVariantFunctorGenerator.fidentity
rmaps.dependent_type_functor_rec
functors.GeneralFunctorGenerator.CovariantBiFunctor_MixVariantFunctor_compose
functors.CovariantFunctorGenerator.fconst
functors.CovariantFunctorGenerator.fidentity
functors.CovariantBiFunctor._functor
functors.CovariantBiFunctorGenerator.Fpair
functors.GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor
functors.CovariantFunctor._functor
functors.MixVariantFunctor.fmap
] in TA
in let TA'' := eval simpl in TA'
in match type of witness with ?T =>
unify T TA''
+ (fail "Type of witness does not match type required by funspec WITH clause.
Witness value: " witness "
Witness type: " T "
Funspec type: " TA'')
end.
(* This is needed for the varargs (printf) hack *)
(* Ltac prove_call_setup1 subsumes := match goal with | |- @semax _ _ _ (@exp _ _ _ _) _ _ => fail 1 "forward_call fails because your precondition starts with EX. Use Intros  to move          the existentially bound variables above the line" | |- @semax ?CS _ ?Delta (PROPx ?P (LOCALx ?Q (SEPx ?R'))) ?c _ => lazymatch c with | context [Scall _ (Evar ?id ?ty) ?bl] => let R := strip1_later R' in exploit (call_setup1_i2 CS Delta P Q R' (*R*) id ty bl) ; [check_prove_local2ptree | apply can_assume_funcptr2; (*(can_assume_funcptr3 _ _ subsumes);*)
[ check_function_name
| lookup_spec id
| find_spec_in_globals'
| simpl; reflexivity  (* function-id type in AST matches type in funspec *)
]
| apply subsumes
| try reflexivity; (eapply classify_fun_ty_hack; [apply subsumes| reflexivity ..])  (* function-id type in AST matches type in funspec *)
|check_typecheck
|check_typecheck
|check_cast_params
|reflexivity
| ..
]
| context [Scall _ ?a ?bl] =>
let R := strip1_later R' in
exploit (call_setup1_i CS Delta P Q (*R*) R' a bl);
[check_prove_local2ptree
|reflexivity
|prove_func_ptr
| apply subsumes
|check_parameter_types
|check_typecheck
|check_typecheck
|check_cast_params
|reflexivity
| ]
end
end.
*)
(*The following version swaps the two context-cases and replaces the lazymatch by a match- we believe this priorizitizes func_ptr lookup over Delta-lookup*)
Ltac prove_call_setup1 subsumes :=
match goal with
| |- @semax _ _ _ (@exp _ _ _ _) _ _ =>
fail 1 "forward_call fails because your precondition starts with EX.
Use Intros  to move          the existentially bound variables above the line"
| |- @semax ?CS _ ?Delta (PROPx ?P (LOCALx ?Q (SEPx ?R'))) ?c _ =>
match c with
| context [Scall _ ?a ?bl] =>
let R := strip1_later R' in
exploit (call_setup1_i CS Delta P Q (*R*) R' a bl);
[check_prove_local2ptree
|reflexivity
|prove_func_ptr
| apply subsumes
|check_parameter_types
|check_typecheck
|check_typecheck
|check_cast_params
|reflexivity
| ]
| context [Scall _ (Evar ?id ?ty) ?bl] =>
let R := strip1_later R' in
exploit (call_setup1_i2 CS Delta P Q R' (*R*) id ty bl) ;
[check_prove_local2ptree
| apply can_assume_funcptr2; (*(can_assume_funcptr3 _ _ subsumes);*)
[ check_function_name
| lookup_spec id
| find_spec_in_globals'
| simpl; reflexivity  (* function-id type in AST matches type in funspec *)
]
| apply subsumes
| try reflexivity; (eapply classify_fun_ty_hack; [apply subsumes| reflexivity ..])  (* function-id type in AST matches type in funspec *)
|check_typecheck
|check_typecheck
|check_cast_params
|reflexivity
| ..
]
end
end.
Ltac check_gvars :=
first [exact Logic.I
| reflexivity
| match goal with |- check_gvars_spec None (Some ?gv) =>
fail 100 "The function precondition requires (gvars" gv ")" "which is not present in your current assertion's LOCAL clause"
end
].
Ltac prove_call_setup_aux  ts witness :=
let H := fresh in
intro H;
match goal with | |- @semax ?CS _ _ (PROPx ?P (LOCALx ?L (SEPx ?R'))) _ _ =>
let Frame := fresh "Frame" in evar (Frame: list mpred);
let R := strip1_later R' in
exploit (call_setup2_i _ _ _ _ _ _ _ _ R R' _ _ _ _ ts _ _ _ _ _ _ _ _ H witness Frame); clear H;
simpl functors.MixVariantFunctor._functor;
[ reflexivity
| check_prove_local2ptree
| Forall_pTree_from_elements
| auto 50 with derives
| unfold check_gvars_spec; solve [exact I | reflexivity]
| try change_compspecs CS; cancel_for_forward_call
|
]
end.
Ltac prove_call_setup ts subsumes witness :=
prove_call_setup1 subsumes;
[ .. |
match goal with |- call_setup1  _ _ _ _ _ _ _ _ (*_*) _ _ _ _ _ ?A _ _ _ _ _ _ _ -> _ =>
check_witness_type ts A witness
end;
prove_call_setup_aux ts witness].
Ltac fwd_call' ts subsumes witness :=
lazymatch goal with
| |- semax _ _ (Ssequence (Scall _ _ _) _) _ =>
eapply semax_seq';
[prove_call_setup ts subsumes witness;
clear_Delta_specs; clear_MORE_POST;
[ .. |
lazymatch goal with
| |- _ -> semax _ _ (Scall (Some _) _ _) _ =>(*
forward_call_id1_wow'
| |- call_setup2' _ _ _ _ _ _ _ _ _ _ _ _ ?retty _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ->
semax _ _ (Scall None _ _) _ =>*)
forward_call_id1_wow
| |- call_setup2 _ _ _ _ _ _ _ _ _ _ _ _ ?retty _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ->
semax _ _ (Scall None _ _) _ =>
tryif (unify retty Tvoid)
then forward_call_id00_wow(*'*)
else forward_call_id01_wow(*'*)
end]
| after_forward_call ]
| |- semax _ _ (Ssequence (Ssequence (Scall (Some ?ret') _ _)
(Sset _ (Ecast (Etempvar ?ret'2 _) _))) _) _ =>
unify ret' ret'2;
eapply semax_seq';
[prove_call_setup ts subsumes witness;
clear_Delta_specs; clear_MORE_POST;
[ .. | forward_call_id1_x_wow(*'*) ]
|  after_forward_call ]
| |- semax _ _ (Ssequence (Ssequence (Scall (Some ?ret') _ _)
(Sset _ (Etempvar ?ret'2 _))) _) _ =>
unify ret' ret'2;
eapply semax_seq';
[prove_call_setup ts subsumes witness;
clear_Delta_specs; clear_MORE_POST;
[ .. | forward_call_id1_y_wow(*'*) ]
|  after_forward_call ]
| |- _ => rewrite <- seq_assoc; fwd_call' ts subsumes witness
end.
Ltac fwd_call_dep ts subsumes witness :=
try lazymatch goal with
| |- semax _ _ (Scall _ _ _) _ => rewrite -> semax_seq_skip
end;
repeat lazymatch goal with
| |- semax _ _ (Ssequence (Ssequence (Ssequence _ _) _) _) _ =>
rewrite <- seq_assoc
end;
lazymatch goal with |- @semax ?CS _ ?Delta _ (Ssequence ?C _) _ =>
lazymatch C with context [Scall _ _ _] =>
fwd_call' ts subsumes witness
end
end.
Tactic Notation "forward_call" constr(ts) constr(subsumes) constr(witness) :=
fwd_call_dep ts subsumes witness.
Tactic Notation "forward_call" constr(witness) :=
fwd_call_dep (@nil Type) funspec_sub_refl witness.
Tactic Notation "forward_call" constr(subsumes) constr(witness) :=
fwd_call_dep (@nil Type) subsumes witness.
Ltac tuple_evar2 name T cb evar_tac :=
lazymatch T with
| prod ?A ?B => tuple_evar2 name A
ltac: (fun xA =>
tuple_evar2 name B ltac: (fun xB =>
cb (xA, xB)) evar_tac) evar_tac
| _ => my_unshelve_evar name T cb evar_tac
end; idtac.
Ltac get_function_witness_type func :=
let TA := constr:(functors.MixVariantFunctor._functor
(rmaps.dependent_type_functor_rec nil func) mpred) in
let TA' := eval cbv
[functors.MixVariantFunctor._functor
functors.MixVariantFunctorGenerator.fpair
functors.MixVariantFunctorGenerator.fconst
functors.MixVariantFunctorGenerator.fidentity
rmaps.dependent_type_functor_rec
functors.GeneralFunctorGenerator.CovariantBiFunctor_MixVariantFunctor_compose
functors.CovariantFunctorGenerator.fconst
functors.CovariantFunctorGenerator.fidentity
functors.CovariantBiFunctor._functor
functors.CovariantBiFunctorGenerator.Fpair
functors.GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor
functors.CovariantFunctor._functor
functors.MixVariantFunctor.fmap
] in TA
in let TA'' := eval simpl in TA'
in TA''.
Ltac new_prove_call_setup :=
prove_call_setup1 funspec_sub_refl;
[ .. |
match goal with |- call_setup1 _ _ _ _ _ _ _ _ _ (*_*) _ _ _ _ ?A _ _ _ _ _ _ _ -> _ =>
let x := fresh "x" in tuple_evar2 x ltac:(get_function_witness_type A)
ltac:(prove_call_setup_aux (@nil Type))
ltac:(fun _ => try refine tt; fail "Failed to infer some parts of witness")
end].
(* Ltac new_prove_call_setup := prove_call_setup1 funspec_sub_refl; [ .. | match goal with |- call_setup1 _ _ _ _ _ _ _ _ _ (*_*) _ _ _ _ ?A _ _ _ _ _ _ _ -> _ => let x := fresh "x" in tuple_evar2 x ltac:(get_function_witness_type A) ltac:(fun witness => let H := fresh in intro H; match goal with | |- @semax ?CS _ _ (PROPx ?P (LOCALx ?L (SEPx ?R'))) _ _ => let Frame := fresh "Frame" in evar (Frame: list mpred); let R := strip1_later R' in exploit (call_setup2_i _ _ _ _ _ _ _ _ R R' _ _ _ _ nil _ _ _ _ _ _ _ _ H witness Frame); clear H; simpl functors.MixVariantFunctor._functor; [ reflexivity | check_prove_local2ptree | Forall_pTree_from_elements | auto 50 with derives | unfold check_gvars_spec; solve [exact I | reflexivity] | try change_compspecs CS; cancel_for_forward_call | ] end) ltac:(fun _ => try refine tt; fail "Failed to infer some parts of witness") end]. *)
Ltac new_fwd_call' :=
lazymatch goal with
| |- semax _ _ (Ssequence (Scall _ _ _) _) _ =>
eapply semax_seq';
[new_prove_call_setup;
clear_Delta_specs; clear_MORE_POST;
[ .. |
lazymatch goal with
| |- _ -> semax _ _ (Scall (Some _) _ _) _ =>
forward_call_id1_wow(*
| |- call_setup2_nil _ _ _ _ _ _ _ _ _ _ _ _ ?retty _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ->
semax _ _ (Scall None _ _) _ =>*)
| |- call_setup2 _ _ _ _ _ _ _ _ _ _ _ _ _ ?retty _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ->
semax _ _ (Scall None _ _) _ =>
tryif (unify retty Tvoid)
then forward_call_id00_wow
else forward_call_id01_wow
end]
| after_forward_call ]
| |- semax _ _ (Ssequence (Ssequence (Scall (Some ?ret') _ _)
(Sset _ (Ecast (Etempvar ?ret'2 _) _))) _) _ =>
unify ret' ret'2;
eapply semax_seq';
[new_prove_call_setup;
clear_Delta_specs; clear_MORE_POST;
[ .. | forward_call_id1_x_wow ]
|  after_forward_call ]
| |- semax _ _ (Ssequence (Ssequence (Scall (Some ?ret') _ _)
(Sset _ (Etempvar ?ret'2 _))) _) _ =>
unify ret' ret'2;
eapply semax_seq';
[new_prove_call_setup;
clear_Delta_specs; clear_MORE_POST;
[ .. | forward_call_id1_y_wow ]
|  after_forward_call ]
| |- _ => rewrite <- seq_assoc; new_fwd_call'
end.
Ltac new_fwd_call:=
try lazymatch goal with
| |- semax _ _ (Scall _ _ _) _ => rewrite -> semax_seq_skip
end;
repeat lazymatch goal with
| |- semax _ _ (Ssequence (Ssequence (Ssequence _ _) _) _) _ =>
rewrite <- seq_assoc
end;
lazymatch goal with |- @semax ?CS _ ?Delta _ (Ssequence ?C _) _ =>
lazymatch C with context [Scall _ _ _] =>
new_fwd_call'
end
end.
Tactic Notation "forward_call"  := new_fwd_call.
Ltac do_compute_lvalue Delta P Q R e v H :=
let rho := fresh "rho" in
assert (ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
local (`(eq v) (eval_lvalue e))) as H by
(first [ assumption |
eapply derives_trans; [| apply msubst_eval_lvalue_eq];
[apply andp_derives; [apply derives_refl |]; apply derives_refl'; apply local2ptree_soundness; try assumption;
let HH := fresh "H" in
construct_local2ptree Q HH;
exact HH |
unfold v;
simpl;
cbv beta iota zeta delta [force_val2 force_val1];
rewrite ?isptr_force_ptr, <- ?offset_val_force_ptr by auto;
reflexivity]
]).
Ltac do_compute_expr Delta P Q R e v H :=
let rho := fresh "rho" in
assert (ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
local (`(eq v) (eval_expr e))) as H by
(assumption || (
eapply derives_trans; [| apply msubst_eval_expr_eq];
[apply andp_derives; [apply derives_refl |]; apply derives_refl'; apply local2ptree_soundness; try assumption;
let HH := fresh "H" in
construct_local2ptree Q HH;
exact HH |
unfold v;
match goal with
| |- ?E = Some _ => let E' := eval hnf in E in change E with E'
end;
match goal with
| |- Some ?E = Some _ => let E' := eval hnf in E in
match E' with
| (match ?E'' with
| Some _ => _
| None => Vundef
end)
=> change E with (force_val E'')
| (match ?E'' with
| Vundef => Vundef
| Vint _ => Vundef
| Vlong _ => Vundef
| Vfloat _ => Vundef
| Vsingle _ => Vundef
| Vptr _ _ => Vptr _ (Ptrofs.add _ (Ptrofs.repr ?ofs))
end)
=> change E with (offset_val ofs E'')
| _ => change E with E'
end
| |- ?NotSome = Some _ =>
fail 1000 "The C-language expression " e
" does not necessarily evaluate, perhaps because some variable is missing from your LOCAL clause"
(* fail 1000 "Please make sure hnf can simplify" NotSome "to an expression of the form (Some _)" *)
end;
reflexivity]
)).
(* solve msubst_eval_expr, msubst_eval_lvalue, msubst_eval_LR *)
Ltac solve_msubst_eval :=
let e := match goal with
| |- msubst_eval_expr _ _ _ _ ?a = _ => a
| |- msubst_eval_lvalue _ _ _ _ ?a = _ => a
end in
match goal with
| |- ?E = Some _ => let E' := eval hnf in E in change E with E'
end;
match goal with
| |- Some ?E = Some _ => let E' := eval hnf in E in
match E' with
| (match ?E'' with
| Some _ => _
| None => Vundef
end)
=> change E with (force_val E'')
| (match ?E'' with
| Vundef => Vundef
| Vint _ => Vundef
| Vlong _ => Vundef
| Vfloat _ => Vundef
| Vsingle _ => Vundef
| Vptr _ _ => Vptr _ (Ptrofs.add _ (Ptrofs.repr ?ofs))
end)
=> change E with (offset_val ofs E'')
| _ => change E with E'
end
| |- ?NotSome = Some _ =>
fail 1000 "The C-language expression " e
" does not necessarily evaluate, perhaps because some variable is missing from your LOCAL clause"
end.
Ltac ignore x := idtac.
(*start tactics for forward_while unfolding *)
Ltac intro_ex_local_derives :=
(match goal with
| |- local (_) && exp (fun y => _) |-- _ =>
rewrite exp_andp2; apply exp_left; let y':=fresh y in intro y'
end).
Ltac unfold_and_function_derives_left :=
(repeat match goal with
| |- _ && (exp _) |--  _ => fail 1
| |- _ && (PROPx _ _) |-- _ => fail 1
| |- _ && (?X _ _ _ _ _) |--  _ => unfold X
| |- _ && (?X _ _ _ _) |--  _ => unfold X
| |- _ && (?X _ _ _) |--  _ => unfold X
| |- _ && (?X _ _) |--  _ => unfold X
| |- _ && (?X _) |--  _ => unfold X
| |- _ && (?X) |--  _ => unfold X
end).
Ltac unfold_and_local_derives :=
try rewrite <- local_lift2_and;
unfold_and_function_derives_left;
repeat intro_ex_local_derives;
try rewrite local_lift2_and;
repeat (try rewrite andp_assoc; rewrite insert_local).
Ltac unfold_function_derives_right :=
(repeat match goal with
| |- _ |-- (exp _) => fail 1
| |- _ |-- (PROPx _ _) => fail 1
| |- _ |-- (?X _ _ _ _ _)  => unfold X
| |- _ |-- (?X _ _ _ _)  => unfold X
| |- _ |-- (?X _ _ _)  => unfold X
| |- _ |-- (?X _ _)  => unfold X
| |- _ |-- (?X _)  => unfold X
| |- _ |-- (?X)  => unfold X
end).
Ltac unfold_pre_local_andp :=
(repeat match goal with
| |- semax _ ((local _) && exp _) _ _ => fail 1
| |- semax _ ((local _) && (PROPx _ _)) _ _ => fail 1
| |- semax _ ((local _) && ?X _ _ _ _ _) _ _ => unfold X at 1
| |- semax _ ((local _) && ?X _ _ _ _) _ _ => unfold X at 1
| |- semax _ ((local _) && ?X _ _ _) _ _ => unfold X at 1
| |- semax _ ((local _) && ?X _ _) _ _ => unfold X at 1
| |- semax _ ((local _) && ?X _) _ _ => unfold X at 1
| |- semax _ ((local _) && ?X) _ _ => unfold X at 1
end).
Ltac intro_ex_local_semax :=
(match goal with
| |- semax _ (local (_) && exp (fun y => _)) _ _  =>
rewrite exp_andp2; apply extract_exists_pre; let y':=fresh y in intro y'
end).
Ltac unfold_and_local_semax :=
unfold_pre_local_andp;
repeat intro_ex_local_semax;
try rewrite insert_local.
Ltac do_compute_expr_helper Delta Q v :=
try assumption;
eapply derives_trans; [| apply msubst_eval_expr_eq];
[apply andp_derives; [apply derives_refl | apply derives_refl']; apply local2ptree_soundness; try assumption;
let HH := fresh "H" in
construct_local2ptree Q HH;
exact HH |
unfold v;
simpl;
try unfold force_val2; try unfold force_val1;
autorewrite with norm;
simpl;
reflexivity].
Ltac do_compute_expr1 Delta Pre e :=
match Pre with
| @exp _ _ ?A ?Pre1 =>
let P := fresh "P" in let Q := fresh "Q" in let R := fresh "R" in
let H8 := fresh "DCE" in let H9 := fresh "DCE" in
evar (P: A -> list Prop);
evar (Q: A -> list localdef);
evar (R: A -> list mpred);
assert (H8: Pre1 =  (fun a => PROPx (P a) (LOCALx (Q a) (SEPx (R a)))))
by (extensionality; unfold P,Q,R; reflexivity);
let v := fresh "v" in evar (v: A -> val);
assert (H9: forall a, ENTAIL Delta, PROPx (P a) (LOCALx (Q a) (SEPx (R a))) |--
local (`(eq (v a)) (eval_expr e)))
by (let a := fresh "a" in intro a; do_compute_expr_helper Delta (Q a) v)
| PROPx ?P (LOCALx ?Q (SEPx ?R)) =>
let H9 := fresh "H" in
let v := fresh "v" in evar (v: val);
assert (H9:  ENTAIL Delta, PROPx P (LOCALx Q (SEPx R))|--
local (`(eq v) (eval_expr e)))
by (do_compute_expr_helper Delta Q v)
end.
Ltac cleanup_repr H :=
rewrite ?mul_repr, ?add_repr, ?sub_repr in H;
match type of H with
| _ (Int.signed (Int.repr ?A)) (Int.signed (Int.repr ?B)) =>
try (rewrite (Int.signed_repr A) in H by rep_omega);
try (rewrite (Int.signed_repr B) in H by rep_omega)
| _ (Int.unsigned (Int.repr ?A)) (Int.unsigned (Int.repr ?B)) =>
try (rewrite (Int.unsigned_repr A) in H by rep_omega);
try (rewrite (Int.unsigned_repr B) in H by rep_omega)
| context [Int.signed (Int.repr ?A) ] =>
try (rewrite (Int.signed_repr A) in H by rep_omega)
| context [Int.unsigned (Int.repr ?A) ] =>
try (rewrite (Int.unsigned_repr A) in H by rep_omega)
end.
Hint Rewrite Byte_signed_lem: norm entailer_rewrite.
Hint Rewrite Byte_signed_lem': norm entailer_rewrite.
Hint Rewrite int_repr_byte_signed_eq0: norm entailer_rewrite.
Hint Rewrite int_repr_byte_signed_eq: norm entailer_rewrite.
Ltac do_repr_inj H :=
simpl typeof in H;
try first [apply typed_true_of_bool in H
|apply typed_false_of_bool in H
| apply typed_true_ptr in H
| apply typed_false_ptr_e in H
| apply typed_true_negb_bool_val_p in H
| apply typed_false_negb_bool_val_p in H; [| solve [auto]]
| apply typed_false_negb_bool_val_p' in H
| unfold nullval in H; (*simple*) apply typed_true_tint_Vint in H
| unfold nullval in H; (*simple*) apply typed_false_tint_Vint in H
(*               | simple apply typed_true_tint in H *)
];
rewrite ?ptrofs_to_int_repr in H;
repeat (rewrite -> negb_true_iff in H || rewrite -> negb_false_iff in H);
try apply int_eq_e in H;
match type of H with
(*  don't do these, because they weaken the statement, unfortunately. | _ <> _ => apply repr_neq_e (*int_eq_false_e*) in H | _ <> _ => apply repr64_neq_e in H *)
| _ <> _ => let H' := fresh H "'" in assert (H' := repr_neq_e _ _ H)
| _ <> _ => let H' := fresh H "'" in assert (H' := repr64_neq_e _ _ H)
| Int.eq _ _ = false => apply int_eq_false_e in H
| _ => idtac
end;
first [ simple apply repr_inj_signed in H; [ | rep_omega | rep_omega ]
| simple apply repr_inj_unsigned in H; [ | rep_omega | rep_omega ]
| simple apply repr_inj_signed' in H; [ | rep_omega | rep_omega ]
| simple apply repr_inj_unsigned' in H; [ | rep_omega | rep_omega ]
| match type of H with
| typed_true _  (force_val (sem_cmp_pp Ceq _ _)) =>
apply typed_true_nullptr3 in H
| typed_true _  (force_val (sem_cmp_pp Cne _ _)) =>
apply typed_true_nullptr4 in H
| typed_false _  (force_val (sem_cmp_pp Ceq _ _)) =>
apply typed_false_nullptr3 in H
| typed_false _  (force_val (sem_cmp_pp Cne _ _)) =>
apply typed_false_nullptr4 in H
end
| apply typed_false_nullptr4 in H
| simple apply ltu_repr in H; [ | rep_omega | rep_omega]
| simple apply ltu_repr_false in H; [ | rep_omega | rep_omega]
| simple apply ltu_inv in H; cleanup_repr H
| simple apply ltu_false_inv in H; cleanup_repr H
| simple apply lt_repr in H; [ | rep_omega | rep_omega]
| simple apply lt_repr_false in H; [ | rep_omega | rep_omega]
| simple apply lt_inv in H; cleanup_repr H
| simple apply lt_false_inv in H; cleanup_repr H
| idtac
];
rewrite ?Byte_signed_lem, ?Byte_signed_lem',
?int_repr_byte_signed_eq0, ?int_repr_byte_signed_eq0
in H.
Ltac simpl_fst_snd :=
repeat match goal with
| |- context [fst (?a,?b) ] => change (fst (a,b)) with a
| |- context [snd (?a,?b) ] => change (snd (a,b)) with b
end.
Definition EXP_NAME := tt.
Definition MARKED_ONE {A} (z: A) := z.
Definition EXP_UNIT := tt.
Ltac special_intros_EX :=
match goal with
| z := EXP_UNIT |- _ => clear z; cbv beta; intros _
| z := EXP_NAME |- _ =>
intro;
match goal with a : ?x |- _ =>
change x with (MARKED_ONE x) in a
end;
repeat match goal with
| w := EXP_NAME, v := EXP_NAME, a: MARKED_ONE _ |- _ =>
clear v; unfold MARKED_ONE in a;
destruct a as [a v];
match type of a with ?x =>
change x with (MARKED_ONE x) in a
end
| v := EXP_NAME, a: MARKED_ONE _ |- _ =>
clear v; unfold MARKED_ONE in a; rename a into v
end;
simpl_fst_snd
end.
Tactic Notation "forward_while" constr(Inv) :=
repeat (apply -> seq_assoc; abbreviate_semax);
lazymatch goal with |- semax _ _ (Ssequence _ _) _ => idtac | _ => apply <- semax_seq_skip end;
first [ignore (Inv: environ->mpred)
| fail 1 "Invariant (first argument to forward_while) must have type (environ->mpred)"];
apply semax_pre with Inv;
[ unfold_function_derives_right
| repeat match goal with
| |- semax _ (exp _) _ _ => fail 1
| |- semax _ (PROPx _ _) _ _ => fail 1
| |- semax _ ?Pre _ _ => match Pre with context [ ?F ] => unfold F end
end;
match goal with
| |- semax _ (exp (fun a1 => _)) _ _ =>
let a := fresh a1 in pose (a := EXP_NAME)
| |- semax _ (PROPx ?P ?QR) _ _ =>
let a := fresh "u" in pose (a := EXP_UNIT);
rewrite (trivial_exp (PROPx P QR))
end;
repeat match goal with |- semax _ (exp (fun a1 => (exp (fun a2 => _)))) _ _ =>
let a := fresh a2 in pose (a := EXP_NAME);
rewrite exp_uncurry
end;
eapply semax_seq;
[match goal with |- semax ?Delta ?Pre (Swhile ?e _) _ =>
(* the following line was before: eapply semax_while_3g1; *)
match goal with [ |- semax _ (@exp _ _ ?A _) _ _ ] => eapply (@semax_while_3g1 _ _ A) end;
(* check if we can revert back to the previous version with coq 8.5. (as of December 2015 with compcert 2.6 the above fix is still necessary) The bug happens when we destruct the existential variable of the loop invariant:  (* example.c program: *)
int main(){int i=0; while(i);}
(* verif_example.v file (+you have to Require Import the example.v file produced by clightgen) *)
Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Local Open Scope logic.
start_function.
forward.
pose (Inv := (EX b : bool, PROP () LOCAL (temp _i (Vint (Int.repr (if b then 1 else 0)))) SEP ())).
forward_while Inv. (** FAILS WITH THE FORMER VERSION OF forward_while **)
*)
simpl typeof;
[ reflexivity
| special_intros_EX
| (do_compute_expr1 Delta Pre e; eassumption) ||
fail "The loop invariant is not strong enough to guarantee evaluation of the loop-test expression.
Loop invariant:" Pre
"
Loop test expression:" e
| special_intros_EX;
let HRE := fresh "HRE" in apply semax_extract_PROP; intro HRE;
do_repr_inj HRE;
repeat (apply semax_extract_PROP; intro);
normalize in HRE
]
end
| apply extract_exists_pre; special_intros_EX;
let HRE := fresh "HRE" in apply semax_extract_PROP; intro HRE;
do_repr_inj HRE;
repeat (apply semax_extract_PROP; intro);
normalize in HRE
]
]; abbreviate_semax;
simpl_ret_assert (*autorewrite with ret_assert*).
Inductive Type_of_invariant_in_forward_for_should_be_environ_arrow_mpred_but_is : Type -> Prop := .
Inductive Type_of_bound_in_forward_for_should_be_Z_but_is : Type -> Prop := .
Ltac check_type_forward_for_simple_bound :=
match goal with |- semax _ _ ?c _ =>
let x := constr:(match c with (Ssequence _ (Sloop _ (Sset _ e))) => Some (typeof e) | _ => None end) in let x := eval hnf in x in let x := eval simpl in x in
match x with
| None => idtac
| Some ?t =>
unify (is_int32_type t) true
+ fail 100 "At present, forward_for_simple_bound works only on iteration variables that are (signed or unsigned) int, but your iteration variable has type" t
end
end.
Ltac forward_for_simple_bound n Pre :=
check_Delta; check_POSTCONDITION;
repeat match goal with |-
semax _ _ (Ssequence (Ssequence (Ssequence _ _) _) _) _ =>
apply -> seq_assoc; abbreviate_semax
end;
match goal with |-
semax _ _ (Ssequence (Ssequence (Sfor _ _ _ _) _) _) _ =>
apply -> seq_assoc; abbreviate_semax
| _ => idtac
end;
match type of n with
?t => tryif (unify t Z) then idtac
else fail "Type of bound" n "should be Z but is" t
end;
match type of Pre with
| ?t => tryif (unify t (environ->mpred)) then idtac
else fail "Type of precondition" Pre "should be environ->mpred but is" t
end;
match goal with
| |- semax _ _ (Sfor _ _ _ _) _ =>
rewrite semax_seq_skip
| |- semax _ _ (Ssequence _ (Sloop _ _)) _ =>
rewrite semax_seq_skip
| |- semax _ _ (Ssequence _ ?MORE_COMMANDS) _ =>
revert MORE_COMMANDS;
match goal with
| |- let MORE_COMMANDS := @abbreviate _ (Sloop _ _) in _ =>
intros MORE_COMMANDS;
rewrite semax_seq_skip
end
| _ => idtac
end;
forward_for_simple_bound'' n Pre; [.. | abbreviate_semax; cbv beta; try fwd_skip].
Ltac forward_for3 Inv PreInc Postcond :=
apply semax_seq with Postcond;
[ eapply semax_for_3g1 with (PQR:=PreInc);
[ reflexivity
|intro
| intro ;
match goal with |- ENTAIL ?Delta, ?Pre |-- local (liftx (eq _) (eval_expr ?e)) =>
do_compute_expr1 Delta Pre e;
match goal with v := _ : val , H: ENTAIL _ , _ |-- _ |- _ => subst v; apply H end
end
| intro; let HRE := fresh in
apply semax_extract_PROP; intro HRE;
repeat (apply semax_extract_PROP; fancy_intro true);
do_repr_inj HRE
| intro; let HRE := fresh in
apply semax_extract_PROP; intro HRE;
repeat (apply semax_extract_PROP; fancy_intro true);
do_repr_inj HRE
| intro; let HRE := fresh in
apply derives_extract_PROP; intro HRE;
repeat (apply derives_extract_PROP; fancy_intro true);
do_repr_inj HRE;
match goal with
| |- context [RA_normal (overridePost ?P ?Post)] => change (RA_normal (overridePost ?P ?Post)) with P
end ]
| abbreviate_semax;
repeat (apply semax_extract_PROP; fancy_intro true)
].
Fixpoint no_breaks (s: statement) : bool :=
match s with
| Sbreak => false
| Ssequence a b => andb (no_breaks a) (no_breaks b)
| Sifthenelse _ a b => andb (no_breaks a) (no_breaks b)
| Sloop _ _ => true (* breaks within the inner loop are OK *)
| _ => true
end.
Ltac forward_for2 Inv PreInc :=
repeat  match goal with P := @abbreviate ret_assert _ |- semax _ _ _ ?P' =>
constr_eq P P'; unfold abbreviate in P; subst P
end;
match goal with |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) ?body) _) _ =>
(tryif unify (no_breaks body) true
then idtac
else fail "Since there is a break in the loop body, you need to supply an explicit postcondition using the 3-argument form of forward_for.");
eapply semax_for_3g2 with (PQR:=PreInc);
[ reflexivity
|intro
| intro ;
match goal with |- ENTAIL ?Delta, ?Pre |-- local (liftx (eq _) (eval_expr ?e)) =>
do_compute_expr1 Delta Pre e;
match goal with v := _ : val , H: ENTAIL _ , _ |-- _ |- _ => subst v; apply H end
end
| intro; let HRE := fresh in
apply semax_extract_PROP; intro HRE;
repeat (apply semax_extract_PROP; fancy_intro true);
do_repr_inj HRE
| intro; let HRE := fresh in
apply semax_extract_PROP; intro HRE;
repeat (apply semax_extract_PROP; fancy_intro true);
do_repr_inj HRE
]
end.
Ltac delete_skip :=
repeat apply -> semax_skip_seq;
try apply semax_skip_seq1.
Ltac forward_loop_aux2 Inv PreInc :=
lazymatch goal with
| |- semax _ _ (Sloop _ Sskip) _ =>
tryif (constr_eq Inv PreInc) then (apply (semax_loop_noincr _ Inv); abbreviate_semax)
else (apply (semax_loop _ Inv PreInc); [delete_skip | ]; abbreviate_semax)
| |- semax _ _ (Sloop _ _) _ =>apply (semax_loop _ Inv PreInc); [delete_skip | ]; abbreviate_semax
end.
Ltac forward_loop_aux1 Inv PreInc:=
lazymatch goal with
| |- semax _ _ (Sfor _ _ _ _) _ => apply semax_seq' with Inv; [abbreviate_semax | forward_loop_aux2 Inv PreInc]
| |- semax _ _ (Sloop _ _) _ => apply semax_pre with Inv; [ | forward_loop_aux2 Inv PreInc]
| |- semax _ _ (Swhile ?E ?B) _ =>
let x := fresh "x" in set (x := Swhile E B); hnf in x; subst x;
apply semax_pre with Inv; [ | forward_loop_aux2 Inv PreInc]
end.
Tactic Notation "forward_loop" constr(Inv) "continue:" constr(PreInc) "break:" constr(Post) :=
repeat simple apply seq_assoc1;
repeat apply -> semax_seq_skip;
match goal with
| |- semax _ _ (Ssequence (Sloop _ _) _) _ =>
apply semax_seq with Post; [forward_loop_aux1 Inv PreInc | abbreviate_semax ]
| |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
apply semax_seq with Post; [forward_loop_aux1 Inv PreInc | abbreviate_semax ]
| |- semax _ _ (Ssequence (Swhile _ _) _) _ =>
apply semax_seq with Post; [forward_loop_aux1 Inv PreInc | abbreviate_semax ]
| |- semax _ _ _ ?Post' =>
tryif (unify Post Post') then forward_loop_aux1 Inv PreInc
else (apply (semax_post1_flipped Post); [ forward_loop_aux1 Inv PreInc | ])
end.
Ltac check_no_incr S :=
let s' := eval hnf in S in
match s' with
| Ssequence ?x _ => check_no_incr x
| Sloop _ ?inc => let i' := eval hnf in inc in match i' with Sskip => idtac end
| Sloop _ _ => fail 100 "Your loop has an increment statement, so your forward_loop must have a continue: invariant"
| Sfor _ _ ?inc _ => let i' := eval hnf in inc in match i' with Sskip => idtac end
| Sfor _ _ _ _ => fail 100 "Your loop has an increment statement, so your forward_loop must have a continue: invariant"
| _ => fail 100 "applied forward_loop to something that is not a loop"
end.
Tactic Notation "forward_loop" constr(Inv) "continue:" constr(PreInc) :=
repeat apply -> semax_seq_skip;
lazymatch goal with
| |- semax _ _ (Ssequence (Sloop _ _) _) _ =>
fail 100 "Your loop is followed by more statements, so you must use the form of forward_loop with the break: keyword to supply an explicit postcondition for the loop."
| |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
fail 100 "Your loop is followed by more statements, so you must use the form of forward_loop with the break: keyword to supply an explicit postcondition for the loop."
| P := @abbreviate ret_assert ?Post' |- semax _ _ _ ?Post =>
first [constr_eq P Post | fail 100 "forward_loop failed; try doing abbreviate_semax first"];
try (has_evar Post'; fail 100 "Error: your postcondition " P " has unification variables (evars), so you must use the form of forward_loop with the break: keyword to supply an explicit postcondition for the loop.");
forward_loop Inv continue: PreInc break: Post
| |- semax _ _ _ _ => fail 100 "forward_loop failed; try doing abbreviate_semax first"
| |- _ => fail 100 "forward_loop applicable only to a semax goal"
end.
Tactic Notation "forward_loop" constr(Inv) "break:" constr(Post) "continue:" constr(PreInc) :=
forward_loop Inv continue: PreInc break: Post.
Tactic Notation "forward_loop" :=
fail "Usage:   forward_loop Inv,     where Inv is your loop invariant".
Fixpoint quickflow (c: statement) (ok: exitkind->bool) : bool :=
match c with
| Sreturn _ => ok EK_return
| Ssequence c1 c2 =>
quickflow c1 (fun ek => match ek with
| EK_normal => quickflow c2 ok
| _ => ok ek
end)
| Sifthenelse e c1 c2 =>
andb (quickflow c1 ok) (quickflow c2 ok)
| Sloop body incr =>
andb (quickflow body (fun ek => match ek with
| EK_normal => true
| EK_break => ok EK_normal
| EK_continue => true
| EK_return => ok EK_return
end))
(quickflow incr (fun ek => match ek with
| EK_normal => true
| EK_break => ok EK_normal
| EK_continue => false
| EK_return => ok EK_return
end))
| Sbreak => ok EK_break
| Scontinue => ok EK_continue
| Sswitch _ _ => false   (* this could be made more generous *)
| Slabel _ c => quickflow c ok
| Sgoto _ => false
| _ => ok EK_normal
end.
Fixpoint nobreaksx (s: statement) : bool :=
match s with
| Sbreak => false
| Scontinue => false
| Ssequence c1 c2 => nobreaksx c1 && nobreaksx c2
| Sifthenelse _ c1 c2 => nobreaksx c1 && nobreaksx c2
| _ => true  (* including Sloop case! *)
end.
Ltac check_nocontinue s :=
let s' := eval hnf in s in
lazymatch s' with
| Ssequence ?x _ => check_nocontinue x
| Sloop ?body _ => unify (nocontinue body) true
| _ => fail 100 "applied forward_loop to something that is not a loop"
end.
Ltac forward_loop_nocontinue2 Inv :=
apply semax_loop_nocontinue; delete_skip; abbreviate_semax.
Ltac forward_loop_nocontinue1 Inv :=
lazymatch goal with
| |- semax _ _ (Sfor _ _ _ _) _ => apply semax_seq' with Inv; [abbreviate_semax | forward_loop_nocontinue2 Inv]
| |- semax _ _ (Sloop _ _) _ => apply semax_pre with Inv; [ | forward_loop_nocontinue2 Inv]
| |- semax _ _ (Swhile ?E ?B) _ =>
let x := fresh "x" in set (x := Swhile E B); unfold Swhile at 1 in x; subst x;
apply semax_pre with Inv; [ | forward_loop_nocontinue2 Inv]
end.
Ltac forward_loop_nocontinue Inv Post :=
repeat simple apply seq_assoc1;
repeat apply -> semax_seq_skip;
match goal with
| |- semax _ _ (Ssequence _ _) _ =>
apply semax_seq with Post; [forward_loop_nocontinue1 Inv  | abbreviate_semax ]
| |- semax _ _ _ ?Post' =>
tryif (unify Post Post') then forward_loop_nocontinue1 Inv
else (apply (semax_post1_flipped Post); [ forward_loop_nocontinue1 Inv  | ])
end.
Ltac forward_loop_nocontinue_nobreak Inv :=
repeat apply -> semax_seq_skip;
lazymatch goal with
| |- semax _ _ (Ssequence (Swhile _ ?S) _) _ =>
tryif (unify (nocontinue S) true; unify (nobreaksx S) true) then forward_while Inv
else fail 100 "Use forward_while, or (unfold Swhile at 1) and then use forward_loop"
| |- semax _ _ (Ssequence (Sloop _ _) _) _ =>
fail 100 "Your loop is followed by more statements, so you must use the form of forward_loop with the break: keyword to supply an explicit postcondition for the loop."
| |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
fail 100 "Your loop is followed by more statements, so you must use the form of forward_loop with the break: keyword to supply an explicit postcondition for the loop."
| P := @abbreviate ret_assert ?Post' |- semax _ _ _ ?Post =>
first [constr_eq P Post | fail 100 "forward_loop failed; try doing abbreviate_semax first"];
try (has_evar Post'; fail 100 "Error: your postcondition " P " has unification variables (evars), so you must use the form of forward_loop with the break: keyword to supply an explicit postcondition for the loop.");
forward_loop_nocontinue Inv Post
| |- semax _ _ _ _ => fail 100 "forward_loop failed; try doing abbreviate_semax first"
| |- _ => fail 100 "forward_loop applicable only to a semax goal"
end.
Tactic Notation "forward_loop" constr(Inv)  :=
repeat simple apply seq_assoc1;
repeat apply -> semax_seq_skip;
lazymatch goal with
| |- semax _ _ (Ssequence (Sfor _ ?e2 ?s3 ?s4) _) _ =>
let c := constr:(Sloop (Ssequence (Sifthenelse e2 Sskip Sbreak) s3) s4) in
tryif (check_nocontinue c)
then forward_loop_nocontinue_nobreak Inv
else (check_no_incr c; forward_loop Inv continue: Inv)
| |- semax _ _ ?c _ =>
tryif (check_nocontinue c)
then forward_loop_nocontinue_nobreak Inv
else (check_no_incr c; forward_loop Inv continue: Inv)
end.
Tactic Notation "forward_loop" constr(Inv) "break:" constr(Post) :=
repeat simple apply seq_assoc1;
repeat apply -> semax_seq_skip;
lazymatch goal with
| |- semax _ _ (Ssequence (Sfor _ ?e2 ?s3 ?s4) _) _ =>
let c := constr:(Sloop (Ssequence (Sifthenelse e2 Sskip Sbreak) s3) s4) in
tryif (check_nocontinue c)
then forward_loop_nocontinue Inv Post
else (check_no_incr c; forward_loop Inv continue: Inv break: Post)
| |- semax _ _ ?c _ =>
tryif (check_nocontinue c)
then forward_loop_nocontinue Inv Post
else (check_no_incr c; forward_loop Inv continue: Inv break: Post)
end.
Tactic Notation "forward_for" constr(Inv) "continue:" constr(PreInc) :=
check_Delta; check_POSTCONDITION;
repeat simple apply seq_assoc1;
lazymatch type of Inv with
| _ -> environ -> mpred => idtac
| _ => fail "Invariant (first argument to forward_for) must have type (_ -> environ -> mpred)"
end;
lazymatch type of PreInc with
| _ -> environ -> mpred => idtac
| _ => fail "PreInc (continue: argument to forward_for) must have type (_ -> environ -> mpred)"
end;
lazymatch goal with
| |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
apply -> seq_assoc;
apply semax_seq' with (exp Inv); abbreviate_semax;
[  | eapply semax_seq;
[ forward_for2 Inv PreInc
| abbreviate_semax;
apply extract_exists_pre; intro;
let HRE := fresh in
apply semax_extract_PROP; intro HRE;
repeat (apply semax_extract_PROP; fancy_intro true);
do_repr_inj HRE]
]
| |- semax _ _ (Sfor _ _ _ _) ?Post =>
apply semax_seq' with (exp Inv); abbreviate_semax;
[  | forward_for3 Inv PreInc Post]
| |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) _) _) ?Post =>
apply semax_pre with (exp Inv);
[  | forward_for3 Inv PreInc Post]
| |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) _) _) _ =>
apply semax_pre with (exp Inv);
[ unfold_function_derives_right | forward_for2 Inv PreInc ]
| |- _ => fail "forward_for2x cannot recognize the loop"
end.
Tactic Notation "forward_for" constr(Inv) "continue:" constr(PreInc) "break:" constr(Postcond) :=
check_Delta; check_POSTCONDITION;
repeat simple apply seq_assoc1;
lazymatch type of Inv with
| _ -> environ -> mpred => idtac
| _ => fail "Invariant (first argument to forward_for) must have type (_ -> environ -> mpred)"
end;
lazymatch type of PreInc with
| _ -> environ -> mpred => idtac
| _ => fail "PreInc (second argument to forward_for) must have type (_ -> environ -> mpred)"
end;
lazymatch type of Postcond with
| environ -> mpred => idtac
| _ => fail "Postcond (third argument to forward_for) must have type (environ -> mpred)"
end;
lazymatch goal with
| |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
apply -> seq_assoc;
apply semax_seq' with (exp Inv); abbreviate_semax;
[  | forward_for3 Inv PreInc Postcond]
| |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) _) _) _ =>
apply semax_pre with (exp Inv);
[ unfold_function_derives_right | forward_for3 Inv PreInc Postcond ]
end.
Tactic Notation "forward_for" constr(Inv) "break:" constr(Postcond) "continue:" constr(PreInc) :=
forward_for Inv continue: PreInc break: Postcond.
Tactic Notation "forward_for" constr(Inv) constr(PreInc) :=
fail "Usage of the forward_for tactic:
forward_for  Inv   (* where Inv: A->environ->mpred is a predicate on index values of type A *)
forward_for Inv continue: PreInc (* where Inv,PreInc are predicates on index values of type A *)
forward_for Inv continue: PreInc break:Post (* where Post: environ->mpred is an assertion *)".
Tactic Notation "forward_for" constr(Inv) :=
check_Delta; check_POSTCONDITION;
repeat simple apply seq_assoc1;
lazymatch type of Inv with
| _ -> environ -> mpred => idtac
| _ => fail "Invariant (first argument to forward_for) must have type (_ -> environ -> mpred)"
end;
lazymatch goal with
| |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
apply semax_convert_for_while';
[(reflexivity ||
fail "Your for-loop has a continue statement, so your forward_for needs a continue: clause")
| (reflexivity || fail "Unexpected continue statement in for-loop increment")
| apply semax_seq' with (exp Inv);
[  |  forward_while (EX x:_, Inv x); [ apply ENTAIL_refl | | |  ]  ] ]
| |- semax _ _ (Sfor _ _ _ _) _ =>
apply semax_convert_for_while;
[(reflexivity ||
fail "Your for-loop has a continue statement, so your forward_for needs a continue: clause")
| (reflexivity || fail "Unexpected continue statement in for-loop increment")
| apply semax_seq' with (exp Inv);
[  |  forward_while (EX x:_, Inv x);
[ apply ENTAIL_refl | | | eapply semax_post_flipped'; [apply semax_skip | ] ]  ] ]
end.
Ltac process_cases sign :=
match goal with
| |- semax _ _ (seq_of_labeled_statement
match select_switch_case ?N (LScons (Some ?X) ?C ?SL)
with Some _ => _ | None => _ end) _ =>
let y := constr:(adjust_for_sign sign X) in let y := eval compute in y in
rewrite (select_switch_case_signed y);
[ | reflexivity | clear; compute; split; congruence];
let E := fresh "E" in let NE := fresh "NE" in
destruct (zeq N (Int.unsigned (Int.repr y))) as [E|NE];
[ rewrite if_true; [ unfold seq_of_labeled_statement at 1 | symmetry; apply E];
apply unsigned_eq_eq in E;
match sign with
| Signed => apply repr_inj_signed in E; [ | rep_omega | rep_omega]
| Unsigned => apply repr_inj_unsigned in E; [ | rep_omega | rep_omega]
end;
try match type of E with ?a = _ => is_var a; subst a end;
repeat apply -> semax_skip_seq
| rewrite if_false by (contradict NE; symmetry; apply NE);
process_cases sign
]
| |- semax _ _ (seq_of_labeled_statement
match select_switch_case ?N (LScons None ?C ?SL)
with Some _ => _ | None => _ end) _ =>
change (select_switch_case N (LScons None C SL))
with (select_switch_case N SL);
process_cases sign
| |- semax _ _ (seq_of_labeled_statement
match select_switch_case ?N LSnil
with Some _ => _ | None => _ end) _ =>
change (select_switch_case N LSnil)
with (@None labeled_statements);
cbv iota;
unfold seq_of_labeled_statement at 1;
repeat apply -> semax_skip_seq
end.
Ltac forward_switch' :=
match goal with
| |- semax ?Delta (PROPx ?P (LOCALx ?Q (SEPx ?R))) (Sswitch ?e _) _ =>
let sign := constr:(signof e) in let sign := eval hnf in sign in
let HRE := fresh "H" in let v := fresh "v" in
evar (v: val);
do_compute_expr Delta P Q R e v HRE;
simpl in v;
let n := fresh "n" in evar (n: int);
let H := fresh in assert (H: v=Vint n) by (unfold v,n; reflexivity);
let A := fresh in
match goal with |- ?AA => set (A:=AA) end;
revert n H; normalize; intros n H; subst A;
let n' := fresh "n" in pose (n' := Int.unsigned n);
let H' := fresh in assert (H': n = Int.repr n');
[try (symmetry; apply Int.repr_unsigned)
| rewrite H,H' in HRE; clear H H';
subst n' n v;
rewrite (Int.repr_unsigned (Int.repr _)) in HRE;
eapply semax_switch_PQR;
[reflexivity | check_typecheck | exact HRE
| clear HRE; unfold select_switch at 1; unfold select_switch_default at 1;
try match goal with H := @abbreviate statement _ |- _ => clear H end;
process_cases sign ]
]
end.
Definition nofallthrough ek :=
match ek with
| EK_normal => false
| _ => true
end.
Ltac forward_if'_new :=
check_Delta; check_POSTCONDITION;
repeat apply -> semax_seq_skip;
repeat (apply seq_assoc1; try apply -> semax_seq_skip);
match goal with
| |- semax ?Delta (PROPx ?P (LOCALx ?Q (SEPx ?R))) (Sifthenelse ?e ?c1 ?c2) _ =>
let HRE := fresh "H" in let v := fresh "v" in
evar (v: val);
do_compute_expr Delta P Q R e v HRE;
simpl in v;
apply (semax_ifthenelse_PQR' _ v);
[ reflexivity | entailer | assumption
| clear HRE; subst v; apply semax_extract_PROP; intro HRE;
do_repr_inj HRE;
repeat (apply semax_extract_PROP; intro);
try rewrite Int.signed_repr in HRE by rep_omega;
repeat apply -> semax_skip_seq;
abbreviate_semax
| clear HRE; subst v; apply semax_extract_PROP; intro HRE;
do_repr_inj HRE;
repeat (apply semax_extract_PROP; intro);
try rewrite Int.signed_repr in HRE by rep_omega;
repeat apply -> semax_skip_seq;
abbreviate_semax
]
| |- semax ?Delta (PROPx ?P (LOCALx ?Q (SEPx ?R))) (Ssequence (Sifthenelse ?e ?c1 ?c2) _) _ =>
tryif (unify (orb (quickflow c1 nofallthrough) (quickflow c2 nofallthrough)) true)
then (apply semax_if_seq; forward_if'_new)
else fail "Because your if-statement is followed by another statement, you need to do 'forward_if Post', where Post is a postcondition of type (environ->mpred) or of type Prop"
| |- semax _ (@exp _ _ _ _) _ _ =>
fail "First use Intros ... to take care of the EXistentially quantified variables in the precondition"
| |- semax _ _ (Sswitch _ _) _ =>
forward_switch'
| |- semax _ _ (Ssequence (Sifthenelse _ _ _) _) _ =>
fail "forward_if failed for some unknown reason, perhaps your precondition is not in canonical form"
| |- semax _ _ (Ssequence (Sswitch _ _) _) _ =>
fail "Because your switch statement is followed by another statement, you need to do 'forward_if Post', where Post is a postcondition of type (environ->mpred) or of type Prop"
end.
Hint Resolve ENTAIL_break_normal ENTAIL_continue_normal ENTAIL_return_normal : core.
Hint Extern 0 (ENTAIL _, _ |-- _) =>
match goal with |- ENTAIL _, ?A |-- ?B => constr_eq A B; simple apply ENTAIL_refl end : core.
Ltac forward_if_tac post :=
check_Delta; check_POSTCONDITION;
repeat (apply -> seq_assoc; abbreviate_semax);
repeat apply -> semax_seq_skip;
first [ignore (post: environ->mpred)
| fail 1 "Invariant (first argument to forward_if) must have type (environ->mpred)"];
match goal with
| |- semax _ _ (Sifthenelse _ _ _) (overridePost post _) =>
forward_if'_new
| |- semax _ _ (Sswitch _ _) _ =>
forward_switch'
| |- semax _ _ (Sifthenelse _ _ _) ?P =>
apply (semax_post_flipped (overridePost post P));
[ forward_if'_new
| try subst P; unfold abbreviate;
simpl_ret_assert;
try (match goal with |- ?A => no_evars A end;
try apply ENTAIL_refl;
try solve [normalize])
| intros; try subst P; unfold abbreviate;
simpl_ret_assert;
try (match goal with |- ?A => no_evars A end;
try apply ENTAIL_refl;
try solve [normalize])
..
]
| |- semax _ _ (Ssequence (Sifthenelse _ _ _) _) _ =>
apply semax_seq with post;
[forward_if'_new
| abbreviate_semax;
simpl_ret_assert (*autorewrite with ret_assert*)]
| |- semax _ _ (Ssequence (Sswitch _ _) _) _ =>
apply semax_seq with post;
[forward_switch'
| abbreviate_semax;
simpl_ret_assert (*autorewrite with ret_assert*)]
end.
Ltac remove_LOCAL name Q :=
let i := eval hnf in (find_LOCAL_index name O Q) in
match i with
| Some ?i' =>
let r := eval cbv iota zeta beta delta [delete_nth] in (delete_nth i' Q) in
constr:(r)
| None =>
constr:(Q)
end.
Ltac remove_LOCAL2 Qr Q :=
match Qr with
| nil => constr:(Q)
| cons ?Qr_head ?Qr_tail =>
match Qr_head with
| temp ?name _ =>
let Q' := remove_LOCAL name Q in remove_LOCAL2 Qr_tail Q'
| _ =>
remove_LOCAL2 Qr_tail Q
end
end.
Tactic Notation "forward_if" constr(post) :=
lazymatch type of post with
| Prop =>
match goal with
| |- semax _ (PROPx (?P) ?Q) _ _ =>
forward_if_tac (PROPx (post :: P) Q)
end
| list Prop =>
match goal with
| |- semax _ (PROPx (?P) ?Q) _ _ =>
let P' := eval cbv iota zeta beta delta [app] in (post ++ P) in
forward_if_tac (PROPx P' Q)
end
| localdef =>
match goal with
| |- semax _ (PROPx (?P) (LOCALx ?Q ?R)) _ _ =>
let Q' := remove_LOCAL2 constr:(cons post nil) Q in
forward_if_tac (PROPx (P) (LOCALx (post :: Q') R))
end
| list localdef =>
match goal with
| |- semax _ (PROPx (?P) (LOCALx ?Q ?R)) _ _ =>
let Q' := remove_LOCAL2 post Q in
let Q'' := eval cbv iota zeta beta delta [app] in (post ++ Q') in
forward_if_tac (PROPx (P) (LOCALx Q'' R))
end
| _ => forward_if_tac post
end.
Tactic Notation "forward_if" :=
forward_if'_new.
Ltac normalize :=
try match goal with |- context[subst] =>  autorewrite with subst typeclass_instances end;
try match goal with |- context[ret_assert] =>  autorewrite with ret_assert typeclass_instances end;
match goal with
| |- semax _ _ _ _ =>
floyd.seplog_tactics.normalize;
repeat
(first [ simpl_tc_expr
| simple apply semax_extract_PROP; fancy_intros true
| move_from_SEP
]; cbv beta; msl.log_normalize.normalize)
| |- _  =>
floyd.seplog_tactics.normalize
end.
Ltac renormalize :=
progress (autorewrite with subst norm1 norm2); normalize;
repeat (progress (autorewrite with subst norm1 norm2); normalize).
Hint Rewrite eqb_ident_true : subst.
Hint Rewrite eqb_ident_false using solve [auto] : subst.
Hint Rewrite subst_temp_special using safe_auto_with_closed: subst.
Ltac ensure_normal_ret_assert :=
match goal with
| |- semax _ _ _ (normal_ret_assert _) => idtac
| |- semax _ _ _ _ => apply sequential
end.
Ltac ensure_open_normal_ret_assert :=
try simple apply sequential';
match goal with
| |- semax _ _ _ (normal_ret_assert ?X) => is_evar X
end.
Definition This_is_a_warning := tt.
Inductive Warning: unit -> unit -> Prop :=
ack : forall s s', Warning s s'.
Definition IGNORE_THIS_WARNING_USING_THE_ack_TACTIC_IF_YOU_WISH := tt.
Ltac ack := apply ack.
Ltac assert_ P :=
let H := fresh in assert (H: P); [ | clear H].
Ltac warn s :=
assert_ (Warning s
IGNORE_THIS_WARNING_USING_THE_ack_TACTIC_IF_YOU_WISH).
(* Given gfs, gfs0, and a name for gfs1, instantiate gfs1 s.t. (gfs = gfs1 ++ gfs0). Called suffix because these paths are reversed lists. *)
Ltac calc_gfs_suffix gfs gfs0 gfs1 :=
let len := fresh "len" in
pose ((length gfs - length gfs0)%nat) as len;
hnf in len;
match goal with
| len := ?len' |- _ =>
pose (firstn len' gfs) as gfs1
end;
clear len;
unfold gfs in gfs1;
let gfs1' := (eval_list gfs1) in change gfs1' in (value of gfs1);
let gfs0' := (eval_list gfs0) in change gfs0' in (value of gfs0);
change gfs with (gfs1 ++ gfs0) in *.
Ltac find_load_result Hresult t_root gfs0 v gfs1 :=
let result := fresh "result" in evar (result: val);
assert (Hresult: JMeq (proj_reptype (nested_field_type t_root gfs0) gfs1 v) result);
subst result;
[ (solve_load_rule_evaluation || fail 1000 "solve_load_rule_evaluation' failed")
| ].
Ltac solve_efield_denote Delta P Q R efs gfs H :=
evar (gfs : list gfield);
assert (ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |-- local (efield_denote efs gfs)) as H;
[
unfold efs, gfs;
match goal with
| efs := nil |- _ =>
instantiate (1 := nil);
intros rho; apply prop_right; constructor
| efs := ?ef :: ?efs' |- _ =>
let efs0 := fresh "efs" in
let gfs0 := fresh "gfs" in
let H0 := fresh "H" in
pose efs' as efs0;
solve_efield_denote Delta P Q R efs0 gfs0 H0;
match goal with
| gfs0 := ?gfs0' |- _ =>
match ef with
| eArraySubsc ?ei =>
let HA := fresh "H" in
let vi := fresh "vi" in evar (vi: val);
do_compute_expr Delta P Q R ei vi HA;
revert vi HA;
let vvvv := fresh "vvvv" in
let HHHH := fresh "HHHH" in
match goal with
| |- let vi := ?V in _ => remember V as vvvv eqn:HHHH
end;
autorewrite with norm in HHHH;
match type of HHHH with
| _ = Vint (Int.repr _) => idtac
| _ = Vint (Int.sub _ _) => unfold Int.sub in HHHH
| _ = Vint (Int.add _ _) => unfold Int.add in HHHH
| _ = Vint (Int.mul _ _) => unfold Int.mul in HHHH
| _ = Vint (Int.and _ _) => unfold Int.and in HHHH
| _ = Vint (Int.or _ _) => unfold Int.or in HHHH
| _ = Vint ?V =>
replace V with (Int.repr (Int.unsigned V)) in HHHH
by (rewrite (Int.repr_unsigned V); reflexivity)
end;
subst vvvv; intros vi HA;
match goal with
| vi := Vint (Int.repr ?i) |- _ => instantiate (1 := ArraySubsc i :: gfs0')
end;
let HB := fresh "H" in
assert (is_int_type (typeof ei) = true) as HB by reflexivity;
apply (efield_denote_cons_array _ _ _ _ _ H0 HA HB)
| eStructField ?i =>
instantiate (1 := StructField i :: gfs0');
apply efield_denote_cons_struct, H0
| eUnionField ?i =>
instantiate (1 := UnionField i :: gfs0');
apply efield_denote_cons_union, H0
end
end
end
|].
Hint Rewrite @sem_add_ptr_int_lem using (try reflexivity; assumption) : norm1.
Hint Rewrite @sem_add_pi' using (solve [try reflexivity; auto with norm ; rep_omega]) : norm.
(* Lemma offset_val_sem_add_pi: forall {CS: compspecs} ofs t0 si v i, match si with | Signed => Int.min_signed <= i <= Int.max_signed | Unsigned => 0 <= i <= Int.max_unsigned end -> offset_val ofs (force_val (sem_add_ptr_int t0 si v (Vint (Int.repr i)))) = offset_val ofs (offset_val (sizeof t0 * i) v). Hint Rewrite @offset_val_sem_add_pi using (solve [auto with norm ; rep_omega]) : norm. *)
Arguments field_type i m / .
Arguments nested_field_type {cs} t gfs / .
Ltac really_simplify A :=
let aa := fresh "aa" in
pose (aa := A); compute in aa; change A with aa; subst aa.
Ltac simple_value v :=
match v with
| Vundef => idtac
| Vint _ => idtac
| Vlong _ => idtac
| Vfloat _ => idtac
| Vsingle _ => idtac
| Vptr _ _ => idtac
| list_repeat (Z.to_nat _) ?v' => simple_value v'
end.
Inductive undo_and_first__assert_PROP: Prop -> Prop := .
Ltac default_entailer_for_store_tac := try solve [entailer!].
Ltac entailer_for_store_tac := default_entailer_for_store_tac.
Ltac load_tac :=
ensure_normal_ret_assert;
hoist_later_in_pre;
first [sc_set_load_store.cast_load_tac | sc_set_load_store.load_tac].
Ltac simpl_proj_reptype :=
progress
match goal with |- context [@proj_reptype ?cs ?t ?gfs ?v] =>
let d := fresh "d" in let Hd := fresh "Hd" in
remember (@proj_reptype cs t gfs v) as d eqn:Hd;
unfold proj_reptype, proj_gfield_reptype, unfold_reptype,
nested_field_type, nested_field_rec in Hd;
rewrite ?eq_rect_r_eq, <- ?eq_rect_eq in Hd;
simpl proj_struct in Hd;
rewrite ?eq_rect_r_eq, <- ?eq_rect_eq in Hd;
subst d
end.
Ltac store_tac :=
ensure_open_normal_ret_assert;
hoist_later_in_pre;
sc_set_load_store.store_tac.
(* END new semax_load and semax_store tactics *************************)
Ltac forward0 :=  (* USE FOR DEBUGGING *)
match goal with
| |- @semax _ _ _ ?PQR (Ssequence ?c1 ?c2) ?PQR' =>
let Post := fresh "Post" in
evar (Post : environ->mpred);
apply semax_seq' with Post;
[
| unfold Post; clear Post ]
end.
(* Lemma normal_ret_assert_derives'': forall P Q R, P |-- R ->  normal_ret_assert (local Q && P) |-- normal_ret_assert R. *)
(* Lemma frame_ret_assert_derives P Q: P |-- Q -> frame_ret_assert P |-- frame_ret_assert Q.  (* Lemma function_body_ret_assert_derives t P Q: P |-- Q -> function_body_ret_assert t P |-- function_body_ret_assert t Q. *)
Ltac entailer_for_return := entailer.
Ltac solve_return_outer_gen := solve [repeat constructor].
Ltac solve_return_inner_gen :=
match goal with
| |- return_inner_gen _ ?v ?P _ =>
match P with
| exp _ =>
simple apply return_inner_gen_EX;
let a := fresh "a" in
intro a;
eexists;
split;
[ solve_return_inner_gen
| build_func_abs_right
]
| PROPx _ (LOCALx _ (SEPx _)) =>
match v with
| Some _ => first [ simple apply return_inner_gen_canon_Some;
unfold VST_floyd_app; reflexivity
| simple apply return_inner_gen_canon_nil;
unfold VST_floyd_app; reflexivity
| fail 1000 "the LOCAL clauses of this POSTCONDITION should only contain ret_temp. Other variables appears there now."]
| None   => first [ simple apply return_inner_gen_canon_nil;
unfold VST_floyd_app; reflexivity
| fail 1000 "the LOCAL clauses of this POSTCONDITION should not contain any variable."]
end
| _ => first [ simple apply return_inner_gen_main
| fail 1000 "the POSTCONDITION should be in an existential canonical form."
"One possible cause of this is some 'simpl in *' command which destroys the existential form in POSTCONDITION."]
end
end.
Inductive fn_data_at {cs: compspecs} (Delta: tycontext) (T2: PTree.t (type * val)): ident * type -> mpred -> Prop :=
| fn_data_at_intro: forall i t p,
(complete_legal_cosu_type t && (sizeof t <? Ptrofs.modulus) && is_aligned cenv_cs ha_env_cs la_env_cs t 0 = true)%bool ->
msubst_eval_lvar Delta T2 i t = Some p ->
fn_data_at Delta T2 (i, t) (data_at_ Tsh t p).
Ltac solve_Forall2_fn_data_at :=
solve
[ apply Forall2_nil
| apply Forall2_cons; [ apply fn_data_at_intro; [reflexivity | solve_msubst_eval_lvar] | solve_Forall2_fn_data_at]].
Ltac solve_canon_derives_stackframe :=
solve
[ simple apply canonicalize_stackframe_emp
| try unfold stackframe_of;
simple eapply canonicalize_stackframe;
[ prove_local2ptree
| solve_Forall2_fn_data_at
]
].
Ltac fold_frame_function_body :=
match goal with P := @abbreviate ret_assert _ |- _ => unfold abbreviate in P; subst P end;
match goal with |- semax _ _ _ ?R =>
match R with {| RA_return := (fun vl rho => bind_ret _ ?t ?P _ * stackframe_of ?f _) |} =>
apply semax_post with (frame_ret_assert (function_body_ret_assert t P) (stackframe_of f));
[ simpl_ret_assert; rewrite FF_sepcon; apply andp_left2; apply FF_left
| simpl_ret_assert; rewrite FF_sepcon; apply andp_left2; apply FF_left
| simpl_ret_assert; rewrite FF_sepcon; apply andp_left2; apply FF_left
| simpl_ret_assert; solve [auto]
|]
end
end.

Lemma fold_another_var_block:
forall {cs: compspecs} Delta P Q R P' Q' R' i (t: type) vbs T1 T2 GV p,
local2ptree Q = (T1,T2,[],GV) ->
complete_legal_cosu_type t = true ->
sizeof t <? Ptrofs.modulus = true ->
is_aligned cenv_cs ha_env_cs la_env_cs t 0 = true ->
(var_types Delta) ! i = Some t ->
T2 ! i = Some (t,p) ->
ENTAIL Delta, PROPx P (LOCALx Q (SEPx R))
|-- PROPx P' (LOCALx Q' (SEPx (data_at_ Tsh t p :: R')))
* fold_right sepcon emp (map (var_block Tsh) vbs) ->
ENTAIL Delta, PROPx P (LOCALx Q (SEPx R))
|-- PROPx P' (LOCALx Q' (SEPx R'))
* fold_right sepcon emp (map (var_block Tsh) ((i,t)::vbs)).