Require Export VST.veric.base.
Require Export VST.veric.shares.
Local Open Scope pred.
(*******************material moved here from tycontext.v *******************)
Inductive Annotation :=
WeakAnnotation : (environ -> mpred) -> Annotation
| StrongAnnotation : (environ -> mpred) -> Annotation.
Inductive tycontext : Type :=
mk_tycontext : forall (tyc_temps: PTree.t type)
(tyc_vars: PTree.t type)
(tyc_ret: type)
(tyc_globty: PTree.t type)
(tyc_globsp: PTree.t funspec)
(tyc_annot: PTree.t Annotation),
tycontext.
Definition empty_tycontext : tycontext :=
mk_tycontext (PTree.empty _) (PTree.empty _) Tvoid
(PTree.empty _)  (PTree.empty _) (PTree.empty _).
Definition temp_types (Delta: tycontext): PTree.t type :=
match Delta with mk_tycontext a _ _ _ _ _ => a end.
Definition var_types (Delta: tycontext) : PTree.t type :=
match Delta with mk_tycontext _ a _ _ _ _ => a end.
Definition ret_type (Delta: tycontext) : type :=
match Delta with mk_tycontext _ _ a _ _ _ => a end.
Definition glob_types (Delta: tycontext) : PTree.t type :=
match Delta with mk_tycontext _ _ _ a _ _ => a end.
Definition glob_specs (Delta: tycontext) : PTree.t funspec :=
match Delta with mk_tycontext _ _ _ _ a _ => a end.
Definition annotations (Delta: tycontext) : PTree.t Annotation :=
match Delta with mk_tycontext _ _ _ _ _ a => a end.
(** Creates a typecontext from a function definition **)
(* NOTE:  params start out initialized, temps do not! *)
Definition make_tycontext_t (params: list (ident*type)) (temps : list(ident*type)) :=
fold_right (fun (param: ident*type) => PTree.set (fst param) (snd param))
(fold_right (fun (temp : ident *type) tenv => let (id,ty):= temp in PTree.set id ty tenv)
(PTree.empty type) temps) params.
Definition make_tycontext_v (vars : list (ident * type)) :=
fold_right (fun (var : ident * type) venv => let (id, ty) := var in PTree.set id ty venv)
(PTree.empty type) vars.
Definition make_tycontext_g (V: varspecs) (G: funspecs) :=
(fold_right (fun (var : ident * funspec) => PTree.set (fst var) (type_of_funspec (snd var)))
(fold_right (fun (v: ident * type) => PTree.set (fst v) (snd v))
(PTree.empty _) V)
G).
Definition make_tycontext_a (anns : list (ident * Annotation)) :=
fold_right (fun (ia : ident * Annotation) aenv => let (id, a) := ia in PTree.set id a aenv)
(PTree.empty Annotation) anns.
Definition make_tycontext (params: list (ident*type)) (temps: list (ident*type)) (vars: list (ident*type))
(return_ty: type)
(V: varspecs) (G: funspecs) (A: list (ident*Annotation)):  tycontext :=
mk_tycontext
(make_tycontext_t params temps)
(make_tycontext_v vars)
return_ty
(make_tycontext_g V G)
(make_tycontext_s G)
(make_tycontext_a A).
(******************* end of material from tycontext.v*)
(*******************material moved here from expr.v *******************)
(** Environment typechecking functions **)
Definition typecheck_temp_environ
(te: tenviron) (tc: PTree.t type) :=
forall id ty , tc ! id = Some ty  -> exists v, Map.get te id = Some v /\ tc_val' ty v.
Definition typecheck_var_environ
(ve: venviron) (tc: PTree.t type) :=
forall id ty, tc ! id = Some ty <-> exists v, Map.get ve id = Some(v,ty).
Definition typecheck_glob_environ
(ge: genviron) (tc: PTree.t type) :=
forall id  t,  tc ! id = Some t ->
(exists b, Map.get ge id = Some b).
Definition typecheck_environ (Delta: tycontext) (rho : environ) :=
typecheck_temp_environ (te_of rho) (temp_types Delta) /\
typecheck_var_environ  (ve_of rho) (var_types Delta) /\
typecheck_glob_environ (ge_of rho) (glob_types Delta).
Definition local:  (environ -> Prop) -> environ->mpred :=  lift1 prop.
Definition tc_environ (Delta: tycontext) : environ -> Prop :=
fun rho => typecheck_environ Delta rho.
Definition funsig_tycontext (fs: funsig) : tycontext :=
make_tycontext (fst fs) nil nil (snd fs) nil nil nil.
Definition funsig_of_funspec (fs: funspec) : funsig :=
match fs with mk_funspec fsig _ _ _ _ _ _ => fsig end.
Definition ret0_tycon (Delta: tycontext): tycontext :=
mk_tycontext (PTree.empty _) (PTree.empty _) (ret_type Delta) (glob_types Delta) (glob_specs Delta) (annotations Delta).
(* If we were to require that a non-void-returning function must, at a function call, have its result assigned to a temp, then we could change "ret0_tycon" to "ret_tycon" in this definition (and in NDfunspec_sub). *)
Definition funspec_sub_si (f1 f2 : funspec):mpred :=
let Delta := funsig_tycontext (funsig_of_funspec f1) in
match f1 with
| mk_funspec fsig1 cc1 A1 P1 Q1 _ _ =>
match f2 with
| mk_funspec fsig2 cc2 A2 P2 Q2 _ _ =>
!!(fsig1 = fsig2 /\ cc1=cc2) &&
! (ALL ts2 :_, ALL x2:_, ALL rho:_,
(((local (tc_environ Delta) rho) && (P2 ts2 x2 rho))
>=> EX ts1:_,  EX x1:_, EX F:_,
(F * (P1 ts1 x1 rho)) &&
ALL rho':_, (     !( ((local (tc_environ (ret0_tycon Delta)) rho') && (F * (Q1 ts1 x1 rho')))
>=> (Q2 ts2 x2 rho')))))
end
end.
Definition funspec_sub_early (f1 f2 : funspec):mpred :=
let Delta := funsig_tycontext (funsig_of_funspec f1) in
match f1 with
| mk_funspec fsig1 cc1 A1 P1 Q1 _ _ =>
match f2 with
| mk_funspec fsig2 cc2 A2 P2 Q2 _ _ =>
!!(fsig1 = fsig2 /\ cc1=cc2) &&
! (ALL ts2 :_, ALL x2:_, ALL rho:_, EX ts1:_,  EX x1:_, EX F:_,
(((local (tc_environ Delta) rho) && (P2 ts2 x2 rho))
>=> (*EX ts1:_,  EX x1:_, EX F:_, *)
(F * (P1 ts1 x1 rho)) &&
ALL rho':_, (     !( ((local (tc_environ (ret0_tycon Delta)) rho') && (F * (Q1 ts1 x1 rho')))
>=> (Q2 ts2 x2 rho')))))
end
end.
Definition funspec_sub (f1 f2 : funspec):Prop :=
let Delta := funsig_tycontext (funsig_of_funspec f1) in
match f1 with
| mk_funspec fsig1 cc1 A1 P1 Q1 _ _ =>
match f2 with
| mk_funspec fsig2 cc2 A2 P2 Q2 _ _ =>
fsig1 = fsig2 /\ cc1=cc2 /\
forall (ts2 : list Type) x2 rho,
((local (tc_environ Delta) rho) && (P2 ts2 x2 rho))
|--
(EX ts1:_,  EX x1:_, EX F:_,
(F * (P1 ts1 x1 rho)) &&
(!! (forall rho',
((local (tc_environ (ret0_tycon Delta)) rho') &&
(F * (Q1 ts1 x1 rho')))
|--
(Q2 ts2 x2 rho'))))
end
end.
(*******************end of material moved here from expr.v *******************)
Definition func_at (f: funspec): address -> pred rmap :=
match f with
| mk_funspec fsig cc A P Q _ _ => pureat (SomeP (SpecTT A) (packPQ P Q)) (FUN fsig cc)
end.
Definition func_at' (f: funspec) (loc: address) : pred rmap :=
match f with
| mk_funspec fsig cc _ _ _ _ _ => EX pp:_, pureat pp (FUN fsig cc) loc
end.
Definition sigcc_at (fsig: funsig) (cc:calling_convention) (loc: address) : pred rmap :=
EX pp:_, pureat pp (FUN fsig cc) loc.
Definition func_ptr_si (f: funspec) (v: val): mpred :=
EX b: block, !! (v = Vptr b Ptrofs.zero) && (EX gs: funspec, funspec_sub_si gs f && func_at gs (b, 0)).
Definition func_ptr_early (f: funspec) (v: val): mpred :=
EX b: block, !! (v = Vptr b Ptrofs.zero) && (EX gs: funspec, funspec_sub_early gs f && func_at gs (b, 0)).
Definition func_ptr (f: funspec) (v: val): mpred :=
EX b: block, !! (v = Vptr b Ptrofs.zero) && (EX gs: funspec, !!(funspec_sub gs f) && func_at gs (b, 0)).
Definition NDmk_funspec (f: funsig) (cc: calling_convention)
(A: Type) (Pre Post: A -> environ -> mpred): funspec :=
mk_funspec f cc (rmaps.ConstType A) (fun _ => Pre) (fun _ => Post)
(const_super_non_expansive _ _) (const_super_non_expansive _ _).
(* Definition assert: Type := environ -> pred rmap. *)
Bind Scope pred with assert.
Local Open Scope pred.
Definition closed_wrt_vars {B} (S: ident -> Prop) (F: environ -> B) : Prop :=
forall rho te',
(forall i, S i \/ Map.get (te_of rho) i = Map.get te' i) ->
F rho = F (mkEnviron (ge_of rho) (ve_of rho) te').
Definition closed_wrt_lvars {B} (S: ident -> Prop) (F: environ -> B) : Prop :=
forall rho ve',
(forall i, S i \/ Map.get (ve_of rho) i = Map.get ve' i) ->
F rho = F (mkEnviron (ge_of rho) ve' (te_of rho)).
Definition not_a_param (params: list (ident * type)) (i : ident) : Prop :=
~ In i (map (@fst _ _) params).
Definition is_a_local (vars: list (ident * type)) (i: ident) : Prop :=
In  i (map (@fst _ _) vars) .
Fixpoint sepcon_list {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A} {AgeA: Age_alg A}
(p: list (pred A)) : pred A :=
match p with nil => emp | h::t => h * sepcon_list t end.
Definition typed_true (t: type) (v: val)  : Prop := strict_bool_val v t
= Some true.
Definition typed_false (t: type)(v: val) : Prop := strict_bool_val v t =
Some false.
Definition subst {A} (x: ident) (v: val) (P: environ -> A) : environ -> A :=
fun s => P (env_set s x v).

(* Lemma approx_func_ptr: forall (A: Type) fsig0 cc (P Q: A -> environ -> mpred) (v: val) (n: nat), approx n (func_ptr (NDmk_funspec fsig0 cc A P Q) v) = approx n (func_ptr (NDmk_funspec fsig0 cc A (fun a rho => approx n (P a rho)) (fun a rho => approx n (Q a rho))) v). Lemma approx_func_ptr_early: forall (A: Type) fsig0 cc (P Q: A -> environ -> mpred) (v: val) (n: nat), approx n (func_ptr_early (NDmk_funspec fsig0 cc A P Q) v) = approx n (func_ptr_early (NDmk_funspec fsig0 cc A (fun a rho => approx n (P a rho)) (fun a rho => approx n (Q a rho))) v).  Lemma approx_func_ptr_si: forall (A: Type) fsig0 cc (P Q: A -> environ -> mpred) (v: val) (n: nat), approx n (func_ptr_si (NDmk_funspec fsig0 cc A P Q) v) = approx n (func_ptr_si (NDmk_funspec fsig0 cc A (fun a rho => approx n (P a rho)) (fun a rho => approx n (Q a rho))) v).  Definition funspecs_assert (FunSpecs: PTree.t funspec): assert := fun rho => (ALL  id: ident, ALL fs:funspec,  !! (FunSpecs!id = Some fs) --> EX b:block, !! (Map.get (ge_of rho) id = Some b) && func_at fs (b,0)) &&  (ALL  b: block, ALL fsig:funsig, ALL cc: calling_convention, sigcc_at fsig cc (b,0) --> EX id:ident, !! (Map.get (ge_of rho) id = Some b) && !! exists fs, FunSpecs!id = Some fs).  Definition globals_only (rho: environ) : environ := (mkEnviron (ge_of rho) (Map.empty _) (Map.empty _)).  Fixpoint make_args (il: list ident) (vl: list val) (rho: environ)  := match il, vl with | nil, nil => globals_only rho | i::il', v::vl' => env_set (make_args il' vl' rho) i v | _ , _ => rho end.  Lemma same_FS_funspecs_assert: forall FS1 FS2, (forall id, FS1 ! id = FS2 ! id) -> funspecs_assert FS1 = funspecs_assert FS2.  Lemma funspecs_assert_rho: forall G rho rho', ge_of rho = ge_of rho' -> funspecs_assert G rho |-- funspecs_assert G rho'.  (*Rule S-inter3 from page 206 of TAPL*)
Lemma funspec_intersection_ND_sub3 {fA cA A PA QA fB cB B PB QB fC cC C PC QC} f1 F1 f2 F2 f
(I: funspec_intersection_ND fA cA A PA QA f1 F1 fB cB B PB QB f2 F2 = Some f) g
(G: g = NDmk_funspec fC cC C PC QC):
funspec_sub g f1 -> funspec_sub g f2 -> funspec_sub g f.