(**************************************************************************)
(*                                                                        *)
(*  This file is part of WP plug-in of Frama-C.                           *)
(*                                                                        *)
(*  Copyright (C) 2007-2020                                               *)
(*    CEA (Commissariat a l'energie atomique et aux energies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

let dkey = Wp_parameters.register_category "annot" (* debugging key *)
let debug fmt = Wp_parameters.debug ~dkey fmt

(* This file groups functions that extract some annotations
 * and associates them with CFG edges. *)

open Cil_types
open Cil_datatype

(* -------------------------------------------------------------------------- *)
(* --- Selection of relevant assigns and postconditions                   --- *)
(* -------------------------------------------------------------------------- *)

(* Properties for kf-conditions of termination-kind 'tkind' *)
let get_called_postconds (tkind:termination_kind) kf =
  let bhvs = Annotations.behaviors kf in
  List.fold_left
    (fun properties bhv ->
       List.fold_left
         (fun properties postcond ->
            if tkind = fst postcond then
              let pid_spec = Property.ip_of_ensures kf Kglobal bhv postcond in
              pid_spec :: properties
            else properties)
         properties bhv.b_post_cond)
    []
    bhvs

let get_called_post_conditions = get_called_postconds Cil_types.Normal
let get_called_exit_conditions = get_called_postconds Cil_types.Exits

(** Properties for assigns of kf *)
let get_called_assigns kf =
  let bhvs = Annotations.behaviors kf in
  List.fold_left
    (fun properties bhv ->
       if Cil.is_default_behavior bhv then
         match Property.ip_assigns_of_behavior kf Kglobal [] bhv with
         | None -> properties
         | Some ip -> ip :: properties
       else properties)
    []
    bhvs

(* -------------------------------------------------------------------------- *)
(* --- Status of Unreachable Annotations                                  --- *)
(* -------------------------------------------------------------------------- *)

let wp_unreachable =
  Emitter.create
    "Unreachable Annotations"
    [ Emitter.Property_status ]
    ~correctness:[] (* TBC *)
    ~tuning:[] (* TBC *)

let set_unreachable pid =
  let open Property in
  let emit = function
    | IPPredicate {ip_kind = PKAssumes _} -> ()
    | p ->
        debug "unreachable annotation %a@." Property.pretty p;
        Property_status.emit wp_unreachable ~hyps:[] p Property_status.True
  in
  let pids = match WpPropId.property_of_id pid with
    | IPPredicate {ip_kind = PKAssumes _} -> []
    | IPBehavior {ib_kf; ib_kinstr; ib_active; ib_bhv} ->
        let active = Datatype.String.Set.elements ib_active in
        (ip_post_cond_of_behavior ib_kf ib_kinstr active ib_bhv) @
        (ip_requires_of_behavior ib_kf ib_kinstr ib_bhv)
    | IPExtended _ -> []
    (* Extended clauses might concern anything. Don't validate them
       unless we know exactly what is going on. *)
    | p ->
        Wp_parameters.result "[CFG] Goal %a : Valid (Unreachable)"
          WpPropId.pp_propid pid ; [p]
  in
  List.iter emit pids

(*----------------------------------------------------------------------------*)
(* Proofs                                                                     *)
(*----------------------------------------------------------------------------*)

type proof = {
  target : Property.t ;
  proved : proofpart array ;
  mutable invalid : bool ;
  mutable dependencies : Property.Set.t ;
} and proofpart =
    | Noproof
    | Complete
    | Parts of Bitvector.t

let target p = p.target
let dependencies p =
  Property.Set.elements (Property.Set.remove p.target p.dependencies)

let create_proof ip =
  let n = WpPropId.subproofs ip in
  {
    target = WpPropId.property_of_id ip ;
    proved = Array.make n Noproof ;
    dependencies = Property.Set.empty ;
    invalid = false ;
  }

let add_proof pf ip hs =
  begin
    if not (Property.equal (WpPropId.property_of_id ip) pf.target)
    then Wp_parameters.fatal "Partial proof inconsistency" ;
    List.iter
      (fun iph ->
         if not (WpPropId.is_requires iph) then
           pf.dependencies <- Property.Set.add iph pf.dependencies
      ) hs ;
    let k = WpPropId.subproof_idx ip in
    match WpPropId.parts_of_id ip with
    | None -> pf.proved.(k) <- Complete
    | Some(p,n) ->
        match pf.proved.(k) with
        | Complete -> ()
        | Noproof ->
            let bv = Bitvector.create n in
            Bitvector.set_range bv 0 (p-1) ;
            Bitvector.set_range bv (p+1) (n-1) ;
            pf.proved.(k) <- Parts bv
        | Parts bv ->
            Bitvector.clear bv p ;
            if Bitvector.is_empty bv
            then pf.proved.(k) <- Complete
  end

let add_invalid_proof pf = pf.invalid <- true

let is_composed pf =
  Array.length pf.proved > 1

let is_proved pf =
  Array.for_all (function Complete -> true | _ -> false) pf.proved

let is_invalid pf =
  pf.invalid && not (is_proved pf)

(* -------------------------------------------------------------------------- *)
(* --- PID for Functions                                                  --- *)
(* -------------------------------------------------------------------------- *)

let mk_call_pre_id called_kf bhv s_call called_pre =
  (* TODOclean : quite dirty here ! *)
  let id = WpPropId.mk_pre_id called_kf Kglobal bhv called_pre in
  let called_pre = WpPropId.property_of_id id in
  let called_pre_p =
    Statuses_by_call.precondition_at_call called_kf called_pre s_call in
  WpPropId.mk_call_pre_id called_kf s_call called_pre called_pre_p

(* -------------------------------------------------------------------------- *)
(* --- Preconditions                                                      --- *)
(* -------------------------------------------------------------------------- *)

let call_preconditions =
  Statuses_by_call.all_call_preconditions_at ~warn_missing:true

(* Preconditions at call-point as WpPropId.t *)
let preconditions_at_call s = function
  | Cil2cfg.Static kf ->
      let preconds = call_preconditions kf s in
      let aux (pre, pre_call) = WpPropId.mk_call_pre_id kf s pre pre_call in
      List.map aux preconds
  | Cil2cfg.Dynamic _ -> []

let get_called_preconditions_at kf stmt =
  List.map snd (call_preconditions kf stmt)

(*----------------------------------------------------------------------------*)
(* Strategy and annotations                                                   *)
(*----------------------------------------------------------------------------*)

(* This is to code what kind of properties we want to process. *)
type asked_assigns = NoAssigns | OnlyAssigns | WithAssigns

(* This is to code which behavior the computed strategy refers to. *)
type asked_bhv =
  | FunBhv of funbehavior option (* None means default behavior
                                    when the function has no spec. This is useful to process internal
                                    properties even if the function has no default behavior *)
  | StmtBhv of Cil2cfg.node * stmt * Datatype.String.Set.t * funbehavior

let name_of_asked_bhv = function
  | FunBhv (Some bhv) -> bhv.b_name
  | FunBhv None -> Cil.default_behavior_name
  | StmtBhv (_, _, _, bhv) -> bhv.b_name

let asked_bhv = function
  | FunBhv None -> None
  | FunBhv (Some bhv) | StmtBhv (_,_,_,bhv) -> Some bhv.b_name

(* This is to code what properties the user asked for in a given behavior. *)
type asked_prop =
  | AllProps
  | NamedProp of string list
  | IdProp of Property.t
  | CallPre of stmt * Property.t option (** No specified property means all *)

(* a table to keep the information about the statement default specification
 * associated with each edge in order to know in which strategy we should put a
 * default annotation on this edge. When an edge has no information in the table,
 * it means that the edge annotations belong to the [FunBhv] default behavior;
 * and when we find a statement [s], it means that they belong to the [StmtBhv s]
 * default behavior. The [int] information is only useful to build the table :
 * when an edge is included in 2 different [StmtBhv] we only keep the one that
 * has the fewer internal edges because it is necessarily included in the other.
*)
module HdefAnnotBhv = Cil2cfg.HE (struct type t = (stmt * int) end)

(* Finally, a configuration is associated to a strategy computation to
 * summarize what is to be computed. *)
type strategy_info = {
  kf : Kernel_function.t;
  cfg : Cil2cfg.t;
  reached : WpReached.reached option ;
  cur_bhv : asked_bhv;
  asked_bhvs : asked_bhv list;
  asked_prop : asked_prop;
  assigns_filter : asked_assigns;
  def_annots_info : HdefAnnotBhv.t;
}

(*----------------------------------------------------------------------------*)
(* Adding things in the strategy                                               *)
(*----------------------------------------------------------------------------*)

(* Select annotations to take as Hyp/Goal/... *)

let pp_assigns_mode fmt config =
  let str = match config.assigns_filter with
    | NoAssigns -> "without assigns"
    | OnlyAssigns -> "only with assigns"
    | WithAssigns -> "both assigns or not"
  in Format.fprintf fmt "%s" str

let pp_asked_prop fmt = function
  | AllProps -> Format.fprintf fmt "all properties"
  | NamedProp names ->  Format.fprintf fmt "properties %a"
                          (Pretty_utils.pp_list ~sep:"," Format.pp_print_string) names
  | IdProp p -> Format.fprintf fmt "property %s" (Property.Names.get_prop_name_id p)
  | CallPre (s, Some p) -> Format.fprintf fmt "pre %s at stmt %a"
                             (Property.Names.get_prop_name_id p) Stmt.pretty_sid s
  | CallPre (s, None) -> Format.fprintf fmt "all call preconditions at stmt %a"
                           Stmt.pretty_sid s

let pp_strategy_info fmt config =
  Format.fprintf fmt "'%a', " Kernel_function.pretty config.kf;
  let _ = match config.cur_bhv with
    | FunBhv _bhv ->
        Format.fprintf fmt "behavior '%s'" (name_of_asked_bhv config.cur_bhv)
    | StmtBhv (_, s, a, bhv) ->
        Format.fprintf fmt "behavior '%s' of statement %d%a"
          bhv.b_name s.sid
          (Pretty_utils.pp_list
             ~pre:" (for active behaviors " ~sep:"," Format.pp_print_string)
          (Datatype.String.Set.elements a)
  in Format.fprintf fmt ", %a, %a"
    pp_asked_prop config.asked_prop pp_assigns_mode config

let cur_fct_default_bhv config = match config.cur_bhv with
  | FunBhv None -> true
  | FunBhv (Some bhv) -> bhv.b_name = Cil.default_behavior_name
  | _ -> false

let filter_assign config pid =
  match config.assigns_filter, WpPropId.property_of_id pid with
  | NoAssigns, Property.IPAssigns _ -> false
  | (OnlyAssigns | WithAssigns), Property.IPAssigns _ -> true
  | OnlyAssigns, _ -> false
  | (NoAssigns | WithAssigns), _ -> true

let filter_speconly config pid =
  if Cil2cfg.cfg_spec_only config.cfg then
    let open Property in
    match WpPropId.property_of_id pid with
    | IPPredicate {ip_kind = PKRequires _; ip_kinstr = Kglobal} -> true
    | _ -> false
  else true

let filter_status pid =
  Wp_parameters.StatusAll.get () ||
  begin
    let module C = Property_status.Consolidation in
    match C.get (WpPropId.property_of_id pid) with
    | C.Never_tried -> true
    | C.Considered_valid | C.Inconsistent _ -> false
    | C.Valid _ | C.Valid_under_hyp _
    | C.Invalid_but_dead _ | C.Valid_but_dead _ | C.Unknown_but_dead _ ->
        Wp_parameters.StatusTrue.get ()
    | C.Unknown _ -> Wp_parameters.StatusMaybe.get ()
    | C.Invalid _ | C.Invalid_under_hyp _ -> Wp_parameters.StatusFalse.get ()
  end

let filter_configstatus config pid =
  (match config.asked_prop with IdProp _ -> true | _ -> false) ||
  (filter_status pid)

let filter_asked config pid =
  match config.asked_prop with
  | IdProp idp -> Property.equal (WpPropId.property_of_id pid) idp
  | CallPre (s_call, asked_pre) -> WpPropId.select_call_pre s_call asked_pre pid
  | NamedProp names -> WpPropId.select_by_name names pid
  | AllProps -> WpPropId.select_default pid

let rec filter config pid = function
  | [] -> None
  | (f,name)::fs -> if f config pid then filter config pid fs else Some name

let dkey = Wp_parameters.register_category "select"
let goal_to_select config pid =
  let result =
    filter config pid [
      filter_assign , "assigns/non-assigns pass" ;
      filter_asked , "user selection" ;
      filter_configstatus , "proved status" ;
      filter_speconly , "no code and not main precondition" ;
    ] in
  match result with
  | None ->
      Wp_parameters.debug ~dkey "Goal '%a' selected" WpPropId.pp_propid pid ;
      true
  | Some f ->
      Wp_parameters.debug ~dkey "Goal '%a' skipped (%s)" WpPropId.pp_propid pid f ;
      false

(*----------------------------------------------------------------------------*)
(* Add properties *)

(* TODO: still have to remove these fonctions... *)

let kind_to_select config kind id = match kind with
  | WpStrategy.Agoal ->
      if goal_to_select config id then Some WpStrategy.Agoal else None
  | WpStrategy.Aboth goal ->
      let goal = goal && goal_to_select config id in
      Some (WpStrategy.Aboth goal)
  | WpStrategy.AcutB goal ->
      let goal = goal && goal_to_select config id in
      Some (WpStrategy.AcutB goal)
  | WpStrategy.AcallPre(goal,fct) ->
      let goal = goal && goal_to_select config id in
      Some (WpStrategy.AcallPre(goal,fct))
  | WpStrategy.AcallCheck(fct) ->
      if goal_to_select config id then Some (WpStrategy.AcallCheck fct)
      else None
  | WpStrategy.AcallPost _ ->
      if goal_to_select config id then Some kind else None
  | WpStrategy.Ahyp | WpStrategy.AcallHyp _ -> Some kind

let add_prop_loop_inv ~established config acc kind s ca p =
  let id = WpPropId.mk_loop_inv_id ~established config.kf s ca in
  match kind_to_select config kind id with
  | None -> acc
  | Some kind -> WpStrategy.add_prop_loop_inv acc kind s id p

let add_prop_inv_fixpoint config acc kind s ca p =
  let id = WpPropId.mk_inv_hyp_id config.kf s ca in
  match kind_to_select config kind id with
  | None -> acc
  | Some kind -> WpStrategy.add_prop_loop_inv acc kind s id p

(*----------------------------------------------------------------------------*)
(* Add Assigns *)

let add_loop_assigns_goal config s (ca, assigns) acc =
  let id = WpPropId.mk_loop_assigns_id config.kf s ca assigns in
  match id with
    None -> acc
  | Some id ->
      if goal_to_select config id then
        let labels = NormAtLabels.labels_loop s in
        let assigns' = NormAtLabels.preproc_assigns labels assigns in
        let a_desc = WpPropId.mk_loop_assigns_desc s assigns' in
        WpStrategy.add_assigns acc WpStrategy.Agoal id a_desc
      else acc

let add_stmt_assigns_goal config s active acc b l_post = match b.b_assigns with
  | WritesAny -> acc
  | Writes assigns ->
      let id = WpPropId.mk_stmt_assigns_id config.kf s active b assigns in
      match id with
      | None -> acc
      | Some id ->
          if goal_to_select config id then
            let kf = config.kf in
            let labels = NormAtLabels.labels_stmt_assigns ~kf s l_post in
            let assigns = NormAtLabels.preproc_assigns labels assigns in
            let a_desc = WpPropId.mk_stmt_assigns_desc s assigns in
            WpStrategy.add_assigns acc WpStrategy.Agoal id a_desc
          else acc

let add_fct_assigns_goal config acc tkind b = match b.b_assigns with
  | WritesAny -> acc
  | Writes assigns ->
      let id = WpPropId.mk_fct_assigns_id config.kf b tkind assigns in
      match id with
      | None -> acc
      | Some id ->
          if goal_to_select config id then
            let labels = NormAtLabels.labels_fct_assigns in
            let assigns' = NormAtLabels.preproc_assigns labels assigns in
            let a_desc = WpPropId.mk_kf_assigns_desc assigns' in
            WpStrategy.add_assigns acc WpStrategy.Agoal id a_desc
          else acc

(* ------------------------------------------------------------------------ *)
(* --- Get annotations according to the behavior                        --- *)
(* ------------------------------------------------------------------------ *)

(** find the behavior named [name] in the list *)
let get_named_bhv name bhv_list =
  try Some (List.find (fun b -> b.b_name = name) bhv_list)
  with Not_found -> None

(** Select in [bhv_list] the behavior that has to be processed
 * according to [config] and [ki] current statement. *)
let get_behav config ki bh_list = match config.cur_bhv, ki with
  | FunBhv _, Kglobal ->
      get_named_bhv (name_of_asked_bhv config.cur_bhv) bh_list
  | StmtBhv (_, s1, _, b), Kstmt s2 when s1.sid = s2.sid ->
      get_named_bhv b.b_name bh_list
  | _ -> None

(** Tells weather the property belonging to the behaviors in [bhv_name_list]
 * has to be considered according to [config]. *)
type test_behav_res =
  | TBRno   (* [cur_bhv] is not concerned *)
  | TBRhyp  (* the property belongs to [default_behavior],
               but not to [cur_bhv] : it doesn't have to be a Goal
               but can be considered as an hypothesis. *)
  | TBRpart (* the property has to be taken as a Goal, but even if it is
               proved for every [asked_bhvs], it will still be a partial proof.
               TODO: use this to generate PKPartial ! *)
  | TBRok   (* Select as a Goal *)

(** (see [test_behav_res] above).
 * If the annotation doesn't have "for" names, it is a bit complicated because
 * we have to know if the statement [s] is inside a stmt behavior or not. *)
let is_annot_for_config config ?(loopassigns=false) node s_annot bhv_name_list =
  let edges_before = Cil2cfg.pred_e config.cfg node in
  debug "[is_annot_for_config] at sid:%d for %a ? @."
    s_annot.sid (Wp_error.pp_string_list ~sep:" " ~empty:"<default>")
    bhv_name_list;
  let hyp_but_not_at_post n = (* don't take assert at post pgpt (see #564) *)
    let s_post = match Cil2cfg.get_post_edges config.cfg n with
      | [] -> None
      | e::_ -> Cil2cfg.get_edge_next_stmt config.cfg e
    in match s_post with
    | Some s_post when s_post.sid = s_annot.sid && not loopassigns -> TBRno
    | _ -> TBRhyp
  in
  let res = match bhv_name_list with
    | [] -> (* no spec 'for' in the property *)
        begin
          let e = match edges_before with
            | e::_ -> e
            | _ -> Wp_parameters.fatal "annot with no edge ?"
          in
          match config.cur_bhv with
          | FunBhv _ when cur_fct_default_bhv config ->
              begin
                try
                  let _ = HdefAnnotBhv.find config.def_annots_info e in
                  TBRhyp
                with Not_found -> TBRok
              end
          | StmtBhv (n, sb, _, b) when b.b_name = Cil.default_behavior_name ->
              begin
                try
                  let s,_ = HdefAnnotBhv.find config.def_annots_info e in
                  if s.sid = sb.sid then TBRok
                  else raise Not_found
                with Not_found -> hyp_but_not_at_post n
              end
          | FunBhv _ -> TBRhyp
          | StmtBhv (n,_,_,_) -> hyp_but_not_at_post n
        end
    | bhvs -> (* TODOopt : there is surely a better way to do this : *)
        let asked_bhv = name_of_asked_bhv config.cur_bhv in
        let goal = List.exists (fun bl -> bl = asked_bhv) bhvs in
        if goal then
          let full = (* TODO *) true
          (* List.for_all (fun bl -> is_in bl config.asked_bhvs) bhvs *)
          in (if full then TBRok else TBRpart)
        else TBRno
  in debug "[is_annot_for_config] -> %s@."
    (match res with TBRok -> "ok" | TBRhyp -> "hyp" | TBRno -> "no"
                  | TBRpart -> "part");
  res

let add_fct_pre config acc spec =
  let kf = config.kf in
  let add_bhv_pre_hyp b acc =
    let kind = WpStrategy.Ahyp in
    WpStrategy.add_prop_fct_bhv_pre acc kind kf b
  in
  let add_def_pre_hyp acc =
    match Cil.find_default_behavior spec with
    | None -> acc
    | Some bdef -> add_bhv_pre_hyp bdef acc
  in
  let acc =
    if WpStrategy.is_main_init kf ||
       Wp_parameters.PrecondWeakening.get () then acc
    else let kind = WpStrategy.Ahyp in
      List.fold_left (fun acc bhv ->
          WpStrategy.add_prop_fct_pre_bhv acc kind kf bhv)
        acc spec.spec_behavior
  in
  let acc = match get_behav config Kglobal spec.spec_behavior with
    | None -> add_def_pre_hyp acc
    | Some b ->
        let acc =
          if not (Cil.is_default_behavior b) then add_def_pre_hyp acc else acc
        in
        let acc =
          if WpStrategy.is_main_init kf then
            let add_both acc p =
              let id = WpPropId.mk_pre_id kf Kglobal b p in
              let goal = goal_to_select config id in
              let kind = WpStrategy.Aboth goal in
              WpStrategy.add_prop_fct_pre acc kind kf b ~assumes:None p
            in
            let acc = List.fold_left add_both acc b.b_requires in
            let add_hyp acc p =
              let kind = WpStrategy.Ahyp in
              WpStrategy.add_prop_fct_pre acc kind kf b ~assumes:None p
            in List.fold_left add_hyp acc b.b_assumes
          else add_bhv_pre_hyp b acc
        in acc
  in
  let acc = match get_behav config Kglobal spec.spec_behavior with
    | Some bhv when Wp_parameters.SmokeTests.get () ->
        WpStrategy.add_prop_fct_smoke acc kf bhv
    | _ -> acc
  in
  acc


let add_variant acc spec = (* TODO *)
  let _ = match spec.spec_variant with None -> ()
                                     | Some v ->
                                         Wp_parameters.warning ~once:true "Ignored 'decrease' specification:@, %a@."
                                           Printer.pp_decreases v
  in acc

let add_terminates acc spec = (* TODO *)
  let _ = match spec.spec_terminates with None -> ()
                                        | Some p ->
                                            Wp_parameters.warning ~once:true "Ignored 'terminates' specification:@, %a@."
                                              Printer.pp_predicate
                                              (Logic_const.pred_of_id_pred p)
  in acc

let add_disjoint_behaviors_props config ki active spec acc =
  match spec.spec_disjoint_behaviors with
  | [] -> acc
  | l ->
      let add_disj acc bhv_names =
        let kf = config.kf in
        let id = WpPropId.mk_disj_bhv_id (kf, ki, active, bhv_names) in
        if goal_to_select config id then
          begin
            let prop = Ast_info.disjoint_behaviors spec bhv_names in
            let labels = match ki with
              | Kglobal -> NormAtLabels.labels_fct_pre
              | Kstmt s -> NormAtLabels.labels_stmt_pre ~kf s in
            let prop = WpStrategy.normalize id labels prop in
            WpStrategy.add_prop acc WpStrategy.Agoal id prop
          end
        else acc
      in List.fold_left add_disj acc l

let add_complete_behaviors_props config ki active spec acc =
  match spec.spec_complete_behaviors with
  | [] -> acc
  | l ->
      let mk_prop acc bhv_names =
        let kf = config.kf in
        let id = WpPropId.mk_compl_bhv_id (kf, ki, active, bhv_names) in
        if goal_to_select config id then
          let prop = Ast_info.complete_behaviors spec bhv_names in
          let labels = match ki with
            | Kglobal -> NormAtLabels.labels_fct_pre
            | Kstmt s -> NormAtLabels.labels_stmt_pre ~kf s in
          let prop = WpStrategy.normalize id labels prop in
          WpStrategy.add_prop acc WpStrategy.Agoal id prop
        else acc
      in List.fold_left mk_prop acc l

let add_behaviors_props config ki active spec acc =
  let add = match config.cur_bhv, ki with
    | FunBhv _, Kglobal when cur_fct_default_bhv config -> true
    | StmtBhv (_, cur_s,  cur_a, b), Kstmt s
      when (s.sid = cur_s.sid &&
            b.b_name = Cil.default_behavior_name &&
            Datatype.String.Set.(equal cur_a (of_list active)))
      -> true
    | _ -> false
  in
  if add then
    let acc = add_complete_behaviors_props config ki active spec acc in
    let acc = add_disjoint_behaviors_props config ki active spec acc in
    acc
  else acc

(** Add the post condition of the whole spec as hypothesis.
 * Add [old(assumes) => ensures] for all the behaviors,
 * and also add an upper approximation of the merged assigns information. *)
let add_stmt_spec_post_as_hyp config v s spec acc =
  let l_post = Cil2cfg.get_post_label config.cfg v in
  let add_bhv_post acc b =
    let assumes = Some (Ast_info.behavior_assumes b) in
    let add tk acc p =
      WpStrategy.add_prop_stmt_post acc WpStrategy.Ahyp config.kf
        s b tk l_post ~assumes p
    in
    let p_acc, e_acc =
      WpStrategy.fold_bhv_post_cond ~warn:false (add Normal) (add Exits) acc b
    in let p_acc =
         WpStrategy.add_stmt_spec_assigns_hyp p_acc config.kf s l_post spec in
    (* let e_acc =  TODO, but crach at the moment... why ?
     * add_spec_assigns_hyp config ki l_post e_acc spec in *)
    p_acc, e_acc
  in List.fold_left add_bhv_post acc spec.spec_behavior

(** we want to prove this behavior:
 * - add the requires as preconditions to both prove and use as hyp,
 * - add the assumes as hypotheses,
 * - add the postconditions as goals.
*)
let add_stmt_bhv_as_goal config v s active b (b_acc, (p_acc, e_acc)) =
  let l_post = Cil2cfg.get_post_label config.cfg v in
  let assumes = None in (* [assumes] are used as separate hypotheses *)
  let add_pre_hyp acc p =
    WpStrategy.add_prop_stmt_pre acc WpStrategy.Ahyp config.kf s b ~assumes p
  in
  let add_pre_goal acc p =
    let id = WpPropId.mk_pre_id config.kf (Kstmt s) b p in
    let goal = goal_to_select config id in
    let kind = WpStrategy.Aboth goal in
    WpStrategy.add_prop_stmt_pre acc kind config.kf s b ~assumes p
  in
  let add_post tk acc p =
    let id = WpPropId.mk_stmt_post_id config.kf s b (tk, p) in
    let goal = goal_to_select config id in
    let kind = WpStrategy.Aboth goal in
    WpStrategy.add_prop_stmt_post acc kind config.kf s b tk l_post ~assumes p
  in

  let b_acc = List.fold_left add_pre_goal b_acc b.b_requires in
  let b_acc =  List.fold_left add_pre_hyp b_acc b.b_assumes in

  let p_acc, e_acc = WpStrategy.fold_bhv_post_cond ~warn:true
      (add_post Normal) (add_post Exits) (p_acc, e_acc) b
  in
  let p_acc = add_stmt_assigns_goal config s active p_acc b l_post in
  (*let e_acc = TODO, but crash at the moment... why ?
                        add_stmt_assigns config s e_acc b l_post in *)
  b_acc, (p_acc, e_acc)

let is_empty_behavior bhv =
  bhv.b_requires = [] &&
  bhv.b_assumes = [] &&
  bhv.b_post_cond = [] &&
  bhv.b_assigns = WritesAny &&
  bhv.b_allocation = FreeAllocAny

let is_empty_spec s =
  s.spec_variant = None &&
  s.spec_terminates = None &&
  List.for_all is_empty_behavior s.spec_behavior

let add_stmt_spec_annots
    config v s active spec ((b_acc, (p_acc, e_acc)) as acc)
  =
  if is_empty_spec spec then acc
  else
    let acc = add_variant acc spec in
    let acc = add_terminates acc spec in
    match config.cur_bhv with
    | StmtBhv (_n, cur_s, cur_a, b)
      when s.sid = cur_s.sid &&
           Datatype.String.Set.(equal cur_a (of_list active))
      ->
          (*
            begin match get_behav config (Kstmt s) spec.spec_behavior with
            | None -> (* in some cases, it seems that we can have several spec
            for the same statement -> not an error *) acc
            | Some b ->
          *)
        let b_acc, a_acc = add_stmt_bhv_as_goal config v s active b acc in
        let b_acc = add_behaviors_props config (Kstmt s) active spec b_acc in
        b_acc, a_acc
    | _ -> (* in all other cases, use the specification as hypothesis *)
        let kind = WpStrategy.Aboth false in
        let b_acc =
          WpStrategy.add_prop_stmt_spec_pre b_acc kind config.kf s spec
        in
        let p_acc, e_acc =
          add_stmt_spec_post_as_hyp config v s spec (p_acc, e_acc)
        in b_acc, (p_acc, e_acc)

(*----------------------------------------------------------------------------*)
(* Call annotations                                                           *)
(*----------------------------------------------------------------------------*)

let add_called_pre config called_kf s spec acc =
  let add_behav acc b = (* pre for behavior is [assumes => requires] *)
    let assumes = (Ast_info.behavior_assumes b) in
    let add_pre acc pre =
      let id = mk_call_pre_id called_kf b s pre in
      let kind = WpStrategy.AcallPre (goal_to_select config id,called_kf) in
      WpStrategy.add_prop_call_pre acc kind id ~assumes pre
    in List.fold_left add_pre acc b.b_requires
  in
  List.fold_left add_behav acc spec.spec_behavior

let add_called_post called_kf termination_kind acc =
  let spec = Annotations.funspec called_kf in
  let add_behav acc b =
    (* post for behavior is [\old(assumes) => ensures] *)
    let kind = WpStrategy.AcallHyp called_kf in
    let assumes = (Ast_info.behavior_assumes b) in
    let add_post acc (tk, p) =
      if tk = termination_kind && not p.ip_content.tp_only_check
      then WpStrategy.add_prop_call_post acc kind called_kf b tk ~assumes p
      else acc
    in List.fold_left add_post acc b.b_post_cond
  in
  List.fold_left add_behav acc spec.spec_behavior

let add_call_checks config s kf posts exits =
  if cur_fct_default_bhv config
  && Wp_parameters.SmokeTests.get ()
  && Wp_parameters.SmokeDeadcode.get ()
  then
    WpStrategy.add_prop_dead_call kf s posts exits
  else
    posts , exits

let add_call_annots config s kf l_post (before,(posts,exits)) =
  let spec = Annotations.funspec kf in
  let before = add_called_pre config kf s spec before in
  let posts = add_called_post kf Normal posts in
  let posts = WpStrategy.add_call_assigns_hyp posts config.kf s
      ~called_kf:kf l_post (Some spec) in
  let exits = add_called_post kf Exits exits in
  before , add_call_checks config s kf posts exits

let get_call_annots config v s fct =
  let l_post = Cil2cfg.get_post_label config.cfg v in
  let empty = let e = WpStrategy.empty_acc in e,(e,e) in
  match fct with

  | Cil2cfg.Static kf -> add_call_annots config s kf l_post empty

  | Cil2cfg.Dynamic _ ->
      let bhv = asked_bhv config.cur_bhv in
      match Dyncall.get ?bhv s with
      | None | Some(_,[]) ->
          Wp_parameters.warning ~once:true ~source:(fst (Stmt.loc s))
            "Missing 'calls' for %s"
            (match bhv with
             | None -> "default behavior"
             | Some b -> b) ;
          let annots = WpStrategy.add_call_assigns_any WpStrategy.empty_acc s in
          WpStrategy.empty_acc, (annots , annots)
      | Some(_,calls) ->
          List.fold_left
            (fun acc kf -> add_call_annots config s kf l_post acc)
            empty calls

(*----------------------------------------------------------------------------*)

let add_variant_annot config s ca var_exp loop_entry loop_back =
  let (vpos_id, vpos), (vdecr_id, vdecr) =
    WpStrategy.mk_variant_properties config.kf s ca var_exp
  in
  let add_variant acc kind id p =
    WpStrategy.add_prop_loop_inv acc kind s id p
  in
  let add_hyp acc =
    let acc = add_variant acc WpStrategy.Ahyp vdecr_id vdecr in
    add_variant acc WpStrategy.Ahyp vpos_id vpos
  in
  let add_goal acc =
    let acc =
      if goal_to_select config vdecr_id then
        add_variant acc WpStrategy.Agoal vdecr_id vdecr
      else acc
    in if goal_to_select config vpos_id then
      add_variant acc WpStrategy.Agoal vpos_id vpos
    else acc
  in
  let loop_back =
    if cur_fct_default_bhv config then add_goal loop_back else add_hyp loop_back
    (*TODO: what about variant establishment ??? It seems that [0<v)] is not
     *       proved by induction anymore. Why ? *)
  in loop_entry, loop_back

let add_loop_invariant_annot config vloop s ca b_list inv acc =
  let only_check = inv.tp_only_check in
  let inv = inv.tp_statement in
  let assigns, loop_entry, loop_back , loop_core = acc in
  (* we have to prove that inv is true for each edge that goes
   * in the loop, so we can assume that inv is true for each edge
   * starting from this point. *)
  match is_annot_for_config config vloop s b_list with
  | TBRok
  | TBRpart (* TODO: PKPartial *)
    ->
      begin
        let loop_entry = add_prop_loop_inv ~established:true config loop_entry
            WpStrategy.Agoal s ca inv in
        let loop_back = add_prop_loop_inv ~established:false config loop_back
            WpStrategy.Agoal s ca inv in
        let loop_core =
          if only_check then loop_core
          else
            add_prop_inv_fixpoint config loop_core WpStrategy.Ahyp s ca inv
        in
        assigns, loop_entry , loop_back , loop_core
      end
  | TBRhyp when not only_check ->
      let kind = WpStrategy.Ahyp in
      let loop_core = add_prop_inv_fixpoint config loop_core kind s ca inv
      in assigns, loop_entry , loop_back , loop_core
  | TBRhyp | TBRno -> acc

(** Returns the annotations for the three edges of the loop node:
 * - loop_entry : goals for the edge entering in the loop
 * - loop_back  : goals for the edge looping to the entry point
 * - loop_core  : fix-point hypothesis for the edge starting the loop core
*)
let get_loop_annots config vloop s =
  let do_annot _ a (assigns, loop_entry, loop_back , loop_core as acc) =
    match a.annot_content with
    | AInvariant (b_list, true, inv) ->
        add_loop_invariant_annot config vloop s a b_list inv acc
    | AVariant (var_exp, None) ->
        let loop_entry, loop_back =
          add_variant_annot config s a var_exp loop_entry loop_back
        in assigns, loop_entry , loop_back , loop_core
    | AVariant (_v, _rel) ->
        Wp_parameters.warning ~once:true "Ignored 'loop variant' specification with measure : %a"
          Printer.pp_code_annotation a;
        acc
    | AAssigns (_,WritesAny) -> assert false
    | AAssigns (b_list, Writes w) -> (* loop assigns *)
        let h_assigns, g_assigns = assigns in
        let check_assigns old cur =
          match old with
            None -> Some cur
          | Some _ ->
              Wp_parameters.fatal
                "At most one loop assigns can be associated to a behavior"
        in
        let assigns =
          match is_annot_for_config config ~loopassigns:true vloop s b_list with
          | TBRok | TBRpart ->
              check_assigns h_assigns (a,w),
              check_assigns g_assigns (a,w)
          | TBRhyp ->
              check_assigns h_assigns (a,w), g_assigns
          | TBRno -> assigns
        in (assigns, loop_entry , loop_back , loop_core)
    | _ -> acc (* see get_stmt_annots *)
  in
  let loop_core =
    if cur_fct_default_bhv config
    && Wp_parameters.SmokeTests.get ()
    && Wp_parameters.SmokeDeadloop.get ()
    && not (WpReached.is_dead_code s)
    then WpStrategy.add_prop_dead_loop WpStrategy.empty_acc config.kf s
    else WpStrategy.empty_acc in
  let (h_assigns, g_assigns), loop_entry , loop_back , loop_core =
    Annotations.fold_code_annot do_annot s
      ((None,None), WpStrategy.empty_acc, WpStrategy.empty_acc, loop_core)
  in
  let loop_back = match g_assigns with
    | None -> loop_back
    | Some a -> add_loop_assigns_goal config s a loop_back
  in
  let loop_core =
    WpStrategy.add_loop_assigns_hyp loop_core config.kf s h_assigns
  in (loop_entry , loop_back , loop_core)

let add_stmt_deadcode_smoke config acc s =
  if cur_fct_default_bhv config
  then
    match config.reached with
    | Some r when WpReached.smoking r s ->
        WpStrategy.add_prop_dead_code acc config.kf s
    | _ -> acc
  else
    acc

let get_stmt_annots config v s =
  let do_annot _ a ((b_acc, (a_acc, e_acc)) as acc) =
    match a.annot_content with
    | AInvariant (_blist, loop_inv, _inv) ->
        if loop_inv then (* see get_loop_annots *) acc
        else
          begin
            Wp_parameters.warning ~once:true
              "Unsupported generalized invariant, use loop invariant instead.\n\
               Ignored invariant @[<hov 2>%a@]"
              Printer.pp_code_annotation a;
            acc
          end
    | AAssert (b_list, p) ->
        let kf = config.kf in
        let acc = match is_annot_for_config config v s b_list with
          | TBRno -> acc
          | TBRhyp ->
              if p.tp_only_check then acc
              else
                let b_acc =
                  WpStrategy.add_prop_assert
                    b_acc WpStrategy.Ahyp kf s a p.tp_statement
                in (b_acc, (a_acc, e_acc))
          | TBRok | TBRpart ->
              let id = WpPropId.mk_assert_id config.kf s a in
              let goal = goal_to_select config id in
              if p.tp_only_check && not goal then acc
              else
                let kind =
                  WpStrategy.(if p.tp_only_check then Agoal else Aboth goal)
                in
                let b_acc =
                  WpStrategy.add_prop_assert b_acc kind kf s a p.tp_statement
                in
                (b_acc, (a_acc, e_acc))
        in acc
    | AAllocation (_b_list, _frees_allocates) ->
        (* [PB] TODO *) acc
    | AAssigns (_b_list, _assigns) ->
        (* loop assigns: see get_loop_annots *) acc
    | AVariant (_v, _rel) -> (* see get_loop_annots *) acc
    | APragma _ -> acc
    | AStmtSpec (b_list, spec) ->
        if b_list <> [] then (* TODO ! *)
          Wp_parameters.warning ~once:true
            "Ignored specification 'for %a' (generalize to all behavior)"
            (Pretty_utils.pp_list ~sep:", " Format.pp_print_string)
            b_list;
        add_stmt_spec_annots config v s b_list spec acc
    | AExtended _ -> acc
  in
  let before_acc =
    add_stmt_deadcode_smoke config WpStrategy.empty_acc s in
  let after_acc = WpStrategy.empty_acc in
  let exits_acc = WpStrategy.empty_acc in
  let acc = before_acc, (after_acc, exits_acc) in
  Annotations.fold_code_annot do_annot s acc

let get_fct_pre_annots config spec =
  let acc = WpStrategy.empty_acc in
  let acc = add_fct_pre config acc spec in
  let acc = add_behaviors_props config Kglobal [] spec acc in
  let acc = add_variant acc spec in
  let acc = add_terminates acc spec in
  acc

let get_fct_post_annots config tkind spec =
  let acc = WpStrategy.empty_acc in
  match get_behav config Kglobal spec.spec_behavior with
  | None -> acc
  | Some b ->
      (* add the postconditions *)
      let f_nothing () _ = () in
      let add tk acc p =
        let id = WpPropId.mk_fct_post_id config.kf b (tk, p) in
        if goal_to_select config id then
          WpStrategy.add_prop_fct_post acc WpStrategy.Agoal config.kf b tk p
        else acc
      in
      let acc = match tkind with
        | Normal ->
            let acc, _ =
              WpStrategy.fold_bhv_post_cond ~warn:true (add Normal) f_nothing (acc, ()) b
            in acc
        | Exits ->
            let _, acc =
              WpStrategy.fold_bhv_post_cond ~warn:false f_nothing (add Exits) ((), acc) b
            in acc
        | _ -> assert false
      in (* also add the [assigns] *)
      let acc =
        if Kernel_function.is_definition config.kf
        then add_fct_assigns_goal config acc tkind b
        else WpStrategy.add_fct_bhv_assigns_hyp acc config.kf tkind b
      in acc

(*----------------------------------------------------------------------------*)
(* Build graph annotation for the strategy                                    *)
(*----------------------------------------------------------------------------*)

(** Builds tables that give hypotheses and goals relative to [b] behavior
 * for edges of the cfg to consider during wp computation.
 * [b = None] means that we only consider internal properties to select for the
 * default behavior. This is useful when the function doesn't have any
 * specification.
 * @param asked_prop = Some id -> select only this goal (use all hyps).
*)
let get_behavior_annots config =
  debug "build strategy for %a@." pp_strategy_info config;
  let cfg = config.cfg in
  let spec = Annotations.funspec config.kf in
  let annots = WpStrategy.create_tbl () in

  let get_node_annot v =
    debug "get_node_annot for node %a" Cil2cfg.pp_node v;
    match Cil2cfg.node_type v with
    | Cil2cfg.Vstart | Cil2cfg.Vend -> ()

    | Cil2cfg.VfctIn ->
        let pre = get_fct_pre_annots config spec in
        WpStrategy.add_on_edges annots pre (Cil2cfg.succ_e cfg v)

    | Cil2cfg.VfctOut  ->
        let post = get_fct_post_annots config Normal spec in
        WpStrategy.add_on_edges annots post (Cil2cfg.succ_e cfg v)

    | Cil2cfg.VfctErr ->
        let post = get_fct_post_annots config Exits spec in
        WpStrategy.add_on_edges annots post (Cil2cfg.succ_e cfg v)

    | Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _)
    | Cil2cfg.Vstmt s
    | Cil2cfg.Vswitch (s,_) | Cil2cfg.Vtest (true, s, _)
      ->
        let stmt_annots = get_stmt_annots config v s in
        WpStrategy.add_node_annots annots cfg v stmt_annots

    | Cil2cfg.Vcall (s,_,fct,_) ->
        let stmt_annots = get_stmt_annots config v s in
        WpStrategy.add_node_annots annots cfg v stmt_annots;
        let call_annots = get_call_annots config v s fct in
        WpStrategy.add_node_annots annots cfg v call_annots

    | Cil2cfg.Vloop (_, s) ->
        let stmt_annots = get_stmt_annots config v s in
        let before, _after = stmt_annots in
        (* TODO: what about after ? *)
        WpStrategy.add_loop_annots annots cfg v ~entry:before
          ~back:WpStrategy.empty_acc ~core:WpStrategy.empty_acc;
        debug "add_loop_annots stmt ok";
        let (entry , back , core) = get_loop_annots config v s in
        debug "get_loop_annots ok";
        WpStrategy.add_loop_annots annots cfg v ~entry ~back ~core

    | Cil2cfg.Vloop2 _ -> (* nothing to do *) ()
    | Cil2cfg.VblkIn (_, _) | Cil2cfg.VblkOut (_, _) -> (* nothing *) ()
    | Cil2cfg.Vtest (false, _s, _) -> (* done in Cil2cfg.Vtest (true) *) ()
  in
  Cil2cfg.iter_nodes get_node_annot cfg;
  annots

(* ------------------------------------------------------------------------ *)
(* ---  Global Properties                                               --- *)
(* ------------------------------------------------------------------------ *)

module GS = Cil_datatype.Global_annotation.Set

let add_global_annotations annots =
  let rec do_global g =
    let (source,_) = Cil_datatype.Global_annotation.loc g in
    match g with
    | Daxiomatic (_ax_name, globs,_,_) -> do_globals globs
    | Dvolatile _ ->
        (* nothing to do *) ()
    | Dfun_or_pred _ ->
        (* will be processed while translation is needed *) ()
    | Dtype _ ->
        (* will be processed while translation is needed *) ()
    | Dtype_annot (linfo,_) ->
        Wp_parameters.warning ~source ~once:true
          "Type invariant not handled yet ('%s' ignored)"
          linfo.l_var_info.lv_name;
        ()
    | Dmodel_annot (mf,_) ->
        Wp_parameters.warning ~source ~once:true
          "Model fields not handled yet (model field '%s' ignored)"
          mf.mi_name;
        ()
    | Dcustom_annot (_c,_n,_,_) ->
        Wp_parameters.warning ~source ~once:true
          "Custom annotation not handled (ignored)";
        ()
    | Dextended _ -> ()
    (* nothing to do. It's the job of the extension's owner
       to generate the appropriate standard annotations. *)
    | Dinvariant (linfo,_) ->
        Wp_parameters.warning ~source ~once:true
          "Global invariant not handled yet ('%s' ignored)"
          linfo.l_var_info.lv_name;
        ()
    | Dlemma (name,_,_,_,p,_,_) ->
        if not (p.tp_only_check) then
          WpStrategy.add_axiom annots (LogicUsage.logic_lemma name)

  and do_globals gs = List.iter do_global gs in
  (*[LC]: forcing order of iteration: hash is not the same on 32 and 64 bits *)
  let pool = ref GS.empty in
  Annotations.iter_global (fun _ g -> pool := GS.add g !pool);
  GS.iter do_global !pool;
  annots

(* ------------------------------------------------------------------------ *)
(* --- Main functions to build the strategies                           --- *)
(* ------------------------------------------------------------------------ *)

let string_of_active active =
  Format.asprintf "%a"
    (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "_%s" s))
    (Datatype.String.Set.elements active)

