Section LIST1.
Context {cs: compspecs}.
Context  {list_structid: ident} {list_link: ident} {list_token: share -> val -> mpred}.
Fixpoint all_but_link (f: members) : members :=
match f with
| nil => nil
| cons it f' => if ident_eq (fst it) list_link
then f'
else cons it (all_but_link f')
end.
Definition elemtype (ls: listspec list_structid list_link list_token) :=
compact_prod
(map (fun it => reptype (field_type (fst it) list_fields)) (all_but_link list_fields)).
Definition field_type'  (F: members) (it: ident * type) :=
reptype (field_type (fst it) F).
Definition add_link_back' {F f: members}
(v: compact_prod (map (field_type' F) (all_but_link f))) :
compact_prod (map (field_type' F) f).
induction f as [| it0 f].
+ exact tt.
+  destruct f as [| it1 f0].
- exact (default_val _).
- change (all_but_link (it0 :: it1 :: f0))
with (if ident_eq (fst it0) list_link
then it1::f0
else cons it0 (all_but_link (it1::f0)))
in v.
change (reptype (field_type (fst it0) F) * compact_prod (map (field_type' F) (it1::f0)))%type.
destruct (ident_eq (fst it0) list_link).
exact (default_val _, v).
destruct (all_but_link (it1 :: f0)) eqn:?.
simpl in Heqm.
destruct (ident_eq (fst it1) list_link); [ | discriminate Heqm].
subst f0.
exact (v, default_val _).
exact (fst v, IHf (snd v)).
Defined.
Definition add_link_back
(F f : members)
(v : compact_prod
(map (fun it : ident * type => reptype (field_type (fst it) F))
(all_but_link f)))
: compact_prod (map (fun it => reptype (field_type (fst it) F)) f)
:=
list_rect
(fun f0 : list (ident * type) =>
compact_prod (map (field_type' F) (all_but_link f0)) ->
compact_prod (map (field_type' F) f0))
(fun _ : compact_prod (map (field_type' F) (all_but_link nil)) => tt)
(fun (it0 : ident * type) (f0 : list (ident * type))
(IHf : compact_prod (map (field_type' F) (all_but_link f0)) ->
compact_prod (map (field_type' F) f0))
(v0 : compact_prod (map (field_type' F) (all_but_link (it0 :: f0)))) =>
match
f0 as l
return
(compact_prod (map (field_type' F) (all_but_link (it0 :: l))) ->
(compact_prod (map (field_type' F) (all_but_link l)) ->
compact_prod (map (field_type' F) l)) ->
compact_prod (map (field_type' F) (it0 :: l)))
with
| nil =>
fun
(_ : compact_prod (map (field_type' F) (all_but_link (it0 :: nil))))
(_ : compact_prod (map (field_type' F) (all_but_link nil)) ->
compact_prod (map (field_type' F) nil)) =>
default_val (field_type (fst it0) F)
| it1 :: f1 =>
fun
(v1 : compact_prod
(map (field_type' F) (all_but_link (it0 :: it1 :: f1))))
(IHf0 : compact_prod
(map (field_type' F) (all_but_link (it1 :: f1))) ->
compact_prod (map (field_type' F) (it1 :: f1))) =>
(if ident_eq (fst it0) list_link as s0
return
(compact_prod
(map (field_type' F)
(if s0 then it1 :: f1 else it0 :: all_but_link (it1 :: f1))) ->
reptype (field_type (fst it0) F) *
compact_prod (map (field_type' F) (it1 :: f1)))
then
fun v2 : compact_prod (map (field_type' F) (it1 :: f1)) =>
(default_val (field_type (fst it0) F), v2)
else
fun
v2 : compact_prod
(map (field_type' F) (it0 :: all_but_link (it1 :: f1))) =>
match
all_but_link (it1 :: f1) as l
return
(all_but_link (it1 :: f1) = l ->
compact_prod (map (field_type' F) (it0 :: l)) ->
(compact_prod (map (field_type' F) l) ->
compact_prod (map (field_type' F) (it1 :: f1))) ->
reptype (field_type (fst it0) F) *
compact_prod (map (field_type' F) (it1 :: f1)))
with
| nil =>
fun (Heqm0 : all_but_link (it1 :: f1) = nil)
(v3 : compact_prod (map (field_type' F) (it0 :: nil)))
(IHf1 : compact_prod (map (field_type' F) nil) ->
compact_prod (map (field_type' F) (it1 :: f1))) =>
let s0 := ident_eq (fst it1) list_link in
(if s0
return
((if s0 then f1 else it1 :: all_but_link f1) = nil ->
reptype (field_type (fst it0) F) *
compact_prod (map (field_type' F) (it1 :: f1)))
then
fun Heqm1 : f1 = nil =>
eq_rect_r
(fun f2 : members =>
(compact_prod (map (field_type' F) nil) ->
compact_prod (map (field_type' F) (it1 :: f2))) ->
reptype (field_type (fst it0) F) *
compact_prod (map (field_type' F) (it1 :: f2)))
(fun
_ : compact_prod (map (field_type' F) nil) ->
compact_prod (map (field_type' F) (it1 :: nil)) =>
(v3, default_val (field_type (fst it1) F)))
Heqm1 IHf1
else
fun Heqm1 : it1 :: all_but_link f1 = nil =>
False_rect
(reptype (field_type (fst it0) F) *
compact_prod (map (field_type' F) (it1 :: f1)))
(eq_rect (it1 :: all_but_link f1)
(fun e : members =>
match e with
| nil => False
| _ :: _ => True
end) I nil Heqm1)) Heqm0
| p :: m0 =>
fun (_ : all_but_link (it1 :: f1) = p :: m0)
(v3 : compact_prod (map (field_type' F) (it0 :: p :: m0)))
(IHf1 : compact_prod (map (field_type' F) (p :: m0)) ->
compact_prod (map (field_type' F) (it1 :: f1))) =>
(fst v3, IHf1 (snd v3))
end eq_refl v2 IHf0) v1
end v0 IHf) f v.
(* Definition add_link_back {ls: listspec list_structid list_link} {f F: members} (v: compact_prod (map (fun it => reptype (field_type (fst it) F)) (all_but_link f))) : compact_prod (map (fun it => reptype (field_type (fst it) F)) f). unfold all_but_link in v. induction f as [| [i0 t0] f]. + exact tt. + simpl in *; destruct f as [| [i1 t1] f0] eqn:?; [| destruct (ident_eq i0 list_link)]. - exact (default_val _). - exact (default_val _, v). - fold (all_but_link ((i1, t1) :: f0)) in IHf, v. destruct (all_but_link ((i1, t1) :: f0)) eqn:?. * simpl in Heqm. if_tac in Heqm; [| congruence]. subst f0. exact (v, default_val _). * exact (fst v, IHf (snd v)). Defined. *)
Definition list_data {ls: listspec list_structid list_link list_token} (v: elemtype ls): reptype list_struct.
unfold list_struct.
pose (add_link_back _ _ v: reptype_structlist _).
rewrite list_members_eq in r.
exact (@fold_reptype _ (Tstruct _ _) r).
Defined.
Definition list_cell' (ls: listspec list_structid list_link list_token) sh v p :=
(field_at_ sh list_struct (StructField list_link :: nil) p) -* (data_at sh list_struct (list_data v) p).
Definition list_cell (ls: listspec list_structid list_link list_token) (sh: Share.t)
(v: elemtype ls) (p: val) : mpred :=
!! field_compatible list_struct nil p &&
struct_pred (all_but_link list_fields)
(fun it v => withspacer sh
(field_offset cenv_cs (fst it) list_fields + sizeof (field_type (fst it) list_fields))
(field_offset_next cenv_cs (fst it) list_fields (co_sizeof (get_co list_structid)))
(at_offset (data_at_rec sh (field_type (fst it) list_fields) v) (field_offset cenv_cs (fst it) list_fields)))
v p.
(* rewrite <- !gather_prop_left. rewrite !(prop_true_andp _ _ f). rewrite (prop_true_andp (field_compatible list_struct (StructField list_link :: nil) p)) by admit. normalize. apply andp_prop_ext. admit. intro HV. clear HV. change  (nested_field_type list_struct nil) with list_struct. rewrite (data_at_rec_ind sh list_struct (@fold_reptype cs (Tstruct list_structid noattr) (@eq_rect members (@list_fields cs list_structid list_link LS) (fun m : members => @reptype_structlist cs m) (@add_link_back (@list_fields cs list_structid list_link LS) (@list_fields cs list_structid list_link LS) v) (co_members (@get_co cs list_structid)) (@list_members_eq cs list_structid list_link LS)))). simpl. forget (co_sizeof (get_co list_structid)) as sz. assert (FT: field_type list_link list_fields = tptr list_struct). admit. pose (P m := fun (it : ident * type) (v0 : reptype (field_type (fst it) m)) => withspacer sh (field_offset cenv_cs (fst it) m + sizeof (field_type (fst it) m)) (field_offset_next cenv_cs (fst it) m sz) (at_offset (data_at_rec sh (field_type (fst it) m) v0) (field_offset cenv_cs (fst it) m))). fold (P list_fields). fold (P (co_members (get_co list_structid))). transitivity (at_offset (struct_pred (co_members (get_co list_structid)) (P (co_members (get_co list_structid))) ( (eq_rect list_fields (fun m : members => reptype_structlist m) (add_link_back _ _ v) (co_members (get_co list_structid)) list_members_eq))) (nested_field_offset list_struct nil) p); [ | f_equal; f_equal; rewrite unfold_fold_reptype; reflexivity ]. unfold at_offset. rewrite (data_at_rec_type_changable sh (nested_field_type list_struct (StructField list_link :: nil)) (tptr list_struct) (default_val _) Vundef list_link_type) by (rewrite by_value_default_val; try reflexivity; rewrite list_link_type; reflexivity). set (ofs := Int.repr (nested_field_offset list_struct (StructField list_link :: nil))). assert (Hofs: ofs = Int.repr (field_offset cenv_cs list_link list_fields)). { unfold ofs. clear. f_equal. unfold list_struct. pose proof list_link_type. unfold nested_field_offset. simpl. rewrite list_members_eq. unfold list_struct, nested_field_type in H; simpl in H. destruct (compute_in_members list_link (co_members (get_co list_structid))); inv H. reflexivity. } revert v; unfold elemtype. fold (field_type' list_fields). pose (m := list_fields). pose (m' := co_members (get_co list_structid)). set (H := list_members_eq). clearbody H. revert H. change (forall (H: m=m') (v : compact_prod (map (field_type' list_fields) (all_but_link m))), struct_pred (all_but_link m) (P list_fields) v p  * spacer sh (field_offset cenv_cs list_link list_fields + sizeof (field_type list_link list_fields)) (field_offset_next cenv_cs list_link list_fields sz) p* data_at_rec sh (tptr list_struct) Vundef (offset_val ofs p) = struct_pred m' (P m') (eq_rect m reptype_structlist (add_link_back list_fields m v) m' H) (offset_val (Int.repr 0) p)). assert  (MNR := get_co_members_no_replicate list_structid). fold m' in MNR. revert MNR. clearbody m'. intros. subst m'. rewrite <- eq_rect_eq. assert (In list_link (map fst m)). { unfold m. rewrite list_members_eq. pose proof list_link_type. unfold nested_field_type in H. unfold list_struct in H. unfold nested_field_rec in H. destruct (compute_in_members list_link (co_members (get_co list_structid))) eqn:?; inv H. apply compute_in_members_true_iff; auto. } change (struct_pred (all_but_link m) (P list_fields) v p  * spacer sh (field_offset cenv_cs list_link list_fields + sizeof (field_type list_link list_fields)) (field_offset_next cenv_cs list_link list_fields sz) p* data_at_rec sh (tptr list_struct) Vundef (offset_val ofs p) = struct_pred m (P list_fields) (add_link_back list_fields m v) (offset_val (Int.repr 0) p)). revert MNR H v; clearbody m. induction m; intros; [inv H | ]. simpl in H. assert (H': In list_link (map fst m) -> fst a <> list_link). clear - MNR. unfold members_no_replicate in MNR. intros; simpl in *.  destruct (id_in_list (fst a) (map fst m)) eqn:?. inv MNR. apply id_in_list_false in Heqb. intro. congruence. destruct H. * (* list_link is the first field *)
clear H'.
destruct a. simpl in H. subst i.
destruct m.
Opaque field_offset. Opaque field_type. simpl.
Transparent field_offset. Transparent field_type.
assert ((if ident_eq list_link list_link then nil else (list_link, t) :: nil) = nil)
by (rewrite if_true; auto).
simpl in v.
assert (exists v' : compact_prod (map (field_type' list_fields) nil), JMeq v' v).  {
revert H v.
clear.
pose (j := if ident_eq list_link list_link
then @nil (ident * type) else (list_link, t) :: @nil (ident * type)).
change (j = nil ->
forall
v : compact_prod (map (field_type' list_fields) j),
exists v' : compact_prod (map (field_type' list_fields) nil), JMeq v' v).
clearbody j.
intros; subst. exists v; reflexivity.
}
destruct H0 as [v' ?].
replace (struct_pred
(if ident_eq list_link list_link then nil else (list_link, t) :: nil)
(P list_fields) v p) with
(struct_pred nil (P list_fields) v' p).
Focus 2.
if_tac; [ | congruence]. reflexivity.
Opaque field_offset. Opaque field_type. simpl.
Transparent field_offset. Transparent field_type.
rewrite emp_sepcon.
clear v' H0 H v IHm.
unfold P.
rewrite withspacer_spacer.
unfold at_offset. simpl @fst.
f_equal.
rewrite isptr_offset_val_zero by auto.
auto.
rewrite offset_offset_val, Int.add_zero_l.
rewrite Hofs.
apply equal_f.
apply data_at_rec_type_changable; auto.
rewrite FT. reflexivity.
assert (all_but_link ((list_link,t)::p0::m) = p0::m).
simpl. rewrite if_true by auto; reflexivity.
assert (all_but_link (p0::m) = p0::m). {
clear - MNR H.
admit. (* easy enough *)
}
rewrite struct_pred_cons2.
unfold P at 2.
rewrite withspacer_spacer.
rewrite Hofs. unfold at_offset.
rewrite offset_offset_val, Int.add_zero_l.
change (fst (list_link, t)) with list_link.
rewrite isptr_offset_val_zero by auto.
pull_right (spacer sh
(field_offset cenv_cs list_link list_fields +
sizeof (field_type list_link list_fields))
(field_offset_next cenv_cs list_link list_fields sz) p).
f_equal.
rewrite sepcon_comm.
f_equal.
apply equal_f.
apply data_at_rec_type_changable; auto.
apply JMeq_trans with (B:= reptype (field_type list_link list_fields)) (y:= default_val (field_type list_link list_fields)).
rewrite FT. reflexivity.
match goal with |- JMeq ?A ?B => replace A with B end.
apply JMeq_refl.
clear.
revert v.
unfold all_but_link.
unfold add_link_back.
unfold list_rect at 1.
simpl @fst.
destruct (ident_eq list_link list_link); [ | elimtype False; congruence]; intro.
simpl. reflexivity.
apply struct_pred_type_changable; auto.
clear.
revert v.
simpl.
destruct (ident_eq list_link list_link); [ | elimtype False; congruence]; intro.
simpl. reflexivity.
* (* list link is not the first field *)
specialize (H' H).
destruct m; [inv H | ].
rewrite struct_pred_cons2.
assert (all_but_link (a :: p0 :: m) = a :: all_but_link (p0::m)). {
clear - MNR H. forget (p0::m) as m'. clear p0 m.
induction m'. inv H.
unfold all_but_link; fold all_but_link.
unfold members_no_replicate in *.
rewrite map_cons in MNR.
unfold compute_list_norepet in MNR.
fold compute_list_norepet in MNR.
destruct (id_in_list (fst a) (map fst (a0 :: m'))) eqn:?; [discriminate | ].
simpl in Heqb. rewrite orb_false_iff in Heqb. destruct Heqb.
apply Pos.eqb_neq in H0.
apply id_in_list_false in H1.
simpl in H. destruct H.
rewrite H in *. rewrite if_false by auto. auto.
rewrite if_false by congruence. auto.
}
unfold members_no_replicate in *.
simpl in MNR.
destruct ((fst a =? fst p0)%positive || id_in_list (fst a) (map fst m))%bool eqn:?; try discriminate.
rewrite orb_false_iff in Heqb. destruct Heqb.
apply Pos.eqb_neq in H1.
apply id_in_list_false in H2.
specialize (IHm MNR H).
destruct p0 as [i t].
(* simpl in v'. *)
simpl in H1. clear MNR H.
destruct (ident_eq i list_link).
+ subst i.
assert (exists v' : compact_prod (map (field_type' list_fields) (a :: m)),
JMeq v v'). {
revert v; clear - H0.
replace (all_but_link ((list_link, t) :: m)) with m in H0
by (simpl; rewrite if_true by auto; auto).
rewrite H0. eexists; eauto.
}
destruct H as [v' H3].
simpl in v'.
destruct m.
-
simpl in v'.
assert (exists v'': compact_prod
(map (field_type' list_fields)
(all_but_link ((list_link, t) :: nil))), JMeq v'' tt). {
clear. simpl. rewrite if_true by auto. exists tt; reflexivity.
}
destruct H as [v'' H4].
specialize (IHm v'').
replace (struct_pred (all_but_link ((list_link, t) :: nil)) (P list_fields) v'' p) with
(struct_pred nil (P list_fields) tt p) in IHm
by (apply struct_pred_type_changable; auto; simpl; rewrite if_true; auto).
change (struct_pred nil (P list_fields) tt p) with emp in IHm.
rewrite emp_sepcon in IHm.
rewrite sepcon_assoc. rewrite IHm; clear IHm.
f_equal.
assert (exists v4: compact_prod
(map (field_type' list_fields) (a::nil)), JMeq v4 v). {
clear - H1. revert v. simpl. rewrite if_false by auto. rewrite if_true by auto.
eexists; eauto.
}
destruct H as [v4 H5].
transitivity (struct_pred (a :: nil) (P list_fields) v4 (offset_val (Int.repr 0) p)).
apply struct_pred_type_changable; auto.
simpl. rewrite if_false by auto; rewrite if_true by auto. auto.
admit. (* see proof above *)
destruct a as [i' t'].
unfold struct_pred at 1.
unfold list_rect.
f_equal.
clear - H1 H5. simpl in H1.
admit.  (* tedious *)
apply struct_pred_type_changable; auto.
clear - H1 H4 H3.
simpl in v'.
admit.  (* tedious *)
-
simpl map at 1 in v'. cbv beta iota in v'.
destruct v' as [va vr].
assert (exists vr' : compact_prod
(map (field_type' list_fields)
(all_but_link ((list_link, t) :: p0 :: m))),
JMeq vr vr'). {
clear - H1; simpl in H1.
simpl. rewrite if_true by auto. exists vr; eauto.
} destruct H as [vr' H4].
specialize (IHm vr').
replace (struct_pred (all_but_link (a :: (list_link, t) :: p0 :: m)) (P list_fields) v p)
with (P list_fields a
(fst (add_link_back list_fields (a :: (list_link, t) :: p0 :: m) v))
(offset_val (Int.repr 0) p) *
struct_pred (all_but_link ((list_link, t) :: p0 :: m)) (P list_fields) vr' p).
rewrite !sepcon_assoc. f_equal.
rewrite <- sepcon_assoc.
rewrite IHm.
apply struct_pred_type_changable; auto.
clear - H3 H4 H1.
admit.  (* tedious *)
clear - H3 H4 H1 H0.
transitivity (P list_fields a va p *
struct_pred (all_but_link ((list_link, t) :: p0 :: m)) (P list_fields) vr' p).
f_equal.
unfold P; rewrite !withspacer_spacer; f_equal. rewrite <- spacer_offset_zero. auto.
unfold at_offset. rewrite offset_offset_val. rewrite Int.add_zero_l.
f_equal.
admit.  (* tedious *)
assert (exists v6: compact_prod (map (field_type' list_fields) (a :: p0 :: m)),
JMeq v v6). {
clear - H1 H0.
simpl all_but_link at 2 in H0. rewrite if_true in H0 by auto.
revert v; rewrite H0. intros. exists v; auto.
} destruct H as [v6 H].
transitivity (struct_pred (a :: p0 :: m) (P list_fields) v6 p).
rewrite struct_pred_cons2. f_equal.
unfold P; rewrite !withspacer_spacer; f_equal.
unfold at_offset.
f_equal. rewrite H in H3. clear - H3. apply JMeq_eq in H3. subst; reflexivity.
apply struct_pred_type_changable; auto.
simpl. rewrite if_true by auto. auto.
rewrite H in H3.
clear - H3 H4.
eapply JMeq_trans. apply JMeq_sym. apply H4.
destruct v6.
clear - H3. simpl.
apply JMeq_eq in H3. inv H3; auto.
apply struct_pred_type_changable; auto.
simpl. rewrite if_false by auto. rewrite if_true by auto. auto.
+
assert (all_but_link ((i,t)::m) = (i,t)::all_but_link m).
simpl. rewrite if_false by auto; auto.
assert (exists v' :
(field_type' list_fields a * compact_prod (map (field_type' list_fields) (all_but_link ((i, t) :: m)))), JMeq v v'). {
clear - H H0 v. revert v; rewrite H0. rewrite H.
simpl. intros. exists v; reflexivity.
} destruct H3 as [v' Hv'].
destruct v' as [v1 vr].
specialize (IHm vr).
replace (struct_pred (all_but_link (a :: (i, t) :: m)) (P list_fields) v p)
with (P list_fields a (fst (add_link_back list_fields (a :: (i, t) :: m) v))
(offset_val (Int.repr 0) p) *
struct_pred (all_but_link ((i, t) :: m)) (P list_fields) vr p).
rewrite !sepcon_assoc. f_equal.
rewrite <- sepcon_assoc.
rewrite IHm. clear IHm.
apply struct_pred_type_changable; auto.
admit.  (* tedious *)
assert (exists v'': compact_prod
(field_type' list_fields a :: field_type' list_fields (i,t) :: map (field_type' list_fields) (all_but_link m)),
JMeq v v''). {
clear - H H0. revert v; rewrite H0. rewrite H. intros; exists v. reflexivity.
} destruct H3 as [v'' Hv''].
transitivity (struct_pred (a :: (i,t) :: all_but_link m) (P list_fields) v'' p).
rewrite struct_pred_cons2.
f_equal.
admit.  (* tedious *)
apply struct_pred_type_changable; auto.
clear - Hv' Hv''. rewrite Hv'' in Hv'. simpl in v''. destruct v''.
clear - Hv'.
admit.  (* tedious *)
apply struct_pred_type_changable; auto.
rewrite H0. rewrite H. auto.
Qed.
*)

Lemma list_cell_link_join_nospacer:
forall (LS: listspec list_structid list_link list_token) sh v p,
field_offset cenv_cs list_link list_fields +
sizeof (field_type list_link list_fields) =
field_offset_next cenv_cs list_link list_fields
(co_sizeof (get_co list_structid)) ->
list_cell LS sh v p * field_at_ sh list_struct (StructField list_link :: nil) p
= data_at sh list_struct (list_data v) p.