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).
(*-------------------- ND case, specification Sigma families --------------------- *)
Definition funspec_Sigma_ND (sig:funsig) (cc:calling_convention) (I:Type) (A : I -> Type)
(Pre Post: forall i, A i -> environ -> mpred): funspec.
(*Specialization of funspec_Sigma_ND to binary case, i.e. I=bool*)
Program Definition BinarySigma fsig cc (A B:Type)
(PA QA: A -> environ ->mpred) (PB QB:B -> environ -> mpred): funspec :=
funspec_Sigma_ND fsig cc bool _ _ _.
Next Obligation.
intros sig cc A B PreA PostA PreB PostB x. destruct x. apply A. apply B.
Defined.
Next Obligation.
intros ? ? ? ? ? ? ? ? b X rho. destruct b; simpl in X. apply (PA X rho). apply (PB X rho).
Defined.
Next Obligation.
intros ? ? ? ? ? ? ? ? b X rho. destruct b; simpl in X. apply (QA X rho). apply (QB X rho).
Defined.
Definition funspecspec_sub_antisym (f g: funspec):= funspec_sub f g /\ funspec_sub g f.
(*-------------------Bifunctor version, binary case ------------*)
Definition binarySUM {A1 A2}
(P1: forall ts : list Type, (dependent_type_functor_rec ts (AssertTT A1)) mpred)
(P2: forall ts : list Type, (dependent_type_functor_rec ts (AssertTT A2)) mpred):
forall ts : list Type,
(dependent_type_functor_rec ts (AssertTT (@SigType bool (fun b => if b then A1 else A2)))) mpred.
Definition binary_intersection (phi psi:funspec): option funspec.
destruct phi as [f c A1 P1 Q1 P1_ne Q1_ne].
destruct psi as [f2 c2 A2 P2 Q2 P2_ne Q2_ne].
destruct (eq_dec f f2); [subst f2 | apply None].
destruct (eq_dec c c2); [subst c2 | apply None].
remember (binarySUM P1 P2) as P.
remember (binarySUM Q1 Q2) as Q.
apply Some. apply (mk_funspec f c _ P Q).
subst P; apply (binarySUM_ne P1_ne P2_ne).
subst Q; apply (binarySUM_ne Q1_ne Q2_ne).
Defined.

Lemma binaryintersection_sub phi psi omega:
binary_intersection phi psi = Some omega ->
funspec_sub omega phi /\  funspec_sub omega psi.