let behavior_name_of_config config =
  match config.cur_bhv with
  | FunBhv None -> None
  | FunBhv (Some b) when b.b_name = Cil.default_behavior_name -> None
  | FunBhv (Some b) -> Some b.b_name
  | StmtBhv (_, s, active, b) when b.b_name = Cil.default_behavior_name ->
      Some(
        "default_for_stmt_"^(string_of_int s.sid)^(string_of_active active))
  (*TODO better name ?*)
  | StmtBhv (_, s, active, b) ->
      Some (b.b_name^"_stmt_"^(string_of_int s.sid)^(string_of_active active))

let build_bhv_strategy config =
  let annots = get_behavior_annots config in
  let annots = add_global_annotations annots in
  let desc = Format.asprintf "%a" pp_strategy_info config in
  WpStrategy.mk_strategy desc config.cfg (behavior_name_of_config config)
    WpStrategy.SKannots annots

(* Visit the CFG to find all the internal statement specifications.
 * (see [HdefAnnotBhv] documentation for information about this table).
*)
let internal_function_behaviors cfg =
  let def_annot_bhv = HdefAnnotBhv.create 42 in
  let get_stmt_bhv node stmt acc =
    let add_bhv_info active acc b =
      if is_empty_behavior b then acc else
        begin
          if b.b_name = Cil.default_behavior_name then
            begin
              let _, int_edges = Cil2cfg.get_internal_edges cfg node in
              let n = Cil2cfg.Eset.cardinal int_edges in
              let reg e =
                try
                  let (_old_s, old_n) = HdefAnnotBhv.find def_annot_bhv e in
                  if n < old_n then
                    (* new spec is included in the old one : override. *)
                    raise Not_found
                with Not_found ->
                  HdefAnnotBhv.replace def_annot_bhv e (stmt, n)
              in
              Cil2cfg.Eset.iter reg int_edges
            end;
          (node, stmt, active, b)::acc
        end
    in
    let spec_bhv_names acc annot = match annot with
      | {annot_content = AStmtSpec (active, spec)} ->
          List.fold_left (add_bhv_info active) acc spec.spec_behavior
      | _ -> Wp_parameters.fatal "filter on is_contract didn't work ?"
    in
    let annots = Annotations.code_annot ~filter:Logic_utils.is_contract stmt in
    List.fold_left spec_bhv_names acc annots
  in
  let get_bhv n ((seen_stmts, bhvs) as l) =
    match Cil2cfg.start_stmt_of_node n with None -> l
                                          | Some s ->
                                              if List.mem s.sid seen_stmts then l
                                              else
                                                let seen_stmts = s.sid::seen_stmts in
                                                let bhvs = get_stmt_bhv n s bhvs in
                                                (seen_stmts, bhvs)
  in
  let _, bhvs = Cil2cfg.fold_nodes get_bhv cfg ([], []) in
  bhvs, def_annot_bhv


