method private make_stmt_contract kf formals_actuals_terms ret_opt =
let tret_opt = match ret_opt with
| None -> None
| Some lv -> Some (Logic_utils.lval_to_term_lval ~cast:true lv)
in
let fun_transform_pred replace_pre p =
let p' = Logic_const.pred_of_id_pred p in
try
let p_unnamed =
Logic_const.unamed
(treat_pred
replace_pre
p'.content
formals_actuals_terms tret_opt)
in
Logic_const.new_predicate
{ content = p_unnamed.content ;
loc = p_unnamed.loc ;
name = p'.name }
with
| AddrOfFormal
| NoResult ->
(* A warning has been emitted, we simply ignore the predicate here. *)
Logic_const.new_predicate Logic_const.ptrue
and fun_transform_assigns assigns =
(* substitute terms, then for each from extract lvals and
keep those and only those as froms *)
let treat_from it =
let rec keep_it t =
match t.term_node with
| TLval _ -> true
| Tat (loc,_) -> keep_it loc
| TCastE (_,te) -> keep_it te
| Tinter locs
| Tunion locs -> (
try
List.iter
(fun loc ->
if not(keep_it loc) then
raise DontKeep
) locs ;
true
with DontKeep -> false )
| _ -> false
in
(* also, discard casts in froms *)
let rec transform_term t =
match t.term_node with
| TCastE (_,te) -> transform_term te
| _ -> t
in
let nterm =
treat_term Logic_const.old_label
it.it_content formals_actuals_terms tret_opt
in
if keep_it nterm then
[ Logic_const.new_identified_term (transform_term nterm) ]
else []
(* Do not generate froms from child left values any more *)
(*
let visitor = tlval_fetcher_visitor () in
let _ = visitCilTerm (visitor :> cilVisitor) nterm in
let list_tlvals = visitor#fetch_lvals () in
List.rev_map
(fun lv ->
Logic_const.new_identified_term lv)
(List.filter keep_it list_tlvals)
*)
in
let treat_identified_term_zone_froms z =
match z with
| FromAny -> FromAny
| From l ->
From (List.flatten (List.rev_map treat_from l))
in
let treat_assign (z,lz) =
try
let nt =
treat_term Logic_const.old_label
z.it_content formals_actuals_terms tret_opt
(* should be an lval *)
in
(* also treat union, inter and at terms *)
match nt.term_node with
| Tat _
| TLval _
| Tunion _
| Tinter _ ->
(Logic_const.new_identified_term nt,
treat_identified_term_zone_froms lz)
| _ -> raise NontreatedAssign
with
| AddrOfFormal
| NoResult -> raise NontreatedAssign
in
let treat_assigns_clause l =
(* compute list of assigns as (terms, list of terms) ;
if empty list of terms => it's a Nothing, else Location ... *)
(* then process to transform assign on \result *)
match l with
| WritesAny -> WritesAny
| Writes l ->
try
Writes (List.rev (List.rev_map treat_assign l))
with NontreatedAssign -> WritesAny
in
let final_assigns_list =
match ret_opt with
| None ->
(* no return value: there should be no assign of \result *)
assigns
| Some ret ->
let ret_type = typeOfLval ret in
let nlist_assigns =
(* if there is a assigns \at(\result,Post) \from x
replace by assigns \result \from x *)
match assigns with
| WritesAny -> WritesAny
| Writes assigns ->
let rec change_at_result acc assgn =
match assgn with
[] -> Writes (List.rev acc)
| (a,from)::tl ->
let new_a =
match a.it_content.term_node with
| Tat ({term_node=(TLval(TResult _,_) as trm)},
LogicLabel (_, "Post")) ->
let ttype = Ctype ret_type
(* cf. bug #559 *)
(* Logic_utils.typ_to_logic_type
ret_type *)
in
Logic_const.new_identified_term
(mk_term trm ttype)
| _ -> a
in
change_at_result ((new_a,from) :: acc) tl
in
change_at_result [] assigns
in
(* add assign on result iff no assigns(\result) already appears ;
treat_assign will then do the job *)
let add_assigns_result () =
(* add assigns \result with empty list of froms to do the job *)
let ttype = Ctype ret_type
(* bug #559 *)
(* Logic_utils.typ_to_logic_type ret_type *)
in
let nterm = mk_term (TLval (TResult ret_type, TNoOffset)) ttype in
(Logic_const.new_identified_term nterm, FromAny)
in
match nlist_assigns with
| WritesAny -> WritesAny
| Writes l when
List.exists
(fun (a,_) -> Logic_utils.is_result a.it_content) l
->
nlist_assigns
| Writes l -> Writes (add_assigns_result()::l)
in
treat_assigns_clause final_assigns_list
and behaviors =
(* calling get_spec on a function with a contract
but no code generates default assigns *)
(Kernel_function.get_spec kf).spec_behavior
in
try
let new_behaviors =
List.fold_left
(fun acc bhv ->
let b =
mk_behavior
~name:(self#mk_new_behavior_name kf)
~post_cond:(List.map
(fun (k,p) -> k,
fun_transform_pred Logic_const.old_label p)
bhv.b_post_cond)
~assumes:(List.map
(fun_transform_pred Logic_const.here_label)
bhv.b_assumes)
~requires:(List.map
(fun_transform_pred Logic_const.here_label)
bhv.b_requires)
~assigns:(fun_transform_assigns bhv.b_assigns)
~extended:[]
()
in
b :: acc)
[]
behaviors
in
(match new_behaviors with
| [] -> None
| _ :: _ ->
Some
{ spec_behavior = List.rev new_behaviors ;
spec_variant = None ;
spec_terminates = None ;
spec_complete_behaviors = [] ;
spec_disjoint_behaviors = [] })
with Exit -> None