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 p =
let p' = Logic_const.pred_of_id_pred p in
try
let p_unnamed =
Logic_const.unamed
(treat_pred
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 nterm =
treat_term it.it_content formals_actuals_terms tret_opt
in
let visitor = tlval_fetcher_visitor () in
let _ = visitCilTerm (visitor :> cilVisitor) nterm in
let list_tlvals = visitor#fetch_lvals () in
List.map
(fun lv -> Logic_const.new_identified_term lv) list_tlvals
in
let treat_identified_term_zone_froms z =
match z with
| FromAny -> FromAny
| From l -> From (List.flatten (List.map treat_from l))
in
let treat_assign (z,lz) =
let nt =
treat_term
z.it_content formals_actuals_terms tret_opt (* should be an lval *)
in
match nt.term_node with
| TLval _ -> (* if substituted term is not an lval,
do not generate an assign *)
Some (Logic_const.new_identified_term nt,
treat_identified_term_zone_froms lz)
| _ -> None
in
let treat_assigns_list acc a =
try
match treat_assign a with
| None -> acc
| Some e -> e :: acc
with
| AddrOfFormal
| NoResult -> acc
(* Ignore the location based on the address of a formal parameter. *)
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 -> Writes (List.fold_left treat_assigns_list [] l)
in
let final_assigns_list =
match ret_opt with
| None ->
(* no return value: there should be no assign of \result *)
treat_assigns_clause 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 ->
(mk_behavior
~name:(self#mk_new_behavior_name kf)
~post_cond:(List.map
(fun (k,p) -> (k,fun_transform_pred p)) bhv.b_post_cond)
~assumes:(List.map fun_transform_pred bhv.b_assumes)
~requires:(List.map fun_transform_pred bhv.b_requires)
~assigns:(fun_transform_assigns bhv.b_assigns)
~extended:[] ())::acc
) [] behaviors
in
if new_behaviors <> [] then
let spec = { spec_behavior = List.rev new_behaviors ;
spec_variant = None ;
spec_terminates = None ;
spec_complete_behaviors = [] ;
spec_disjoint_behaviors = []
}
in Some spec
else None
with Exit -> None