(** empty [bhv_names] means all (whatever [ki] is) *)
let find_behaviors kf cfg ki bhv_names =
  let f_bhvs = Annotations.behaviors kf in
  let s_bhvs, def_annot_bhv = internal_function_behaviors cfg in

  let add_fct_bhv (def, acc) b =
    let add () =
      let def = if Cil.is_default_behavior b then true else def in
      def, (FunBhv (Some b))::acc
    in
    if bhv_names = [] then add()
    else match ki with
      | None (* not specified ki *) | Some Kglobal ->
          if List.mem b.b_name bhv_names then add () else (def, acc)
      | Some Kstmt _ -> def, acc
  in

  let add_stmt_bhv acc (n,s,active,b) =
    let active = Datatype.String.Set.of_list active in
    if bhv_names = [] then (StmtBhv (n,s,active,b))::acc
    else if List.mem b.b_name bhv_names then
      let acc = match ki with
        | None -> (* not specified ki *) (StmtBhv (n, s, active, b))::acc
        | Some (Kstmt stmt) when stmt.sid = s.sid ->
            (StmtBhv (n, s, active, b))::acc
        | _ -> (* specified ki but not this one *) acc
      in acc
    else acc
  in

  let f_bhvs = List.rev f_bhvs in (* for compatibility with previous version *)
  let def, bhvs = List.fold_left add_fct_bhv (false, []) f_bhvs in
  let bhvs = List.fold_left add_stmt_bhv bhvs s_bhvs in
  let bhvs =
    if def then (* fct default behavior already in *) bhvs
    else if bhv_names = [] then (FunBhv None)::bhvs
    else match ki with
      | None (* not specified ki *) | Some Kglobal ->
          if List.mem Cil.default_behavior_name bhv_names
          then (FunBhv None)::bhvs
          else bhvs
      | Some Kstmt _ -> bhvs
  in def_annot_bhv, bhvs

