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 ->
(* A warning has been emitted, we simply ignore the predicate here. *)
Logic_const.new_predicate Logic_const.ptrue
and fun_transform_assigns list_assigns =
(* substitute terms, then for each from extract lvals and
keep those and only those as froms *)
let treat_identified_term_zone_froms z =
match z with
| Nothing -> [ Nothing ]
| Location 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 -> Location (Logic_const.new_identified_term lv)) list_tlvals
in let treat_assign a =
let (z,lz) = a in
match z with
| Nothing -> Some (Nothing, [])
| Location it ->
let nt =
treat_term
it.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 (Location (Logic_const.new_identified_term nt),
List.flatten
(List.map 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 -> acc
(* Ignore the location based on the address of a formal parameter. *)
in let treat_assigns_clause ~is_result 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 *)
let ll = List.fold_left treat_assigns_list [] l in
let final_ll =
if is_result then
(* there is an assign \result: remove assigns \nothing if present *)
List.filter (fun (z,_) -> z <> Nothing) ll
else ll
in Logic_utils.merge_assigns final_ll []
in let final_assigns_list =
match ret_opt with
| None ->
(* no return value: there should be no assign of \result *)
treat_assigns_clause ~is_result:false list_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 *)
let rec change_at_result prefix suffix =
match suffix with
| [] -> List.rev prefix
| (a,from) :: tl ->
let new_a =
match a with
| Nothing -> a
| Location it ->
match it.it_content.term_node with
| Tat (trm, LogicLabel (_, "Post")) -> (
match trm.term_node with
| TLval (TResult _, _) ->
let ttype = Ctype ret_type
(* cf. bug #559 *)
(* Logic_utils.typ_to_logic_type
ret_type *)
in
Location
(Logic_const.new_identified_term
(mk_term trm.term_node ttype))
| _ -> a
)
| _ -> a
in change_at_result ((new_a,from) :: prefix) tl
in change_at_result [] list_assigns
in
(* add assign on result iff no assigns(\result) already appears ;
treat_assign will then do the job *)
let check_if_result () =
(* raise [Not_found] iff there is no assigns \result *)
ignore
(List.find
(fun (a,_from) ->
match a with
| Nothing -> false
| Location it -> (
match it.it_content.term_node with
| TLval (TResult _, _) -> true
| _ -> false
)
) nlist_assigns)
in
try
let () = check_if_result () in
(* found an assigns \result *)
treat_assigns_clause ~is_result:true nlist_assigns
with Not_found ->
(* 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
let new_assign =
(Location (Logic_const.new_identified_term nterm), [])
in
treat_assigns_clause ~is_result:true (new_assign :: nlist_assigns)
in 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 ())
~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 [ spec ]
else []
with Exit -> []