let rec prop env p =
List.fold_right F.p_named p.name (prop_body env p)
and prop_body env p =
match p.content with
| Pfalse -> F.p_false
| Ptrue -> F.p_true
| Pand(p1,p2) ->
F.p_and (prop env p1)(prop env p2)
| Por(p1,p2) ->
F.p_or (prop env p1)(prop env p2)
| Pxor(p1,p2) ->
F.p_xor(prop env p1)(prop env p2)
| Pimplies(p1,p2) ->
F.p_implies(prop env p1)(prop env p2)
| Piff(p1,p2)->
F.p_iff(prop env p1)(prop env p2)
| Pnot p -> F.p_not (prop env p)
| Pif(c,pt,pf) ->
F.p_cond (F.unwrap (term env c))
(prop env pt)
(prop env pf)
| Pold p -> prop (env_at env Pre) p
| Pat (p,l) -> prop (env_at env (c_label l)) p
| Prel ( rel ,t1,t2) ->
let ct1 = kind_of t1.term_type in
let ct2 = kind_of t2.term_type in
let m1 = data_of_term env t1 in
let m2 = data_of_term env t2 in
pred_cmp (rel_op rel) ct1 m1 ct2 m2
| Pvalid t ->
let k = kind_of t.term_type in
let d = data_of_term env t in
data_valid (mem_at_env env) k d
| Pvalid_index(tp,ti) ->
let ty = match tp.term_type with
| Ctype te -> te
| _ -> WpLog.fatal "expected a non logic type"
in
let kp = kind_of_typ ty in
let ki = kind_of ti.term_type in
let dp = data_of_term env tp in
let di = data_of_term env ti in
if Cil.isArrayType ty then
let te = Cil.typeOf_array_elem ty in
let ta = object_of te in
let d = data_index ta kp dp ki di in
data_valid (mem_at_env env) kp d
else
if Cil.isPointerType ty then
let d = data_shift kp dp ki di ~is_pos:true in
data_valid (mem_at_env env) kp d
else WpLog.fatal "unexepected type for valid index"
| Pvalid_range(b,l,h) ->
let tb = b.term_type in
let k = kind_of tb in
begin
match k with
| Kptr _ ->
let ty = typ_of_elements tb in
let obj = object_of ty in
let loc = loc_of_data obj (data_of_term env b) in
let rg = {
D.inf = Some (integer_of_data (kind_of l.term_type)
(data_of_term env l));
D.sup = Some (integer_of_data (kind_of h.term_type)
(data_of_term env h));
} in
M.valid (mem_at_env env) (D.Arange(obj,loc,rg))
| _ -> WpLog.fatal "unsuitable argument for [valid_range]"
end
| Pfresh _t -> WpLog.not_yet_implemented "fresh"
| Psubtype (_t1,_t2) -> WpLog.not_yet_implemented "subtype"
| Plet(def, p) ->
begin
let lv = def.l_var_info in
match def.l_body, def.l_profile with
LBterm t, [] ->
let x = D.fresh lv.lv_name (Mdata.Vacsl lv.lv_type) in
D.subst x (term env t)
(prop (quant_env env [(lv,F.var x)]) p)
| _ -> WpLog.not_yet_implemented "local binding"
end
| Pforall (xs,p) ->
let freshes =
List.map
(fun x -> x ,
D.fresh x.lv_name (Mdata.Vacsl x.lv_type)) xs in
let quantified = List.map snd freshes in
let assoc = List.map (fun (x,v) -> x,F.var v) freshes in
D.forall quantified (prop (quant_env env assoc) p)
| Pexists (xs,p) ->
let freshes =
List.map
(fun x -> x , D.fresh x.lv_name (Mdata.Vacsl x.lv_type)) xs
in
let quantified = List.map snd freshes in
let assoc = List.map (fun (x,v) -> x,F.var v) freshes in
D.exists quantified
(prop (quant_env env assoc) p)
| Pseparated tl ->
let gs =
List.map
(fun t ->
let te =
match kind_of t.term_type with
| Kptr te -> te
| Kset (Kptr te) -> te
| k -> WpLog.fatal "separated on non pointer type : %a " pp_kind k
in
Ctypes.object_of te, data_of_term env t) tl in
let ags = Array.of_list gs in
let p = ref F.p_true in
for i=0 to Array.length ags - 2 do
for j=i+1 to Array.length ags - 1 do
p := F.p_and !p (data_separated ags.(i) ags.(j))
done
done ;
!p
| Papp (predicate,labels,args) ->
!rec_apply_predicate env predicate labels args