(*----------------------------------------------------------------------------*)
(* Unreachable                                                                *)
(*----------------------------------------------------------------------------*)

class vexit kf acc =
  object
    inherit Visitor.frama_c_inplace
    val mutable ips = acc
    method acc = ips
    method! vstmt_aux stmt =
      Annotations.iter_code_annot
        (fun _e ca ->
           match ca.annot_content with
           | AStmtSpec(_,spec) ->
               List.iter
                 (fun bhv ->
                    List.iter
                      (fun post ->
                         if fst post = Exits then
                           let ip = WpPropId.mk_stmt_post_id kf stmt bhv post in
                           ips <- ip :: ips
                      ) bhv.b_post_cond
                 ) spec.spec_behavior
           | _ -> ()
        ) stmt ;
      Cil.DoChildren
  end

let process_unreached_annots cfg =
  debug "collecting unreachable annotations@.";
  let unreached = Cil2cfg.unreachable_nodes cfg in
  let kf = Cil2cfg.cfg_kf cfg in
  let spec = Annotations.funspec kf in
  let add_id acc id =
    if filter_status id then id::acc
    else (* non-selected property : nothing to do *) acc
  in
  let do_post b tk acc (termk, _ as p) =
    if tk = termk then add_id acc (WpPropId.mk_fct_post_id kf b p) else acc
  in
  let do_bhv termk acc b = List.fold_left (do_post b termk) acc b.b_post_cond in
  let do_annot s _ a acc =
    List.fold_left add_id acc (WpPropId.mk_code_annot_ids kf s a)
  in
  let do_node acc n =
    debug
      "process annotations of unreachable node %a@."
      Cil2cfg.pp_node_type n;
    match n with
    | Cil2cfg.Vstart -> Wp_parameters.fatal "Start must be reachable"
    | Cil2cfg.VfctIn -> Wp_parameters.fatal "FctIn must be reachable"
    | Cil2cfg.VfctOut  -> List.fold_left (do_bhv Normal) acc spec.spec_behavior
    | Cil2cfg.VfctErr  ->
        let acc = List.fold_left (do_bhv Exits) acc spec.spec_behavior in
        let visitor = new vexit kf acc in
        ignore Visitor.(visitFramacKf (visitor :> frama_c_visitor) kf) ;
        visitor#acc
    | Cil2cfg.Vcall (s, _, call, _) ->
        Annotations.fold_code_annot (do_annot s) s acc @
        preconditions_at_call s call
    | Cil2cfg.Vstmt s
    | Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _)
    | Cil2cfg.VblkOut (Cil2cfg.Bstmt s, _)
    | Cil2cfg.Vtest (true, s, _) | Cil2cfg.Vloop (_, s) | Cil2cfg.Vswitch (s,_)
      -> Annotations.fold_code_annot (do_annot s) s acc
    | Cil2cfg.Vtest (false, _, _) | Cil2cfg.Vloop2 _
    | Cil2cfg.VblkIn _ | Cil2cfg.VblkOut _ | Cil2cfg.Vend -> acc
  in
  let annots = List.fold_left do_node [] unreached in
  debug "found %d unreachable annotations@." (List.length annots) ;
  List.iter (fun pid -> set_unreachable pid) annots

