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.

Lemma funspec_sub_early_sub_si f1 f2: funspec_sub_early f1 f2 |-- funspec_sub_si f1 f2.