Local Open Scope logic.
Ltac unfold_for_go_lower :=
cbv delta [PROPx LOCALx SEPx locald_denote
eval_exprlist eval_expr eval_lvalue cast_expropt
eval_binop eval_unop force_val1 force_val2
msubst_tc_expropt msubst_tc_expr msubst_tc_exprlist msubst_tc_lvalue msubst_tc_LR (* msubst_tc_LR_strong *) msubst_tc_efield msubst_simpl_tc_assert
function_body_ret_assert frame_ret_assert
make_args' bind_ret get_result1 retval
classify_cast
(* force_val sem_cast_neutral ... NOT THESE TWO!  *)
denote_tc_assert (* tc_andp tc_iszero *)
liftx LiftEnviron Tarrow Tend lift_S lift_T
lift_prod lift_last lifted lift_uncurry_open lift_curry
local lift lift0 lift1 lift2 lift3
] beta iota.
Ltac go_lower0 :=
intros ?rho;
try (simple apply grab_tc_environ; intro);
repeat (progress unfold_for_go_lower; simpl).
Ltac old_go_lower :=
go_lower0;
autorewrite with go_lower;
try findvars;
simpl;
autorewrite with go_lower;
try match goal with H: tc_environ _ ?rho |- _ => clear H rho end.
Hint Rewrite eval_id_same : go_lower.
Hint Rewrite eval_id_other using solve [clear; intro Hx; inversion Hx] : go_lower.
(*Hint Rewrite Vint_inj' : go_lower.*)
(*** New go_lower stuff ****)
Ltac safe_subst x := subst x.
Ltac safe_subst_any := subst_any.
(* safe_subst is meant to avoid doing rewrites or substitution of variables that are in the scope of a unification variable.  Right now, the tactic is a placeholder for real tactic that will detect the scope violation and (if so) avoid doing the substition.  See issue #186. *)
Ltac lower_one_temp_Vint' :=
match goal with
| |- (local _ && PROPx _ (LOCALx (temp _ ?v :: _) _)) _ |-- _ =>
is_var v;
simple eapply lower_one_temp_Vint';
[ reflexivity | ];
let v' := fresh "v" in rename v into v';
let tc := fresh "TC" in
intros [v [? [tc ?EVAL]]]; unfold tc_val in tc; safe_subst v';
revert tc; fancy_intro true
end.
Ltac gvar_headptr_intro_case1 gv H i :=
match goal with
| _ := gv i |- _ => fail 1
| H: isptr (gv i), H': headptr (gv i) |- _ => fail 1
| _ => generalize (H i _ ltac:(first[reflexivity | eassumption])); fancy_intro true
end.
Ltac gvar_headptr_intro_case2 gv H x i :=
match goal with
| H: isptr x, H': headptr x |- _ => fail 1
| _ => generalize ((H i _ ltac:(first[reflexivity | eassumption])): headptr x); fancy_intro true
end.
Ltac gvar_headptr_intro gv H:=
repeat
match goal with
| x:= gv ?i |- _ =>
gvar_headptr_intro_case2 gv H x i
| |- context [gv ?i] =>
gvar_headptr_intro_case1 gv H i
| _: context [gv ?i] |- _ =>
gvar_headptr_intro_case1 gv H i
| x:= context [gv ?i] |- _ =>
gvar_headptr_intro_case1 gv H i
end.
Fixpoint remove_localdef (x: localdef) (l: list localdef) : list localdef :=
match l with
| nil => nil
| y :: l0 =>
match x, y with
| temp i u, temp j v =>
if Pos.eqb i j
then remove_localdef x l0
else y :: remove_localdef x l0
| lvar i ti u, lvar j tj v =>
if Pos.eqb i j
then remove_localdef x l0
else y :: remove_localdef x l0
| _, _ => y :: remove_localdef x l0
end
end.
Definition localdef_tc (Delta: tycontext) (gvar_idents: list ident) (x: localdef): list Prop :=
match x with
| temp i v =>
match (temp_types Delta) ! i with
| Some t => tc_val t v :: nil
| _ => nil
end
| lvar _ _ v =>
isptr v :: headptr v :: nil
| gvars gv =>
VST_floyd_map (fun id => headptr (gv id)) gvar_idents
end.
Definition legal_glob_ident (Delta: tycontext) (i: ident): bool :=
match (glob_types Delta) ! i with
| Some _ => true
| _ => false
end.
Definition localdefs_tc (Delta: tycontext) gvar_ident (Pre: list localdef): list Prop :=
VST_floyd_concat (VST_floyd_map (localdef_tc Delta gvar_ident) Pre).
Definition msubst_extract_local (Delta: tycontext) (T1: PTree.t val) (T2: PTree.t (type * val)) (GV: option globals) (x: localdef): Prop :=
match x with
| temp i u =>
match T1 ! i with
| Some v => u = v
| None => False
end
| lvar i ti u =>
match T2 ! i with
| Some (tj, v) =>
if eqb_type ti tj
then u = v
else False
| _ => False
end
| gvars gv =>
match GV with
| Some gv0 => gv0 = gv
| _ => False
end
end.
Definition msubst_extract_locals (Delta: tycontext) (T1: PTree.t val) (T2: PTree.t (type * val)) (GV: option globals) := VST_floyd_map (msubst_extract_local Delta T1 T2 GV).
Inductive clean_LOCAL_right {cs: compspecs} (Delta: tycontext) (T1: PTree.t val) (T2: PTree.t (type * val)) (GV: option globals): (environ -> mpred) -> mpred -> Prop :=
| clean_LOCAL_right_sep_lift: forall P, clean_LOCAL_right Delta T1 T2 GV (`P) (P)
| clean_LOCAL_right_local_lift: forall P, clean_LOCAL_right Delta T1 T2 GV (local (`P)) (!! P)
| clean_LOCAL_right_prop: forall P, clean_LOCAL_right Delta T1 T2 GV (!! P) (!! P)
| clean_LOCAL_right_tc_lvalue: forall e, clean_LOCAL_right Delta T1 T2 GV (denote_tc_assert (typecheck_lvalue Delta e)) (msubst_tc_lvalue Delta T1 T2 GV e)
| clean_LOCAL_right_tc_expr: forall e, clean_LOCAL_right Delta T1 T2 GV (denote_tc_assert (typecheck_expr Delta e)) (msubst_tc_expr Delta T1 T2 GV e)
| clean_LOCAL_right_tc_LR: forall e lr, clean_LOCAL_right Delta T1 T2 GV (denote_tc_assert (typecheck_LR Delta e lr)) (msubst_tc_LR Delta T1 T2 GV e lr)
| clean_LOCAL_right_tc_efield: forall efs, clean_LOCAL_right Delta T1 T2 GV (denote_tc_assert (typecheck_efield Delta efs)) (msubst_tc_efield Delta T1 T2 GV efs)
| clean_LOCAL_right_tc_exprlist: forall ts es, clean_LOCAL_right Delta T1 T2 GV (denote_tc_assert (typecheck_exprlist Delta ts es)) (msubst_tc_exprlist Delta T1 T2 GV ts es)
| clean_LOCAL_right_tc_expropt: forall e t, clean_LOCAL_right Delta T1 T2 GV (tc_expropt Delta e t) (msubst_tc_expropt Delta T1 T2 GV e t)
| clean_LOCAL_right_canon': forall P Q R, clean_LOCAL_right Delta T1 T2 GV (PROPx P (LOCALx Q (SEPx R))) (fold_right_PROP_SEP (P ++ msubst_extract_locals Delta T1 T2 GV Q) R)
| clean_LOCAL_right_eval_lvalue: forall e u v, msubst_eval_lvalue Delta T1 T2 GV e = Some u -> clean_LOCAL_right Delta T1 T2 GV (local (`(eq v) (eval_lvalue e))) (!! (u = v))
| clean_LOCAL_right_eval_expr: forall e u v, msubst_eval_expr Delta T1 T2 GV e = Some u -> clean_LOCAL_right Delta T1 T2 GV (local (`(eq v) (eval_expr e))) (!! (u = v))
| clean_LOCAL_right_andp: forall P1 P2 Q1 Q2, clean_LOCAL_right Delta T1 T2 GV P1 Q1 -> clean_LOCAL_right Delta T1 T2 GV P2 Q2 -> clean_LOCAL_right Delta T1 T2 GV (P1 && P2) (Q1 && Q2)
| clean_LOCAL_right_EX': forall A (P: A -> environ -> mpred) (Q: A -> mpred), (forall a, clean_LOCAL_right Delta T1 T2 GV (P a) (Q a)) -> clean_LOCAL_right Delta T1 T2 GV (exp P) (exp Q).
Ltac unfold_localdef_name QQ Q :=
match Q with
| nil => idtac
| cons ?Qh ?Qt =>
match Qh with
| temp ?n _ => unfold n in QQ
| lvar ?n _ _ => unfold n in QQ
| _ => idtac
end;
unfold_localdef_name QQ Qt
end.
Ltac unify_for_go_lower :=
match goal with |- fold_right_PROP_SEP (VST_floyd_app ?A ?B) ?C = _ =>
repeat match B with context [(?x = ?y) :: _] =>
has_evar x; progress (unify x y)
end
end.
Ltac simply_msubst_extract_locals :=
unfold msubst_extract_locals, msubst_extract_local, VST_floyd_map;
cbv iota zeta beta;
simpl_PTree_get; simpl_eqb_type.
Ltac solve_clean_LOCAL_right :=
solve
[ simple apply clean_LOCAL_right_sep_lift
| simple apply clean_LOCAL_right_local_lift
| simple apply clean_LOCAL_right_prop
| simple apply clean_LOCAL_right_TT
| simple apply clean_LOCAL_right_FF
| try unfold tc_lvalue; simple apply clean_LOCAL_right_tc_lvalue
| try unfold tc_expr; simple apply clean_LOCAL_right_tc_expr
| try unfold tc_LR; simple apply clean_LOCAL_right_tc_LR
| try unfold tc_efield; simple apply clean_LOCAL_right_tc_efield
| try unfold tc_exprlist; simple apply clean_LOCAL_right_tc_exprlist
| simple apply clean_LOCAL_right_tc_expropt
| simple apply clean_LOCAL_right_canon;
simply_msubst_extract_locals;
unify_for_go_lower;
unfold VST_floyd_app;
unfold fold_right_PROP_SEP, fold_right_and_True;
unfold fold_right_sepcon; fold fold_right_sepcon; rewrite ?sepcon_emp;
reflexivity
| simple apply clean_LOCAL_right_eval_lvalue; solve_msubst_eval_lvalue
| simple apply clean_LOCAL_right_eval_expr; solve_msubst_eval_expr
| simple apply clean_LOCAL_right_andp; solve_clean_LOCAL_right
| simple apply clean_LOCAL_right_tc_andp; solve_clean_LOCAL_right
| simple apply clean_LOCAL_right_EX;
let a := fresh "a" in
intro a;
eexists;
split;
[ solve_clean_LOCAL_right
| match goal with
| |- ?t = _ => super_pattern t a; reflexivity
end
]
| fail 1000 "The right hand side is messed up; perhaps you inadvertently did something like 'simpl in *' that changes POSTCONDITION into a form that Floyd cannot recognize.  You may do 'unfold abbreviate in POSTCONDITION' in your previous proof steps to inspect it"
].
Ltac eapply_clean_LOCAL_right_spec_rec gv L :=
match goal with
| |- context [gv ?i] =>
match L with
| context [i] => fail 1
| _ => eapply_clean_LOCAL_right_spec_rec gv (@cons ident i L)
end
| _ := gv ?i |- _ =>
match L with
| context [i] => fail 1
| _ => eapply_clean_LOCAL_right_spec_rec gv (@cons ident i L)
end
| _ => match goal with
| |- _ |-- |==> _ => eapply (clean_LOCAL_right_bupd_spec L)
| _ => eapply (clean_LOCAL_right_spec L)
end
end.
Ltac eapply_clean_LOCAL_right_spec :=
match goal with
| |- context [gvars ?gv] => eapply_clean_LOCAL_right_spec_rec gv (@nil ident)
| _ => match goal with
| |- _ |-- |==> _ => eapply (clean_LOCAL_right_bupd_spec nil)
| _ => eapply (clean_LOCAL_right_spec nil)
end
end.
Ltac simpl_app_localdefs_tc :=
unfold localdefs_tc, localdef_tc;
unfold VST_floyd_map, VST_floyd_concat, VST_floyd_app;
cbv iota zeta beta;
simpl_temp_types_get;
cbv iota zeta beta.
Ltac solve_all_legal_glob_ident :=
reflexivity ||
lazymatch goal with
| gv: globals |- fold_right andb true (map ?F ?L) = true =>
let L' := constr:(List.filter (Basics.compose negb F) L)
in let L' := eval simpl in L'
in fail 1 "The following global identifiers," L'
"are not mentioned in your type-context,
therefore entailer or go_lower cannot operate on them."
"You can work around this problem by doing"
"(forget (" gv "i) as i')" "for each of those global identifiers i.
Then entailer or go_lower will work"
end.
Ltac clean_LOCAL_canon_mix :=
eapply_clean_LOCAL_right_spec;
[solve_all_legal_glob_ident | prove_local2ptree | solve_clean_LOCAL_right | simpl_app_localdefs_tc].

Lemma is_int_Vint_intro: forall sz sg v (P: Prop),
((exists i, v = Vint i /\ is_int sz sg (Vint i)) -> P) ->
(is_int sz sg v -> P).