(*----------------------------------------------------------------------------*)
(* Everything must go through here.                                           *)
(*----------------------------------------------------------------------------*)

let get_cfg kf model =
  if Wp_parameters.RTE.get () then WpRTE.generate model kf ;
  let cfg = Cil2cfg.get kf in
  let _ = process_unreached_annots cfg in cfg

let build_configs assigns kf model behaviors ki property =
  debug "[get_strategies] for behaviors names: %a@."
    (Wp_error.pp_string_list ~sep:" " ~empty:"<none>")
    (match behaviors with [] -> ["<all>"] | _ :: _ as l -> l) ;
  let _ = match ki with
    | None -> ()
    | Some Kglobal ->
        debug
          "[get_strategies] select in function properties@."
    | Some (Kstmt s) ->
        debug
          "[get_strategies] select stmt %d properties@." s.sid
  in
  let cfg = get_cfg kf model in
  let reached =
    if Wp_parameters.SmokeTests.get ()
    && Wp_parameters.SmokeDeadcode.get ()
    then Some (WpReached.reached kf)
    else None in
  let def_annot_bhv, bhvs = find_behaviors kf cfg ki behaviors in
  if bhvs <> [] then debug "[get_strategies] %d behaviors" (List.length bhvs);
  let mk_bhv_config bhv = {
    kf; reached; cfg;
    cur_bhv = bhv;
    asked_prop = property;
    asked_bhvs = bhvs;
    assigns_filter = assigns;
    def_annots_info = def_annot_bhv;
  } in List.map mk_bhv_config bhvs

let get_strategies assigns kf model behaviors ki property =
  let configs = build_configs assigns kf model behaviors ki property in
  let rec add_stgs l = match l with [] -> [] | config::tl ->
    let stg = build_bhv_strategy config in
    stg::(add_stgs tl)
  in add_stgs configs

(*----------------------------------------------------------------------------*)
(* Public functions to build the strategies                                   *)
(*----------------------------------------------------------------------------*)

let get_precond_strategies ~model p =
  debug "[get_precond_strategies] %s@."
    (Property.Names.get_prop_name_id p);
  let open Property in
  match p with
  | IPPredicate {ip_kind = PKRequires b; ip_kf; ip_kinstr = Kglobal} ->
      let strategies =
        if WpStrategy.is_main_init ip_kf then
          get_strategies NoAssigns ip_kf model [b.b_name] None (IdProp p)
        else []
      in
      let call_sites = Kernel_function.find_syntactic_callsites ip_kf in
      let add_call_pre_strategy acc (kf_caller, stmt) =
        let asked = CallPre (stmt, Some p) in
        get_strategies NoAssigns kf_caller model [] None asked @ acc
      in
      if call_sites = [] then
        (Wp_parameters.warning ~once:true
           "No direct call sites for function '%a': cannot check pre-conditions"
           Kernel_function.pretty ip_kf;
         strategies)
      else List.fold_left add_call_pre_strategy strategies call_sites
  | _ ->
      invalid_arg "[get_precond_strategies] not a function precondition"

let get_call_pre_strategies ~model stmt =
  debug
    "[get_call_pre_strategies] on statement %a@." Stmt.pretty_sid stmt;
  match stmt.skind with
  | Instr(Call(_,f,_,_)) ->
      let strategies = match Kernel_function.get_called f with
        | None ->
            Wp_parameters.warning
              "Call through function pointer not implemented yet: \
               cannot check pre-conditions for statement %a"
              Stmt.pretty_sid stmt;
            []
        | Some _kf_called ->
            let kf_caller = Kernel_function.find_englobing_kf stmt in
            let asked = CallPre (stmt, None) in
            get_strategies NoAssigns kf_caller model [] None asked
      in strategies
  | Instr(Local_init(_, ConsInit _, _)) ->
      let kf_caller = Kernel_function.find_englobing_kf stmt in
      let asked = CallPre(stmt, None) in
      get_strategies NoAssigns kf_caller model [] None asked
  | _ -> Wp_parameters.warning
           "[get_call_pre_strategies] this is not a call statement"; []

let get_id_prop_strategies ~model ?(assigns=WithAssigns) p =
  debug "[get_id_prop_strategies] %s@."
    (Property.Names.get_prop_name_id p);
  let open Property in match p with
  | IPCodeAnnot {ica_kf; ica_ca} ->
      let bhvs = match ica_ca.annot_content with
        | AAssert (l, _) | AInvariant (l, _, _) | AAssigns (l, _) -> l
        | _ -> []
      in get_strategies assigns ica_kf model bhvs None (IdProp p)
  | IPAssigns {ias_kf = kf; ias_bhv = Id_loop _}
  (*loop assigns: belongs to the default behavior *)
  | IPDecrease {id_kf = kf} ->
      (* any variant property is attached to the default behavior of
       * the function, NOT to a statement behavior *)
      let bhvs = [ Cil.default_behavior_name ] in
      get_strategies assigns kf model bhvs None (IdProp p)
  | IPPredicate {ip_kind = PKRequires _; ip_kinstr = Kglobal} ->
      get_precond_strategies model p
  | _ ->
      let strategies = match get_kf p with
        | None -> Wp_parameters.warning
                    "WP of property outside functions: ignore %s"
                    (Property.Names.get_prop_name_id p); []
        | Some kf ->
            let ki = Some (get_kinstr p) in
            let bhv = match get_behavior p with
              | None -> Cil.default_behavior_name
              | Some fb -> fb.b_name
            in get_strategies assigns kf model [bhv] ki (IdProp p)
      in strategies

let get_function_strategies ~model
    ?(assigns=WithAssigns) ?(bhv=[]) ?(prop=[]) kf =
  let prop = match prop with [] -> AllProps | _ -> NamedProp prop in
  get_strategies assigns kf model bhv None prop
